packages feed

ghc-lib-parser 9.6.7.20250325 → 9.14.1.20251220

raw patch · 499 files changed

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

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
@@ -16,6 +16,7 @@  *   - the closure flags table in rts/ClosureFlags.c  *   - isRetainer in rts/RetainerProfile.c  *   - the closure_type_names list in rts/Printer.c+ *   - the ClosureType sum type in libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs  */  /* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B@@ -88,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
@@ -1,7 +1,8 @@  import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \-    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64))+    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \+    || defined(MACHREGS_riscv64) || defined(MACHREGS_loongarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg@@ -203,6 +204,39 @@ # define d29 61 # define d30 62 # define d31 63++# define q0 32+# define q1 33+# define q2 34+# define q3 35+# define q4 36+# define q5 37+# define q6 38+# define q7 39+# define q8 40+# define q9 41+# define q10 42+# define q11 43+# define q12 44+# define q13 45+# define q14 46+# define q15 47+# define q16 48+# define q17 49+# define q18 50+# define q19 51+# define q20 52+# define q21 53+# define q22 54+# define q23 55+# define q24 56+# define q25 57+# define q26 58+# define q27 59+# define q28 60+# define q29 61+# define q30 62+# define q31 63 #endif  # if defined(MACHREGS_darwin)@@ -447,39 +481,40 @@  #endif +-- See also Note [Caller saves and callee-saves regs.] callerSaves :: GlobalReg -> Bool #if defined(CALLER_SAVES_Base) callerSaves BaseReg           = True #endif #if defined(CALLER_SAVES_R1)-callerSaves (VanillaReg 1 _)  = True+callerSaves (VanillaReg 1)    = True #endif #if defined(CALLER_SAVES_R2)-callerSaves (VanillaReg 2 _)  = True+callerSaves (VanillaReg 2)    = True #endif #if defined(CALLER_SAVES_R3)-callerSaves (VanillaReg 3 _)  = True+callerSaves (VanillaReg 3)    = True #endif #if defined(CALLER_SAVES_R4)-callerSaves (VanillaReg 4 _)  = True+callerSaves (VanillaReg 4)    = True #endif #if defined(CALLER_SAVES_R5)-callerSaves (VanillaReg 5 _)  = True+callerSaves (VanillaReg 5)    = True #endif #if defined(CALLER_SAVES_R6)-callerSaves (VanillaReg 6 _)  = True+callerSaves (VanillaReg 6)    = True #endif #if defined(CALLER_SAVES_R7)-callerSaves (VanillaReg 7 _)  = True+callerSaves (VanillaReg 7)    = True #endif #if defined(CALLER_SAVES_R8)-callerSaves (VanillaReg 8 _)  = True+callerSaves (VanillaReg 8)    = True #endif #if defined(CALLER_SAVES_R9)-callerSaves (VanillaReg 9 _)  = True+callerSaves (VanillaReg 9)    = True #endif #if defined(CALLER_SAVES_R10)-callerSaves (VanillaReg 10 _) = True+callerSaves (VanillaReg 10)   = True #endif #if defined(CALLER_SAVES_F1) callerSaves (FloatReg 1)      = True@@ -555,34 +590,34 @@     ,Hp #endif #if defined(REG_R1)-    ,VanillaReg 1 VGcPtr+    ,VanillaReg 1 #endif #if defined(REG_R2)-    ,VanillaReg 2 VGcPtr+    ,VanillaReg 2 #endif #if defined(REG_R3)-    ,VanillaReg 3 VGcPtr+    ,VanillaReg 3 #endif #if defined(REG_R4)-    ,VanillaReg 4 VGcPtr+    ,VanillaReg 4 #endif #if defined(REG_R5)-    ,VanillaReg 5 VGcPtr+    ,VanillaReg 5 #endif #if defined(REG_R6)-    ,VanillaReg 6 VGcPtr+    ,VanillaReg 6 #endif #if defined(REG_R7)-    ,VanillaReg 7 VGcPtr+    ,VanillaReg 7 #endif #if defined(REG_R8)-    ,VanillaReg 8 VGcPtr+    ,VanillaReg 8 #endif #if defined(REG_R9)-    ,VanillaReg 9 VGcPtr+    ,VanillaReg 9 #endif #if defined(REG_R10)-    ,VanillaReg 10 VGcPtr+    ,VanillaReg 10 #endif #if defined(REG_SpLim)     ,SpLim@@ -740,34 +775,34 @@ globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base) # endif # if defined(REG_R1)-globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)+globalRegMaybe (VanillaReg 1)           = Just (RealRegSingle REG_R1) # endif # if defined(REG_R2)-globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)+globalRegMaybe (VanillaReg 2)           = Just (RealRegSingle REG_R2) # endif # if defined(REG_R3)-globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)+globalRegMaybe (VanillaReg 3)           = Just (RealRegSingle REG_R3) # endif # if defined(REG_R4)-globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)+globalRegMaybe (VanillaReg 4)           = Just (RealRegSingle REG_R4) # endif # if defined(REG_R5)-globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)+globalRegMaybe (VanillaReg 5)           = Just (RealRegSingle REG_R5) # endif # if defined(REG_R6)-globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)+globalRegMaybe (VanillaReg 6)           = Just (RealRegSingle REG_R6) # endif # if defined(REG_R7)-globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)+globalRegMaybe (VanillaReg 7)           = Just (RealRegSingle REG_R7) # endif # if defined(REG_R8)-globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)+globalRegMaybe (VanillaReg 8)           = Just (RealRegSingle REG_R8) # endif # if defined(REG_R9)-globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)+globalRegMaybe (VanillaReg 9)           = Just (RealRegSingle REG_R9) # endif # if defined(REG_R10)-globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)+globalRegMaybe (VanillaReg 10)          = Just (RealRegSingle REG_R10) # endif # if defined(REG_F1) globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)@@ -997,13 +1032,214 @@ -- 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++# 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_riscv64)++-- zero reg+freeReg 0 = False+-- link register+freeReg 1 = False+-- stack pointer+freeReg 2 = False+-- global pointer+freeReg 3 = False+-- thread pointer+freeReg 4 = False+-- frame pointer+freeReg 8 = False+-- 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
@@ -4,2820 +4,2774 @@ \section[GHC.Builtin.Names]{Definitions of prelude modules and names}  -Nota Bene: all Names defined in here should come from the base package-- - ModuleNames for prelude modules,-        e.g.    pREL_BASE_Name :: ModuleName-- - Modules for prelude modules-        e.g.    pREL_Base :: Module-- - Uniques for Ids, DataCons, TyCons and Classes that the compiler-   "knows about" in some way-        e.g.    intTyConKey :: Unique-                minusClassOpKey :: Unique-- - Names for Ids, DataCons, TyCons and Classes that the compiler-   "knows about" in some way-        e.g.    intTyConName :: Name-                minusName    :: Name-   One of these Names contains-        (a) the module and occurrence name of the thing-        (b) its Unique-   The way the compiler "knows about" one of these things is-   where the type checker or desugarer needs to look it up. For-   example, when desugaring list comprehensions the desugarer-   needs to conjure up 'foldr'.  It does this by looking up-   foldrName in the environment.-- - RdrNames for Ids, DataCons etc that the compiler may emit into-   generated code (e.g. for deriving).  It's not necessary to know-   the uniques for these guys, only their names---Note [Known-key names]-~~~~~~~~~~~~~~~~~~~~~~-It is *very* important that the compiler gives wired-in things and-things with "known-key" names the correct Uniques wherever they-occur. We have to be careful about this in exactly two places:--  1. When we parse some source code, renaming the AST better yield an-     AST whose Names have the correct uniques--  2. When we read an interface file, the read-in gubbins better have-     the right uniques--This is accomplished through a combination of mechanisms:--  1. When parsing source code, the RdrName-decorated AST has some-     RdrNames which are Exact. These are wired-in RdrNames where-     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.--     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).--  2. The knownKeyNames (which consist of the basicKnownKeyNames from-     the module, and those names reachable via the wired-in stuff from-     GHC.Builtin.Types) are used to initialise the "OrigNameCache" in-     GHC.Iface.Env.  This initialization ensures that when the type checker-     or renamer (both of which use GHC.Iface.Env) look up an original name-     (i.e. a pair of a Module and an OccName) for a known-key name-     they get the correct Unique.--     This is the most important mechanism for ensuring that known-key-     stuff gets the right Unique, and is why it is so important to-     place your known-key names in the appropriate lists.--  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.---Note [Infinite families of known-key names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Infinite families of known-key things (e.g. tuples and sums) pose a tricky-problem: we can't add them to the knownKeyNames finite map which we use to-ensure that, e.g., a reference to (,) gets assigned the right unique (if this-doesn't sound familiar see Note [Known-key names] above).--We instead handle tuples and sums separately from the "vanilla" known-key-things,--  a) The parser recognises them specially and generates an Exact Name (hence not-     looked up in the orig-name cache)--  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.--     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 #-}--module GHC.Builtin.Names-   ( Unique, Uniquable(..), hasKey,  -- Re-exported for convenience--   ------------------------------------------------------------   module GHC.Builtin.Names, -- A huge bunch of (a) Names,  e.g. intTyConName-                             --                 (b) Uniques e.g. intTyConKey-                             --                 (c) Groups of classes and types-                             --                 (d) miscellaneous things-                             -- So many that we export them all-   )-where--import GHC.Prelude--import GHC.Unit.Types-import GHC.Types.Name.Occurrence-import GHC.Types.Name.Reader-import GHC.Types.Unique-import GHC.Builtin.Uniques-import GHC.Types.Name-import GHC.Types.SrcLoc-import GHC.Data.FastString-import GHC.Data.List.Infinite (Infinite (..))-import qualified GHC.Data.List.Infinite as Inf--import Language.Haskell.Syntax.Module.Name--{--************************************************************************-*                                                                      *-     allNameStrings-*                                                                      *-************************************************************************--}--allNameStrings :: Infinite String--- Infinite list of a,b,c...z, aa, ab, ac, ... etc-allNameStrings = Inf.allListsOf ['a'..'z']--allNameStringList :: [String]--- Infinite list of a,b,c...z, aa, ab, ac, ... etc-allNameStringList = Inf.toList allNameStrings--{--************************************************************************-*                                                                      *-\subsection{Local Names}-*                                                                      *-************************************************************************--This *local* name is used by the interactive stuff--}--itName :: Unique -> SrcSpan -> Name-itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc---- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly--- during compiler debugging.-mkUnboundName :: OccName -> Name-mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan--isUnboundName :: Name -> Bool-isUnboundName name = name `hasKey` unboundKey--{--************************************************************************-*                                                                      *-\subsection{Known key Names}-*                                                                      *-************************************************************************--This section tells what the compiler knows about the association of-names with uniques.  These ones are the *non* wired-in ones.  The-wired in ones are defined in GHC.Builtin.Types etc.--}--basicKnownKeyNames :: [Name]  -- See Note [Known-key names]-basicKnownKeyNames- = genericTyConNames- ++ [   --  Classes.  *Must* include:-        --      classes that are grabbed by key (e.g., eqClassKey)-        --      classes in "Class.standardClassKeys" (quite a few)-        eqClassName,                    -- mentioned, derivable-        ordClassName,                   -- derivable-        boundedClassName,               -- derivable-        numClassName,                   -- mentioned, numeric-        enumClassName,                  -- derivable-        monadClassName,-        functorClassName,-        realClassName,                  -- numeric-        integralClassName,              -- numeric-        fractionalClassName,            -- numeric-        floatingClassName,              -- numeric-        realFracClassName,              -- numeric-        realFloatClassName,             -- numeric-        dataClassName,-        isStringClassName,-        applicativeClassName,-        alternativeClassName,-        foldableClassName,-        traversableClassName,-        semigroupClassName, sappendName,-        monoidClassName, memptyName, mappendName, mconcatName,--        -- The IO type-        ioTyConName, ioDataConName,-        runMainIOName,-        runRWName,--        -- Type representation types-        trModuleTyConName, trModuleDataConName,-        trNameTyConName, trNameSDataConName, trNameDDataConName,-        trTyConTyConName, trTyConDataConName,--        -- Typeable-        typeableClassName,-        typeRepTyConName,-        someTypeRepTyConName,-        someTypeRepDataConName,-        kindRepTyConName,-        kindRepTyConAppDataConName,-        kindRepVarDataConName,-        kindRepAppDataConName,-        kindRepFunDataConName,-        kindRepTYPEDataConName,-        kindRepTypeLitSDataConName,-        kindRepTypeLitDDataConName,-        typeLitSortTyConName,-        typeLitSymbolDataConName,-        typeLitNatDataConName,-        typeLitCharDataConName,-        typeRepIdName,-        mkTrTypeName,-        mkTrConName,-        mkTrAppName,-        mkTrFunName,-        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,-        trGhcPrimModuleName,--        -- KindReps for common cases-        starKindRepName,-        starArrStarKindRepName,-        starArrStarArrStarKindRepName,-        constraintKindRepName,--        -- WithDict-        withDictClassName,--        -- Dynamic-        toDynName,--        -- Numeric stuff-        negateName, minusName, geName, eqName,-        mkRationalBase2Name, mkRationalBase10Name,--        -- Conversion functions-        rationalTyConName,-        ratioTyConName, ratioDataConName,-        fromRationalName, fromIntegerName,-        toIntegerName, toRationalName,-        fromIntegralName, realToFracName,--        -- Int# stuff-        divIntName, modIntName,--        -- String stuff-        fromStringName,--        -- Enum stuff-        enumFromName, enumFromThenName,-        enumFromThenToName, enumFromToName,--        -- Applicative stuff-        pureAName, apAName, thenAName,--        -- Functor stuff-        fmapName,--        -- Monad stuff-        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,-        returnMName, joinMName,--        -- MonadFail-        monadFailClassName, failMName,--        -- MonadFix-        monadFixClassName, mfixName,--        -- Arrow stuff-        arrAName, composeAName, firstAName,-        appAName, choiceAName, loopAName,--        -- Ix stuff-        ixClassName,--        -- Show stuff-        showClassName,--        -- Read stuff-        readClassName,--        -- Stable pointers-        newStablePtrName,--        -- GHC Extensions-        considerAccessibleName,--        -- Strings and lists-        unpackCStringName, unpackCStringUtf8Name,-        unpackCStringAppendName, unpackCStringAppendUtf8Name,-        unpackCStringFoldrName, unpackCStringFoldrUtf8Name,-        cstringLengthName,--        -- Overloaded lists-        isListClassName,-        fromListName,-        fromListNName,-        toListName,--        -- Non-empty lists-        nonEmptyTyConName,--        -- Overloaded record dot, record update-        getFieldName, setFieldName,--        -- List operations-        concatName, filterName, mapName,-        zipName, foldrName, buildName, augmentName, appendName,--        -- FFI primitive types that are not wired-in.-        stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,-        int8TyConName, int16TyConName, int32TyConName, int64TyConName,-        word8TyConName, word16TyConName, word32TyConName, word64TyConName,--        -- Others-        otherwiseIdName, inlineIdName,-        eqStringName, assertName,-        assertErrorName, traceName,-        printName,-        dollarName,--        -- ghc-bignum-        integerFromNaturalName,-        integerToNaturalClampName,-        integerToNaturalThrowName,-        integerToNaturalName,-        integerToWordName,-        integerToIntName,-        integerToWord64Name,-        integerToInt64Name,-        integerFromWordName,-        integerFromWord64Name,-        integerFromInt64Name,-        integerAddName,-        integerMulName,-        integerSubName,-        integerNegateName,-        integerAbsName,-        integerPopCountName,-        integerQuotName,-        integerRemName,-        integerDivName,-        integerModName,-        integerDivModName,-        integerQuotRemName,-        integerEncodeFloatName,-        integerEncodeDoubleName,-        integerGcdName,-        integerLcmName,-        integerAndName,-        integerOrName,-        integerXorName,-        integerComplementName,-        integerBitName,-        integerTestBitName,-        integerShiftLName,-        integerShiftRName,--        naturalToWordName,-        naturalPopCountName,-        naturalShiftRName,-        naturalShiftLName,-        naturalAddName,-        naturalSubName,-        naturalSubThrowName,-        naturalSubUnsafeName,-        naturalMulName,-        naturalQuotRemName,-        naturalQuotName,-        naturalRemName,-        naturalAndName,-        naturalAndNotName,-        naturalOrName,-        naturalXorName,-        naturalTestBitName,-        naturalBitName,-        naturalGcdName,-        naturalLcmName,-        naturalLog2Name,-        naturalLogBaseWordName,-        naturalLogBaseName,-        naturalPowModName,-        naturalSizeInBaseName,--        bignatFromWordListName,-        bignatEqName,--        -- Float/Double-        integerToFloatName,-        integerToDoubleName,-        naturalToFloatName,-        naturalToDoubleName,-        rationalToFloatName,-        rationalToDoubleName,--        -- Other classes-        monadPlusClassName,--        -- Type-level naturals-        knownNatClassName, knownSymbolClassName, knownCharClassName,--        -- Overloaded labels-        fromLabelClassOpName,--        -- Implicit Parameters-        ipClassName,--        -- Overloaded record fields-        hasFieldClassName,--        -- Call Stacks-        callStackTyConName,-        emptyCallStackName, pushCallStackName,--        -- Source Locations-        srcLocDataConName,--        -- Annotation type checking-        toAnnotationWrapperName--        -- The SPEC type for SpecConstr-        , specTyConName--        -- The Either type-        , eitherTyConName, leftDataConName, rightDataConName--        -- The Void type-        , voidTyConName--        -- Plugins-        , pluginTyConName-        , frontendPluginTyConName--        -- Generics-        , genClassName, gen1ClassName-        , datatypeClassName, constructorClassName, selectorClassName--        -- Monad comprehensions-        , guardMName-        , liftMName-        , mzipName--        -- GHCi Sandbox-        , ghciIoClassName, ghciStepIoMName--        -- StaticPtr-        , makeStaticName-        , staticPtrTyConName-        , staticPtrDataConName, staticPtrInfoDataConName-        , fromStaticPtrName--        -- Fingerprint-        , fingerprintDataConName--        -- Custom type errors-        , errorMessageTypeErrorFamName-        , typeErrorTextDataConName-        , typeErrorAppendDataConName-        , typeErrorVAppendDataConName-        , typeErrorShowTypeDataConName--        -- Unsafe coercion proofs-        , unsafeEqualityProofName-        , unsafeEqualityTyConName-        , unsafeReflDataConName-        , unsafeCoercePrimName-    ]--genericTyConNames :: [Name]-genericTyConNames = [-    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,-    k1TyConName, m1TyConName, sumTyConName, prodTyConName,-    compTyConName, rTyConName, dTyConName,-    cTyConName, sTyConName, rec0TyConName,-    d1TyConName, c1TyConName, s1TyConName,-    repTyConName, rep1TyConName, uRecTyConName,-    uAddrTyConName, uCharTyConName, uDoubleTyConName,-    uFloatTyConName, uIntTyConName, uWordTyConName,-    prefixIDataConName, infixIDataConName, leftAssociativeDataConName,-    rightAssociativeDataConName, notAssociativeDataConName,-    sourceUnpackDataConName, sourceNoUnpackDataConName,-    noSourceUnpackednessDataConName, sourceLazyDataConName,-    sourceStrictDataConName, noSourceStrictnessDataConName,-    decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,-    metaDataDataConName, metaConsDataConName, metaSelDataConName-  ]--{--************************************************************************-*                                                                      *-\subsection{Module names}-*                                                                      *-************************************************************************-----MetaHaskell Extension Add a new module here--}--pRELUDE :: Module-pRELUDE         = mkBaseModule_ pRELUDE_NAME--gHC_PRIM, gHC_PRIM_PANIC,-    gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,-    gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,-    gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,-    gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,-    gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,-    gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_LIST, dATA_STRING,-    dATA_FOLDABLE, dATA_TRAVERSABLE,-    gHC_CONC, gHC_IO, gHC_IO_Exception,-    gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,-    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,-    tYPEABLE, tYPEABLE_INTERNAL, gENERICS,-    rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,-    aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,-    cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,-    gHC_TYPENATS, gHC_TYPENATS_INTERNAL,-    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: 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_BASE        = mkBaseModule (fsLit "GHC.Base")-gHC_ENUM        = mkBaseModule (fsLit "GHC.Enum")-gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")-gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers")-gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")-gHC_READ        = mkBaseModule (fsLit "GHC.Read")-gHC_NUM         = mkBaseModule (fsLit "GHC.Num")-gHC_MAYBE       = mkBaseModule (fsLit "GHC.Maybe")-gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer")-gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural")-gHC_NUM_BIGNAT  = mkBignumModule (fsLit "GHC.Num.BigNat")-gHC_LIST        = mkBaseModule (fsLit "GHC.List")-gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")-gHC_TUPLE_PRIM  = mkPrimModule (fsLit "GHC.Tuple.Prim")-dATA_EITHER     = mkBaseModule (fsLit "Data.Either")-dATA_LIST       = mkBaseModule (fsLit "Data.List")-dATA_STRING     = mkBaseModule (fsLit "Data.String")-dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")-dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")-gHC_CONC        = mkBaseModule (fsLit "GHC.Conc")-gHC_IO          = mkBaseModule (fsLit "GHC.IO")-gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")-gHC_ST          = mkBaseModule (fsLit "GHC.ST")-gHC_IX          = mkBaseModule (fsLit "GHC.Ix")-gHC_STABLE      = mkBaseModule (fsLit "GHC.Stable")-gHC_PTR         = mkBaseModule (fsLit "GHC.Ptr")-gHC_ERR         = mkBaseModule (fsLit "GHC.Err")-gHC_REAL        = mkBaseModule (fsLit "GHC.Real")-gHC_FLOAT       = mkBaseModule (fsLit "GHC.Float")-gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler")-sYSTEM_IO       = mkBaseModule (fsLit "System.IO")-dYNAMIC         = mkBaseModule (fsLit "Data.Dynamic")-tYPEABLE        = mkBaseModule (fsLit "Data.Typeable")-tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")-gENERICS        = mkBaseModule (fsLit "Data.Data")-rEAD_PREC       = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")-lEX             = mkBaseModule (fsLit "Text.Read.Lex")-gHC_INT         = mkBaseModule (fsLit "GHC.Int")-gHC_WORD        = mkBaseModule (fsLit "GHC.Word")-mONAD           = mkBaseModule (fsLit "Control.Monad")-mONAD_FIX       = mkBaseModule (fsLit "Control.Monad.Fix")-mONAD_ZIP       = mkBaseModule (fsLit "Control.Monad.Zip")-mONAD_FAIL      = mkBaseModule (fsLit "Control.Monad.Fail")-aRROW           = mkBaseModule (fsLit "Control.Arrow")-gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")-rANDOM          = mkBaseModule (fsLit "System.Random")-gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")-gHC_IS_LIST     = mkBaseModule (fsLit "GHC.IsList")-cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")-gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")-gHC_TYPEERROR   = mkBaseModule (fsLit "GHC.TypeError")-gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")-gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal")-gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")-gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal")-dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")-dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")-uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")-fOREIGN_C_CONSTPTR = mkBaseModule (fsLit "Foreign.C.ConstPtr")--gHC_SRCLOC :: Module-gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")--gHC_STACK, gHC_STACK_TYPES :: Module-gHC_STACK = mkBaseModule (fsLit "GHC.Stack")-gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")--gHC_STATICPTR :: Module-gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")--gHC_STATICPTR_INTERNAL :: Module-gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal")--gHC_FINGERPRINT_TYPE :: Module-gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")--gHC_OVER_LABELS :: Module-gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")--gHC_RECORDS :: Module-gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")--rOOT_MAIN :: Module-rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation--mkInteractiveModule :: Int -> Module--- (mkInteractiveMoudule 9) makes module 'interactive:Ghci9'-mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))--pRELUDE_NAME, mAIN_NAME :: ModuleName-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)--mkBaseModule :: FastString -> Module-mkBaseModule m = mkBaseModule_ (mkModuleNameFS m)--mkBaseModule_ :: ModuleName -> Module-mkBaseModule_ m = mkModule baseUnit m--mkThisGhcModule :: FastString -> Module-mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)--mkThisGhcModule_ :: ModuleName -> Module-mkThisGhcModule_ m = mkModule thisGhcUnit m--mkMainModule :: FastString -> Module-mkMainModule m = mkModule mainUnit (mkModuleNameFS m)--mkMainModule_ :: ModuleName -> Module-mkMainModule_ m = mkModule mainUnit m--{--************************************************************************-*                                                                      *-                        RdrNames-*                                                                      *-************************************************************************--}--main_RDR_Unqual    :: RdrName-main_RDR_Unqual = mkUnqual varName (fsLit "main")-        -- We definitely don't want an Orig RdrName, because-        -- main might, in principle, be imported into module Main--eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR,-    ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName-eq_RDR                  = nameRdrName eqName-ge_RDR                  = nameRdrName geName-le_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<=")-lt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<")-gt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit ">")-compare_RDR             = varQual_RDR  gHC_CLASSES (fsLit "compare")-ltTag_RDR               = nameRdrName  ordLTDataConName-eqTag_RDR               = nameRdrName  ordEQDataConName-gtTag_RDR               = nameRdrName  ordGTDataConName--eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR-    :: RdrName-eqClass_RDR             = nameRdrName eqClassName-numClass_RDR            = nameRdrName numClassName-ordClass_RDR            = nameRdrName ordClassName-enumClass_RDR           = nameRdrName enumClassName-monadClass_RDR          = nameRdrName monadClassName--map_RDR, append_RDR :: RdrName-map_RDR                 = nameRdrName mapName-append_RDR              = nameRdrName appendName--foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR-    :: RdrName-foldr_RDR               = nameRdrName foldrName-build_RDR               = nameRdrName buildName-returnM_RDR             = nameRdrName returnMName-bindM_RDR               = nameRdrName bindMName-failM_RDR               = nameRdrName failMName--left_RDR, right_RDR :: RdrName-left_RDR                = nameRdrName leftDataConName-right_RDR               = nameRdrName rightDataConName--fromEnum_RDR, toEnum_RDR :: RdrName-fromEnum_RDR            = varQual_RDR gHC_ENUM (fsLit "fromEnum")-toEnum_RDR              = varQual_RDR gHC_ENUM (fsLit "toEnum")--enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName-enumFrom_RDR            = nameRdrName enumFromName-enumFromTo_RDR          = nameRdrName enumFromToName-enumFromThen_RDR        = nameRdrName enumFromThenName-enumFromThenTo_RDR      = nameRdrName enumFromThenToName--ratioDataCon_RDR, integerAdd_RDR, integerMul_RDR :: RdrName-ratioDataCon_RDR        = nameRdrName ratioDataConName-integerAdd_RDR          = nameRdrName integerAddName-integerMul_RDR          = nameRdrName integerMulName--ioDataCon_RDR :: RdrName-ioDataCon_RDR           = nameRdrName ioDataConName--newStablePtr_RDR :: RdrName-newStablePtr_RDR        = nameRdrName newStablePtrName--bindIO_RDR, returnIO_RDR :: RdrName-bindIO_RDR              = nameRdrName bindIOName-returnIO_RDR            = nameRdrName returnIOName--fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName-fromInteger_RDR         = nameRdrName fromIntegerName-fromRational_RDR        = nameRdrName fromRationalName-minus_RDR               = nameRdrName minusName-times_RDR               = varQual_RDR  gHC_NUM (fsLit "*")-plus_RDR                = varQual_RDR gHC_NUM (fsLit "+")--toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName-toInteger_RDR           = nameRdrName toIntegerName-toRational_RDR          = nameRdrName toRationalName-fromIntegral_RDR        = nameRdrName fromIntegralName--fromString_RDR :: RdrName-fromString_RDR          = nameRdrName fromStringName--fromList_RDR, fromListN_RDR, toList_RDR :: RdrName-fromList_RDR = nameRdrName fromListName-fromListN_RDR = nameRdrName fromListNName-toList_RDR = nameRdrName toListName--compose_RDR :: RdrName-compose_RDR             = varQual_RDR gHC_BASE (fsLit ".")--not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,-    and_RDR, range_RDR, inRange_RDR, index_RDR,-    unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName-and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&")-not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")-dataToTag_RDR           = varQual_RDR gHC_PRIM (fsLit "dataToTag#")-succ_RDR                = varQual_RDR gHC_ENUM (fsLit "succ")-pred_RDR                = varQual_RDR gHC_ENUM (fsLit "pred")-minBound_RDR            = varQual_RDR gHC_ENUM (fsLit "minBound")-maxBound_RDR            = varQual_RDR gHC_ENUM (fsLit "maxBound")-range_RDR               = varQual_RDR gHC_IX (fsLit "range")-inRange_RDR             = varQual_RDR gHC_IX (fsLit "inRange")-index_RDR               = varQual_RDR gHC_IX (fsLit "index")-unsafeIndex_RDR         = varQual_RDR gHC_IX (fsLit "unsafeIndex")-unsafeRangeSize_RDR     = varQual_RDR gHC_IX (fsLit "unsafeRangeSize")--readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,-    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName-readList_RDR            = varQual_RDR gHC_READ (fsLit "readList")-readListDefault_RDR     = varQual_RDR gHC_READ (fsLit "readListDefault")-readListPrec_RDR        = varQual_RDR gHC_READ (fsLit "readListPrec")-readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault")-readPrec_RDR            = varQual_RDR gHC_READ (fsLit "readPrec")-parens_RDR              = varQual_RDR gHC_READ (fsLit "parens")-choose_RDR              = varQual_RDR gHC_READ (fsLit "choose")-lexP_RDR                = varQual_RDR gHC_READ (fsLit "lexP")-expectP_RDR             = varQual_RDR gHC_READ (fsLit "expectP")--readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName-readField_RDR           = varQual_RDR gHC_READ (fsLit "readField")-readFieldHash_RDR       = varQual_RDR gHC_READ (fsLit "readFieldHash")-readSymField_RDR        = varQual_RDR gHC_READ (fsLit "readSymField")--punc_RDR, ident_RDR, symbol_RDR :: RdrName-punc_RDR                = dataQual_RDR lEX (fsLit "Punc")-ident_RDR               = dataQual_RDR lEX (fsLit "Ident")-symbol_RDR              = dataQual_RDR lEX (fsLit "Symbol")--step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName-step_RDR                = varQual_RDR  rEAD_PREC (fsLit "step")-alt_RDR                 = varQual_RDR  rEAD_PREC (fsLit "+++")-reset_RDR               = varQual_RDR  rEAD_PREC (fsLit "reset")-prec_RDR                = varQual_RDR  rEAD_PREC (fsLit "prec")-pfail_RDR               = varQual_RDR  rEAD_PREC (fsLit "pfail")--showsPrec_RDR, shows_RDR, showString_RDR,-    showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName-showsPrec_RDR           = varQual_RDR gHC_SHOW (fsLit "showsPrec")-shows_RDR               = varQual_RDR gHC_SHOW (fsLit "shows")-showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")-showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")-showCommaSpace_RDR      = varQual_RDR gHC_SHOW (fsLit "showCommaSpace")-showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")--error_RDR :: RdrName-error_RDR = varQual_RDR gHC_ERR (fsLit "error")---- Generics (constructors and functions)-u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,-  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,-  prodDataCon_RDR, comp1DataCon_RDR,-  unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,-  from_RDR, from1_RDR, to_RDR, to1_RDR,-  datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,-  conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR,-  prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,-  rightAssocDataCon_RDR, notAssocDataCon_RDR,-  uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,-  uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,-  uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,-  uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName--u1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "U1")-par1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Par1")-rec1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Rec1")-k1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "K1")-m1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "M1")--l1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "L1")-r1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "R1")--prodDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")-comp1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Comp1")--unPar1_RDR  = varQual_RDR gHC_GENERICS (fsLit "unPar1")-unRec1_RDR  = varQual_RDR gHC_GENERICS (fsLit "unRec1")-unK1_RDR    = varQual_RDR gHC_GENERICS (fsLit "unK1")-unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1")--from_RDR  = varQual_RDR gHC_GENERICS (fsLit "from")-from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")-to_RDR    = varQual_RDR gHC_GENERICS (fsLit "to")-to1_RDR   = varQual_RDR gHC_GENERICS (fsLit "to1")--datatypeName_RDR  = varQual_RDR gHC_GENERICS (fsLit "datatypeName")-moduleName_RDR    = varQual_RDR gHC_GENERICS (fsLit "moduleName")-packageName_RDR   = varQual_RDR gHC_GENERICS (fsLit "packageName")-isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype")-selName_RDR       = varQual_RDR gHC_GENERICS (fsLit "selName")-conName_RDR       = varQual_RDR gHC_GENERICS (fsLit "conName")-conFixity_RDR     = varQual_RDR gHC_GENERICS (fsLit "conFixity")-conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")--prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")-infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")-leftAssocDataCon_RDR  = nameRdrName leftAssociativeDataConName-rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName-notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName--uAddrDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UAddr")-uCharDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UChar")-uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble")-uFloatDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "UFloat")-uIntDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "UInt")-uWordDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UWord")--uAddrHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uAddr#")-uCharHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uChar#")-uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#")-uFloatHash_RDR  = varQual_RDR gHC_GENERICS (fsLit "uFloat#")-uIntHash_RDR    = varQual_RDR gHC_GENERICS (fsLit "uInt#")-uWordHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uWord#")--fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,-    foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,-    mappend_RDR :: RdrName-fmap_RDR                = nameRdrName fmapName-replace_RDR             = varQual_RDR gHC_BASE (fsLit "<$")-pure_RDR                = nameRdrName pureAName-ap_RDR                  = nameRdrName apAName-liftA2_RDR              = varQual_RDR gHC_BASE (fsLit "liftA2")-foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")-foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")-null_RDR                = varQual_RDR dATA_FOLDABLE       (fsLit "null")-all_RDR                 = varQual_RDR dATA_FOLDABLE       (fsLit "all")-traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")-mempty_RDR              = nameRdrName memptyName-mappend_RDR             = nameRdrName mappendName-------------------------varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR-    :: Module -> FastString -> RdrName-varQual_RDR  mod str = mkOrig mod (mkOccNameFS varName str)-tcQual_RDR   mod str = mkOrig mod (mkOccNameFS tcName str)-clsQual_RDR  mod str = mkOrig mod (mkOccNameFS clsName str)-dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)--{--************************************************************************-*                                                                      *-\subsection{Known-key names}-*                                                                      *-************************************************************************--Many of these Names are not really "built in", but some parts of the-compiler (notably the deriving mechanism) need to mention their names,-and it's convenient to write them all down in one place.--}--wildCardName :: Name-wildCardName = mkSystemVarName wildCardKey (fsLit "wild")--runMainIOName, runRWName :: Name-runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey-runRWName     = varQual gHC_MAGIC       (fsLit "runRW#")    runRWKey--orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name-orderingTyConName = tcQual  gHC_TYPES (fsLit "Ordering") orderingTyConKey-ordLTDataConName     = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey-ordEQDataConName     = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey-ordGTDataConName     = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey--specTyConName :: Name-specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey--eitherTyConName, leftDataConName, rightDataConName :: Name-eitherTyConName   = tcQual  dATA_EITHER (fsLit "Either") eitherTyConKey-leftDataConName   = dcQual dATA_EITHER (fsLit "Left")   leftDataConKey-rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey--voidTyConName :: Name-voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey---- Generics (types)-v1TyConName, u1TyConName, par1TyConName, rec1TyConName,-  k1TyConName, m1TyConName, sumTyConName, prodTyConName,-  compTyConName, rTyConName, dTyConName,-  cTyConName, sTyConName, rec0TyConName,-  d1TyConName, c1TyConName, s1TyConName,-  repTyConName, rep1TyConName, uRecTyConName,-  uAddrTyConName, uCharTyConName, uDoubleTyConName,-  uFloatTyConName, uIntTyConName, uWordTyConName,-  prefixIDataConName, infixIDataConName, leftAssociativeDataConName,-  rightAssociativeDataConName, notAssociativeDataConName,-  sourceUnpackDataConName, sourceNoUnpackDataConName,-  noSourceUnpackednessDataConName, sourceLazyDataConName,-  sourceStrictDataConName, noSourceStrictnessDataConName,-  decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,-  metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name--v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey-u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey-par1TyConName  = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey-rec1TyConName  = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey-k1TyConName  = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey-m1TyConName  = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey--sumTyConName    = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey-prodTyConName   = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey-compTyConName   = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey--rTyConName  = tcQual gHC_GENERICS (fsLit "R") rTyConKey-dTyConName  = tcQual gHC_GENERICS (fsLit "D") dTyConKey-cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey-sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey--rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey-d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey-c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey-s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey--repTyConName  = tcQual gHC_GENERICS (fsLit "Rep")  repTyConKey-rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey--uRecTyConName      = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey-uAddrTyConName     = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey-uCharTyConName     = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey-uDoubleTyConName   = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey-uFloatTyConName    = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey-uIntTyConName      = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey-uWordTyConName     = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey--prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI")  prefixIDataConKey-infixIDataConName  = dcQual gHC_GENERICS (fsLit "InfixI")   infixIDataConKey-leftAssociativeDataConName  = dcQual gHC_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey-rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey-notAssociativeDataConName   = dcQual gHC_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey--sourceUnpackDataConName         = dcQual gHC_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey-sourceNoUnpackDataConName       = dcQual gHC_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey-noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey-sourceLazyDataConName           = dcQual gHC_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey-sourceStrictDataConName         = dcQual gHC_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey-noSourceStrictnessDataConName   = dcQual gHC_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey-decidedLazyDataConName          = dcQual gHC_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey-decidedStrictDataConName        = dcQual gHC_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey-decidedUnpackDataConName        = dcQual gHC_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey--metaDataDataConName  = dcQual gHC_GENERICS (fsLit "MetaData")  metaDataDataConKey-metaConsDataConName  = dcQual gHC_GENERICS (fsLit "MetaCons")  metaConsDataConKey-metaSelDataConName   = dcQual gHC_GENERICS (fsLit "MetaSel")   metaSelDataConKey---- Primitive Int-divIntName, modIntName :: Name-divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey-modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey---- Base strings Strings-unpackCStringName, unpackCStringFoldrName,-    unpackCStringUtf8Name, unpackCStringFoldrUtf8Name,-    unpackCStringAppendName, unpackCStringAppendUtf8Name,-    eqStringName, cstringLengthName :: Name-cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey-eqStringName            = varQual gHC_BASE (fsLit "eqString")  eqStringIdKey--unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey-unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey-unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey--unpackCStringUtf8Name       = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey-unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey-unpackCStringFoldrUtf8Name  = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey----- The 'inline' function-inlineIdName :: Name-inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey---- Base classes (Eq, Ord, Functor)-fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name-eqClassName       = clsQual gHC_CLASSES (fsLit "Eq")      eqClassKey-eqName            = varQual gHC_CLASSES (fsLit "==")      eqClassOpKey-ordClassName      = clsQual gHC_CLASSES (fsLit "Ord")     ordClassKey-geName            = varQual gHC_CLASSES (fsLit ">=")      geClassOpKey-functorClassName  = clsQual gHC_BASE    (fsLit "Functor") functorClassKey-fmapName          = varQual gHC_BASE    (fsLit "fmap")    fmapClassOpKey---- Class Monad-monadClassName, thenMName, bindMName, returnMName :: Name-monadClassName     = clsQual gHC_BASE (fsLit "Monad")  monadClassKey-thenMName          = varQual gHC_BASE (fsLit ">>")     thenMClassOpKey-bindMName          = varQual gHC_BASE (fsLit ">>=")    bindMClassOpKey-returnMName        = varQual gHC_BASE (fsLit "return") returnMClassOpKey---- Class MonadFail-monadFailClassName, failMName :: Name-monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey-failMName          = varQual mONAD_FAIL (fsLit "fail")      failMClassOpKey---- Class Applicative-applicativeClassName, pureAName, apAName, thenAName :: Name-applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey-apAName              = varQual gHC_BASE (fsLit "<*>")         apAClassOpKey-pureAName            = varQual gHC_BASE (fsLit "pure")        pureAClassOpKey-thenAName            = varQual gHC_BASE (fsLit "*>")          thenAClassOpKey---- Classes (Foldable, Traversable)-foldableClassName, traversableClassName :: Name-foldableClassName     = clsQual  dATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey-traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey---- Classes (Semigroup, Monoid)-semigroupClassName, sappendName :: Name-semigroupClassName = clsQual gHC_BASE       (fsLit "Semigroup") semigroupClassKey-sappendName        = varQual gHC_BASE       (fsLit "<>")        sappendClassOpKey-monoidClassName, memptyName, mappendName, mconcatName :: Name-monoidClassName    = clsQual gHC_BASE       (fsLit "Monoid")    monoidClassKey-memptyName         = varQual gHC_BASE       (fsLit "mempty")    memptyClassOpKey-mappendName        = varQual gHC_BASE       (fsLit "mappend")   mappendClassOpKey-mconcatName        = varQual gHC_BASE       (fsLit "mconcat")   mconcatClassOpKey------ AMP additions--joinMName, alternativeClassName :: Name-joinMName            = varQual gHC_BASE (fsLit "join")        joinMIdKey-alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey-----joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey,-    alternativeClassKey :: Unique-joinMIdKey          = mkPreludeMiscIdUnique 750-apAClassOpKey       = mkPreludeMiscIdUnique 751 -- <*>-pureAClassOpKey     = mkPreludeMiscIdUnique 752-thenAClassOpKey     = mkPreludeMiscIdUnique 753-alternativeClassKey = mkPreludeMiscIdUnique 754----- Functions for GHC extensions-considerAccessibleName :: Name-considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey---- Random GHC.Base functions-fromStringName, otherwiseIdName, foldrName, buildName, augmentName,-    mapName, appendName, assertName,-    dollarName :: Name-dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey-otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey-foldrName         = varQual gHC_BASE (fsLit "foldr")      foldrIdKey-buildName         = varQual gHC_BASE (fsLit "build")      buildIdKey-augmentName       = varQual gHC_BASE (fsLit "augment")    augmentIdKey-mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey-appendName        = varQual gHC_BASE (fsLit "++")         appendIdKey-assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey-fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey---- Module GHC.Num-numClassName, fromIntegerName, minusName, negateName :: Name-numClassName      = clsQual gHC_NUM (fsLit "Num")         numClassKey-fromIntegerName   = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey-minusName         = varQual gHC_NUM (fsLit "-")           minusClassOpKey-negateName        = varQual gHC_NUM (fsLit "negate")      negateClassOpKey-------------------------------------- ghc-bignum-----------------------------------integerFromNaturalName-   , integerToNaturalClampName-   , integerToNaturalThrowName-   , integerToNaturalName-   , integerToWordName-   , integerToIntName-   , integerToWord64Name-   , integerToInt64Name-   , integerFromWordName-   , integerFromWord64Name-   , integerFromInt64Name-   , integerAddName-   , integerMulName-   , integerSubName-   , integerNegateName-   , integerAbsName-   , integerPopCountName-   , integerQuotName-   , integerRemName-   , integerDivName-   , integerModName-   , integerDivModName-   , integerQuotRemName-   , integerEncodeFloatName-   , integerEncodeDoubleName-   , integerGcdName-   , integerLcmName-   , integerAndName-   , integerOrName-   , integerXorName-   , integerComplementName-   , integerBitName-   , integerTestBitName-   , integerShiftLName-   , integerShiftRName-   , naturalToWordName-   , naturalPopCountName-   , naturalShiftRName-   , naturalShiftLName-   , naturalAddName-   , naturalSubName-   , naturalSubThrowName-   , naturalSubUnsafeName-   , naturalMulName-   , naturalQuotRemName-   , naturalQuotName-   , naturalRemName-   , naturalAndName-   , naturalAndNotName-   , naturalOrName-   , naturalXorName-   , naturalTestBitName-   , naturalBitName-   , naturalGcdName-   , naturalLcmName-   , naturalLog2Name-   , naturalLogBaseWordName-   , naturalLogBaseName-   , naturalPowModName-   , naturalSizeInBaseName-   , bignatFromWordListName-   , bignatEqName-   , bignatCompareName-   , bignatCompareWordName-   :: Name--bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name-bnbVarQual str key = varQual gHC_NUM_BIGNAT  (fsLit str) key-bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key-bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key---- Types and DataCons-bignatFromWordListName    = bnbVarQual "bigNatFromWordList#"       bignatFromWordListIdKey-bignatEqName              = bnbVarQual "bigNatEq#"                 bignatEqIdKey-bignatCompareName         = bnbVarQual "bigNatCompare"             bignatCompareIdKey-bignatCompareWordName     = bnbVarQual "bigNatCompareWord#"        bignatCompareWordIdKey--naturalToWordName         = bnnVarQual "naturalToWord#"            naturalToWordIdKey-naturalPopCountName       = bnnVarQual "naturalPopCount#"          naturalPopCountIdKey-naturalShiftRName         = bnnVarQual "naturalShiftR#"            naturalShiftRIdKey-naturalShiftLName         = bnnVarQual "naturalShiftL#"            naturalShiftLIdKey-naturalAddName            = bnnVarQual "naturalAdd"                naturalAddIdKey-naturalSubName            = bnnVarQual "naturalSub"                naturalSubIdKey-naturalSubThrowName       = bnnVarQual "naturalSubThrow"           naturalSubThrowIdKey-naturalSubUnsafeName      = bnnVarQual "naturalSubUnsafe"          naturalSubUnsafeIdKey-naturalMulName            = bnnVarQual "naturalMul"                naturalMulIdKey-naturalQuotRemName        = bnnVarQual "naturalQuotRem#"           naturalQuotRemIdKey-naturalQuotName           = bnnVarQual "naturalQuot"               naturalQuotIdKey-naturalRemName            = bnnVarQual "naturalRem"                naturalRemIdKey-naturalAndName            = bnnVarQual "naturalAnd"                naturalAndIdKey-naturalAndNotName         = bnnVarQual "naturalAndNot"             naturalAndNotIdKey-naturalOrName             = bnnVarQual "naturalOr"                 naturalOrIdKey-naturalXorName            = bnnVarQual "naturalXor"                naturalXorIdKey-naturalTestBitName        = bnnVarQual "naturalTestBit#"           naturalTestBitIdKey-naturalBitName            = bnnVarQual "naturalBit#"               naturalBitIdKey-naturalGcdName            = bnnVarQual "naturalGcd"                naturalGcdIdKey-naturalLcmName            = bnnVarQual "naturalLcm"                naturalLcmIdKey-naturalLog2Name           = bnnVarQual "naturalLog2#"              naturalLog2IdKey-naturalLogBaseWordName    = bnnVarQual "naturalLogBaseWord#"       naturalLogBaseWordIdKey-naturalLogBaseName        = bnnVarQual "naturalLogBase#"           naturalLogBaseIdKey-naturalPowModName         = bnnVarQual "naturalPowMod"             naturalPowModIdKey-naturalSizeInBaseName     = bnnVarQual "naturalSizeInBase#"        naturalSizeInBaseIdKey--integerFromNaturalName    = bniVarQual "integerFromNatural"        integerFromNaturalIdKey-integerToNaturalClampName = bniVarQual "integerToNaturalClamp"     integerToNaturalClampIdKey-integerToNaturalThrowName = bniVarQual "integerToNaturalThrow"     integerToNaturalThrowIdKey-integerToNaturalName      = bniVarQual "integerToNatural"          integerToNaturalIdKey-integerToWordName         = bniVarQual "integerToWord#"            integerToWordIdKey-integerToIntName          = bniVarQual "integerToInt#"             integerToIntIdKey-integerToWord64Name       = bniVarQual "integerToWord64#"          integerToWord64IdKey-integerToInt64Name        = bniVarQual "integerToInt64#"           integerToInt64IdKey-integerFromWordName       = bniVarQual "integerFromWord#"          integerFromWordIdKey-integerFromWord64Name     = bniVarQual "integerFromWord64#"        integerFromWord64IdKey-integerFromInt64Name      = bniVarQual "integerFromInt64#"         integerFromInt64IdKey-integerAddName            = bniVarQual "integerAdd"                integerAddIdKey-integerMulName            = bniVarQual "integerMul"                integerMulIdKey-integerSubName            = bniVarQual "integerSub"                integerSubIdKey-integerNegateName         = bniVarQual "integerNegate"             integerNegateIdKey-integerAbsName            = bniVarQual "integerAbs"                integerAbsIdKey-integerPopCountName       = bniVarQual "integerPopCount#"          integerPopCountIdKey-integerQuotName           = bniVarQual "integerQuot"               integerQuotIdKey-integerRemName            = bniVarQual "integerRem"                integerRemIdKey-integerDivName            = bniVarQual "integerDiv"                integerDivIdKey-integerModName            = bniVarQual "integerMod"                integerModIdKey-integerDivModName         = bniVarQual "integerDivMod#"            integerDivModIdKey-integerQuotRemName        = bniVarQual "integerQuotRem#"           integerQuotRemIdKey-integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey-integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey-integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey-integerLcmName            = bniVarQual "integerLcm"                integerLcmIdKey-integerAndName            = bniVarQual "integerAnd"                integerAndIdKey-integerOrName             = bniVarQual "integerOr"                 integerOrIdKey-integerXorName            = bniVarQual "integerXor"                integerXorIdKey-integerComplementName     = bniVarQual "integerComplement"         integerComplementIdKey-integerBitName            = bniVarQual "integerBit#"               integerBitIdKey-integerTestBitName        = bniVarQual "integerTestBit#"           integerTestBitIdKey-integerShiftLName         = bniVarQual "integerShiftL#"            integerShiftLIdKey-integerShiftRName         = bniVarQual "integerShiftR#"            integerShiftRIdKey---------------------------------------- End of ghc-bignum-------------------------------------- GHC.Real types and classes-rationalTyConName, ratioTyConName, ratioDataConName, realClassName,-    integralClassName, realFracClassName, fractionalClassName,-    fromRationalName, toIntegerName, toRationalName, fromIntegralName,-    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name-rationalTyConName   = tcQual  gHC_REAL (fsLit "Rational")     rationalTyConKey-ratioTyConName      = tcQual  gHC_REAL (fsLit "Ratio")        ratioTyConKey-ratioDataConName    = dcQual  gHC_REAL (fsLit ":%")           ratioDataConKey-realClassName       = clsQual gHC_REAL (fsLit "Real")         realClassKey-integralClassName   = clsQual gHC_REAL (fsLit "Integral")     integralClassKey-realFracClassName   = clsQual gHC_REAL (fsLit "RealFrac")     realFracClassKey-fractionalClassName = clsQual gHC_REAL (fsLit "Fractional")   fractionalClassKey-fromRationalName    = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey-toIntegerName       = varQual gHC_REAL (fsLit "toInteger")    toIntegerClassOpKey-toRationalName      = varQual gHC_REAL (fsLit "toRational")   toRationalClassOpKey-fromIntegralName    = varQual  gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey-realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey-mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey-mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey--- GHC.Float classes-floatingClassName, realFloatClassName :: Name-floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey-realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey---- other GHC.Float functions-integerToFloatName, integerToDoubleName,-  naturalToFloatName, naturalToDoubleName,-  rationalToFloatName, rationalToDoubleName :: Name-integerToFloatName   = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey-integerToDoubleName  = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey-naturalToFloatName   = varQual gHC_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey-naturalToDoubleName  = varQual gHC_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey-rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey-rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey---- Class Ix-ixClassName :: Name-ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey---- Typeable representation types-trModuleTyConName-  , trModuleDataConName-  , trNameTyConName-  , trNameSDataConName-  , trNameDDataConName-  , trTyConTyConName-  , trTyConDataConName-  :: Name-trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey-trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey-trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey-trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey-trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey-trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey-trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey--kindRepTyConName-  , kindRepTyConAppDataConName-  , kindRepVarDataConName-  , kindRepAppDataConName-  , kindRepFunDataConName-  , kindRepTYPEDataConName-  , kindRepTypeLitSDataConName-  , kindRepTypeLitDDataConName-  :: Name-kindRepTyConName      = tcQual gHC_TYPES          (fsLit "KindRep")        kindRepTyConKey-kindRepTyConAppDataConName = dcQual gHC_TYPES     (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey-kindRepVarDataConName = dcQual gHC_TYPES          (fsLit "KindRepVar")     kindRepVarDataConKey-kindRepAppDataConName = dcQual gHC_TYPES          (fsLit "KindRepApp")     kindRepAppDataConKey-kindRepFunDataConName = dcQual gHC_TYPES          (fsLit "KindRepFun")     kindRepFunDataConKey-kindRepTYPEDataConName = dcQual gHC_TYPES         (fsLit "KindRepTYPE")    kindRepTYPEDataConKey-kindRepTypeLitSDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey-kindRepTypeLitDDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey--typeLitSortTyConName-  , typeLitSymbolDataConName-  , typeLitNatDataConName-  , typeLitCharDataConName-  :: Name-typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey-typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey-typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey-typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey---- Class Typeable, and functions for constructing `Typeable` dictionaries-typeableClassName-  , typeRepTyConName-  , someTypeRepTyConName-  , someTypeRepDataConName-  , mkTrTypeName-  , mkTrConName-  , mkTrAppName-  , mkTrFunName-  , typeRepIdName-  , typeNatTypeRepName-  , typeSymbolTypeRepName-  , typeCharTypeRepName-  , trGhcPrimModuleName-  :: Name-typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey-typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey-someTypeRepTyConName   = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey-someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey-typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey-mkTrTypeName          = varQual tYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey-mkTrConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey-mkTrAppName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey-mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey-typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey-typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey-typeCharTypeRepName   = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey--- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)--- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.-trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey---- Typeable KindReps for some common cases-starKindRepName, starArrStarKindRepName,-  starArrStarArrStarKindRepName, constraintKindRepName :: Name-starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")          starKindRepKey-starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")      starArrStarKindRepKey-starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")    starArrStarArrStarKindRepKey-constraintKindRepName  = varQual gHC_TYPES         (fsLit "krep$Constraint") constraintKindRepKey---- WithDict-withDictClassName :: Name-withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey--nonEmptyTyConName :: Name-nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey---- Custom type errors-errorMessageTypeErrorFamName-  , typeErrorTextDataConName-  , typeErrorAppendDataConName-  , typeErrorVAppendDataConName-  , typeErrorShowTypeDataConName-  :: Name--errorMessageTypeErrorFamName =-  tcQual gHC_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey--typeErrorTextDataConName =-  dcQual gHC_TYPEERROR (fsLit "Text") typeErrorTextDataConKey--typeErrorAppendDataConName =-  dcQual gHC_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey--typeErrorVAppendDataConName =-  dcQual gHC_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey--typeErrorShowTypeDataConName =-  dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey---- Unsafe coercion proofs-unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,-  unsafeReflDataConName :: Name-unsafeEqualityProofName = varQual uNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey-unsafeEqualityTyConName = tcQual uNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey-unsafeReflDataConName   = dcQual uNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey-unsafeCoercePrimName    = varQual uNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey---- Dynamic-toDynName :: Name-toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey---- Class Data-dataClassName :: Name-dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey---- Error module-assertErrorName    :: Name-assertErrorName   = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey---- Debug.Trace-traceName          :: Name-traceName         = varQual dEBUG_TRACE (fsLit "trace") traceKey---- Enum module (Enum, Bounded)-enumClassName, enumFromName, enumFromToName, enumFromThenName,-    enumFromThenToName, boundedClassName :: Name-enumClassName      = clsQual gHC_ENUM (fsLit "Enum")           enumClassKey-enumFromName       = varQual gHC_ENUM (fsLit "enumFrom")       enumFromClassOpKey-enumFromToName     = varQual gHC_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey-enumFromThenName   = varQual gHC_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey-enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey-boundedClassName   = clsQual gHC_ENUM (fsLit "Bounded")        boundedClassKey---- List functions-concatName, filterName, zipName :: Name-concatName        = varQual gHC_LIST (fsLit "concat") concatIdKey-filterName        = varQual gHC_LIST (fsLit "filter") filterIdKey-zipName           = varQual gHC_LIST (fsLit "zip")    zipIdKey---- Overloaded lists-isListClassName, fromListName, fromListNName, toListName :: Name-isListClassName = clsQual gHC_IS_LIST (fsLit "IsList")    isListClassKey-fromListName    = varQual gHC_IS_LIST (fsLit "fromList")  fromListClassOpKey-fromListNName   = varQual gHC_IS_LIST (fsLit "fromListN") fromListNClassOpKey-toListName      = varQual gHC_IS_LIST (fsLit "toList")    toListClassOpKey---- HasField class ops-getFieldName, setFieldName :: Name-getFieldName   = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey-setFieldName   = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey---- Class Show-showClassName :: Name-showClassName   = clsQual gHC_SHOW (fsLit "Show")      showClassKey---- Class Read-readClassName :: Name-readClassName   = clsQual gHC_READ (fsLit "Read")      readClassKey---- Classes Generic and Generic1, Datatype, Constructor and Selector-genClassName, gen1ClassName, datatypeClassName, constructorClassName,-  selectorClassName :: Name-genClassName  = clsQual gHC_GENERICS (fsLit "Generic")  genClassKey-gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey--datatypeClassName    = clsQual gHC_GENERICS (fsLit "Datatype")    datatypeClassKey-constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey-selectorClassName    = clsQual gHC_GENERICS (fsLit "Selector")    selectorClassKey--genericClassNames :: [Name]-genericClassNames = [genClassName, gen1ClassName]---- GHCi things-ghciIoClassName, ghciStepIoMName :: Name-ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey-ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey---- IO things-ioTyConName, ioDataConName,-  thenIOName, bindIOName, returnIOName, failIOName :: Name-ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey-ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey-thenIOName        = varQual gHC_BASE  (fsLit "thenIO")   thenIOIdKey-bindIOName        = varQual gHC_BASE  (fsLit "bindIO")   bindIOIdKey-returnIOName      = varQual gHC_BASE  (fsLit "returnIO") returnIOIdKey-failIOName        = varQual gHC_IO    (fsLit "failIO")   failIOIdKey---- IO things-printName :: Name-printName         = varQual sYSTEM_IO (fsLit "print") printIdKey---- Int, Word, and Addr things-int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name-int8TyConName     = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey-int16TyConName    = tcQual gHC_INT  (fsLit "Int16") int16TyConKey-int32TyConName    = tcQual gHC_INT  (fsLit "Int32") int32TyConKey-int64TyConName    = tcQual gHC_INT  (fsLit "Int64") int64TyConKey---- Word module-word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name-word8TyConName    = tcQual  gHC_WORD (fsLit "Word8")  word8TyConKey-word16TyConName   = tcQual  gHC_WORD (fsLit "Word16") word16TyConKey-word32TyConName   = tcQual  gHC_WORD (fsLit "Word32") word32TyConKey-word64TyConName   = tcQual  gHC_WORD (fsLit "Word64") word64TyConKey---- PrelPtr module-ptrTyConName, funPtrTyConName :: Name-ptrTyConName      = tcQual   gHC_PTR (fsLit "Ptr")    ptrTyConKey-funPtrTyConName   = tcQual   gHC_PTR (fsLit "FunPtr") funPtrTyConKey---- Foreign objects and weak pointers-stablePtrTyConName, newStablePtrName :: Name-stablePtrTyConName    = tcQual   gHC_STABLE (fsLit "StablePtr")    stablePtrTyConKey-newStablePtrName      = varQual  gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey---- Recursive-do notation-monadFixClassName, mfixName :: Name-monadFixClassName  = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey-mfixName           = varQual mONAD_FIX (fsLit "mfix")     mfixIdKey---- Arrow notation-arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name-arrAName           = varQual aRROW (fsLit "arr")       arrAIdKey-composeAName       = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey-firstAName         = varQual aRROW (fsLit "first")     firstAIdKey-appAName           = varQual aRROW (fsLit "app")       appAIdKey-choiceAName        = varQual aRROW (fsLit "|||")       choiceAIdKey-loopAName          = varQual aRROW (fsLit "loop")      loopAIdKey---- Monad comprehensions-guardMName, liftMName, mzipName :: Name-guardMName         = varQual mONAD (fsLit "guard")    guardMIdKey-liftMName          = varQual mONAD (fsLit "liftM")    liftMIdKey-mzipName           = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey----- Annotation type checking-toAnnotationWrapperName :: Name-toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey---- Other classes, needed for type defaulting-monadPlusClassName, isStringClassName :: Name-monadPlusClassName  = clsQual mONAD (fsLit "MonadPlus")      monadPlusClassKey-isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey---- Type-level naturals-knownNatClassName :: Name-knownNatClassName     = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey-knownSymbolClassName :: Name-knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey-knownCharClassName :: Name-knownCharClassName  = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey---- Overloaded labels-fromLabelClassOpName :: Name-fromLabelClassOpName- = varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey---- Implicit Parameters-ipClassName :: Name-ipClassName-  = clsQual gHC_CLASSES (fsLit "IP") ipClassKey---- Overloaded record fields-hasFieldClassName :: Name-hasFieldClassName- = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey---- Source Locations-callStackTyConName, emptyCallStackName, pushCallStackName,-  srcLocDataConName :: Name-callStackTyConName-  = tcQual gHC_STACK_TYPES  (fsLit "CallStack") callStackTyConKey-emptyCallStackName-  = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey-pushCallStackName-  = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey-srcLocDataConName-  = dcQual gHC_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey---- plugins-pLUGINS :: Module-pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins")-pluginTyConName :: Name-pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey-frontendPluginTyConName :: Name-frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey---- Static pointers-makeStaticName :: Name-makeStaticName =-    varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey--staticPtrInfoTyConName :: Name-staticPtrInfoTyConName =-    tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey--staticPtrInfoDataConName :: Name-staticPtrInfoDataConName =-    dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey--staticPtrTyConName :: Name-staticPtrTyConName =-    tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey--staticPtrDataConName :: Name-staticPtrDataConName =-    dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey--fromStaticPtrName :: Name-fromStaticPtrName =-    varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey--fingerprintDataConName :: Name-fingerprintDataConName =-    dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey--constPtrConName :: Name-constPtrConName =-    tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey--{--************************************************************************-*                                                                      *-\subsection{Local helpers}-*                                                                      *-************************************************************************--All these are original names; hence mkOrig--}--{-# INLINE varQual #-}-{-# INLINE tcQual #-}-{-# INLINE clsQual #-}-{-# INLINE dcQual #-}-varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name-varQual  modu str unique = mk_known_key_name varName modu str unique-tcQual   modu str unique = mk_known_key_name tcName modu str unique-clsQual  modu str unique = mk_known_key_name clsName modu str unique-dcQual   modu str unique = mk_known_key_name dataName modu str unique--mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name-{-# INLINE mk_known_key_name #-}-mk_known_key_name space modu str unique-  = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan---{--************************************************************************-*                                                                      *-\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}-*                                                                      *-************************************************************************---MetaHaskell extension hand allocate keys here--}--boundedClassKey, enumClassKey, eqClassKey, floatingClassKey,-    fractionalClassKey, integralClassKey, monadClassKey, dataClassKey,-    functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey,-    realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique-boundedClassKey         = mkPreludeClassUnique 1-enumClassKey            = mkPreludeClassUnique 2-eqClassKey              = mkPreludeClassUnique 3-floatingClassKey        = mkPreludeClassUnique 5-fractionalClassKey      = mkPreludeClassUnique 6-integralClassKey        = mkPreludeClassUnique 7-monadClassKey           = mkPreludeClassUnique 8-dataClassKey            = mkPreludeClassUnique 9-functorClassKey         = mkPreludeClassUnique 10-numClassKey             = mkPreludeClassUnique 11-ordClassKey             = mkPreludeClassUnique 12-readClassKey            = mkPreludeClassUnique 13-realClassKey            = mkPreludeClassUnique 14-realFloatClassKey       = mkPreludeClassUnique 15-realFracClassKey        = mkPreludeClassUnique 16-showClassKey            = mkPreludeClassUnique 17-ixClassKey              = mkPreludeClassUnique 18--typeableClassKey :: Unique-typeableClassKey        = mkPreludeClassUnique 20--withDictClassKey :: Unique-withDictClassKey        = mkPreludeClassUnique 21--monadFixClassKey :: Unique-monadFixClassKey        = mkPreludeClassUnique 28--monadFailClassKey :: Unique-monadFailClassKey       = mkPreludeClassUnique 29--monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique-monadPlusClassKey       = mkPreludeClassUnique 30-randomClassKey          = mkPreludeClassUnique 31-randomGenClassKey       = mkPreludeClassUnique 32--isStringClassKey :: Unique-isStringClassKey        = mkPreludeClassUnique 33--applicativeClassKey, foldableClassKey, traversableClassKey :: Unique-applicativeClassKey     = mkPreludeClassUnique 34-foldableClassKey        = mkPreludeClassUnique 35-traversableClassKey     = mkPreludeClassUnique 36--genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,-  selectorClassKey :: Unique-genClassKey   = mkPreludeClassUnique 37-gen1ClassKey  = mkPreludeClassUnique 38--datatypeClassKey    = mkPreludeClassUnique 39-constructorClassKey = mkPreludeClassUnique 40-selectorClassKey    = mkPreludeClassUnique 41---- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence-knownNatClassNameKey :: Unique-knownNatClassNameKey = mkPreludeClassUnique 42---- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence-knownSymbolClassNameKey :: Unique-knownSymbolClassNameKey = mkPreludeClassUnique 43--knownCharClassNameKey :: Unique-knownCharClassNameKey = mkPreludeClassUnique 44--ghciIoClassKey :: Unique-ghciIoClassKey = mkPreludeClassUnique 45--semigroupClassKey, monoidClassKey :: Unique-semigroupClassKey = mkPreludeClassUnique 47-monoidClassKey    = mkPreludeClassUnique 48---- Implicit Parameters-ipClassKey :: Unique-ipClassKey = mkPreludeClassUnique 49---- Overloaded record fields-hasFieldClassNameKey :: Unique-hasFieldClassNameKey = mkPreludeClassUnique 50------------------- Template Haskell ----------------------      GHC.Builtin.Names.TH: USES ClassUniques 200-299--------------------------------------------------------{--************************************************************************-*                                                                      *-\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}-*                                                                      *-************************************************************************--}--addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,-    byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,-    doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey,-    intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,-    int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey,-    int64PrimTyConKey, int64TyConKey,-    integerTyConKey, naturalTyConKey,-    listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,-    weakPrimTyConKey, mutableArrayPrimTyConKey,-    mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,-    ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,-    stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,-    smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,-    stringTyConKey,-    ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique-addrPrimTyConKey                        = mkPreludeTyConUnique  1-arrayPrimTyConKey                       = mkPreludeTyConUnique  3-boolTyConKey                            = mkPreludeTyConUnique  4-byteArrayPrimTyConKey                   = mkPreludeTyConUnique  5-stringTyConKey                          = mkPreludeTyConUnique  6-charPrimTyConKey                        = mkPreludeTyConUnique  7-charTyConKey                            = mkPreludeTyConUnique  8-doublePrimTyConKey                      = mkPreludeTyConUnique  9-doubleTyConKey                          = mkPreludeTyConUnique 10-floatPrimTyConKey                       = mkPreludeTyConUnique 11-floatTyConKey                           = mkPreludeTyConUnique 12-fUNTyConKey                             = mkPreludeTyConUnique 13-intPrimTyConKey                         = mkPreludeTyConUnique 14-intTyConKey                             = mkPreludeTyConUnique 15-int8PrimTyConKey                        = mkPreludeTyConUnique 16-int8TyConKey                            = mkPreludeTyConUnique 17-int16PrimTyConKey                       = mkPreludeTyConUnique 18-int16TyConKey                           = mkPreludeTyConUnique 19-int32PrimTyConKey                       = mkPreludeTyConUnique 20-int32TyConKey                           = mkPreludeTyConUnique 21-int64PrimTyConKey                       = mkPreludeTyConUnique 22-int64TyConKey                           = mkPreludeTyConUnique 23-integerTyConKey                         = mkPreludeTyConUnique 24-naturalTyConKey                         = mkPreludeTyConUnique 25--listTyConKey                            = mkPreludeTyConUnique 26-foreignObjPrimTyConKey                  = mkPreludeTyConUnique 27-maybeTyConKey                           = mkPreludeTyConUnique 28-weakPrimTyConKey                        = mkPreludeTyConUnique 29-mutableArrayPrimTyConKey                = mkPreludeTyConUnique 30-mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 31-orderingTyConKey                        = mkPreludeTyConUnique 32-mVarPrimTyConKey                        = mkPreludeTyConUnique 33-ioPortPrimTyConKey                      = mkPreludeTyConUnique 34-ratioTyConKey                           = mkPreludeTyConUnique 35-rationalTyConKey                        = mkPreludeTyConUnique 36-realWorldTyConKey                       = mkPreludeTyConUnique 37-stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38-stablePtrTyConKey                       = mkPreludeTyConUnique 39-eqTyConKey                              = mkPreludeTyConUnique 40-heqTyConKey                             = mkPreludeTyConUnique 41--ctArrowTyConKey                       = mkPreludeTyConUnique 42-ccArrowTyConKey                       = mkPreludeTyConUnique 43-tcArrowTyConKey                       = mkPreludeTyConUnique 44--statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,-    mutVarPrimTyConKey, ioTyConKey,-    wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,-    word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey,-    word64PrimTyConKey, word64TyConKey,-    kindConKey, boxityConKey,-    typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,-    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,-    eqReprPrimTyConKey, eqPhantPrimTyConKey,-    compactPrimTyConKey, stackSnapshotPrimTyConKey,-    promptTagPrimTyConKey, constPtrTyConKey :: Unique-statePrimTyConKey                       = mkPreludeTyConUnique 50-stableNamePrimTyConKey                  = mkPreludeTyConUnique 51-stableNameTyConKey                      = mkPreludeTyConUnique 52-eqPrimTyConKey                          = mkPreludeTyConUnique 53-eqReprPrimTyConKey                      = mkPreludeTyConUnique 54-eqPhantPrimTyConKey                     = mkPreludeTyConUnique 55-mutVarPrimTyConKey                      = mkPreludeTyConUnique 56-ioTyConKey                              = mkPreludeTyConUnique 57-wordPrimTyConKey                        = mkPreludeTyConUnique 59-wordTyConKey                            = mkPreludeTyConUnique 60-word8PrimTyConKey                       = mkPreludeTyConUnique 61-word8TyConKey                           = mkPreludeTyConUnique 62-word16PrimTyConKey                      = mkPreludeTyConUnique 63-word16TyConKey                          = mkPreludeTyConUnique 64-word32PrimTyConKey                      = mkPreludeTyConUnique 65-word32TyConKey                          = mkPreludeTyConUnique 66-word64PrimTyConKey                      = mkPreludeTyConUnique 67-word64TyConKey                          = mkPreludeTyConUnique 68-kindConKey                              = mkPreludeTyConUnique 72-boxityConKey                            = mkPreludeTyConUnique 73-typeConKey                              = mkPreludeTyConUnique 74-threadIdPrimTyConKey                    = mkPreludeTyConUnique 75-bcoPrimTyConKey                         = mkPreludeTyConUnique 76-ptrTyConKey                             = mkPreludeTyConUnique 77-funPtrTyConKey                          = mkPreludeTyConUnique 78-tVarPrimTyConKey                        = mkPreludeTyConUnique 79-compactPrimTyConKey                     = mkPreludeTyConUnique 80-stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81-promptTagPrimTyConKey                   = mkPreludeTyConUnique 82--eitherTyConKey :: Unique-eitherTyConKey                          = mkPreludeTyConUnique 84--voidTyConKey :: Unique-voidTyConKey                            = mkPreludeTyConUnique 85--nonEmptyTyConKey :: Unique-nonEmptyTyConKey                        = mkPreludeTyConUnique 86--dictTyConKey :: Unique-dictTyConKey                            = mkPreludeTyConUnique 87---- Kind constructors-liftedTypeKindTyConKey, unliftedTypeKindTyConKey,-  tYPETyConKey, cONSTRAINTTyConKey,-  liftedRepTyConKey, unliftedRepTyConKey,-  constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,-  vecCountTyConKey, vecElemTyConKey,-  zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique-liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88-unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89-tYPETyConKey                            = mkPreludeTyConUnique 91-cONSTRAINTTyConKey                      = mkPreludeTyConUnique 92-constraintKindTyConKey                  = mkPreludeTyConUnique 93-levityTyConKey                          = mkPreludeTyConUnique 94-runtimeRepTyConKey                      = mkPreludeTyConUnique 95-vecCountTyConKey                        = mkPreludeTyConUnique 96-vecElemTyConKey                         = mkPreludeTyConUnique 97-liftedRepTyConKey                       = mkPreludeTyConUnique 98-unliftedRepTyConKey                     = mkPreludeTyConUnique 99-zeroBitRepTyConKey                         = mkPreludeTyConUnique 100-zeroBitTypeTyConKey                        = mkPreludeTyConUnique 101--pluginTyConKey, frontendPluginTyConKey :: Unique-pluginTyConKey                          = mkPreludeTyConUnique 102-frontendPluginTyConKey                  = mkPreludeTyConUnique 103--trTyConTyConKey, trModuleTyConKey, trNameTyConKey,-  kindRepTyConKey, typeLitSortTyConKey :: Unique-trTyConTyConKey                         = mkPreludeTyConUnique 104-trModuleTyConKey                        = mkPreludeTyConUnique 105-trNameTyConKey                          = mkPreludeTyConUnique 106-kindRepTyConKey                         = mkPreludeTyConUnique 107-typeLitSortTyConKey                     = mkPreludeTyConUnique 108---- Generics (Unique keys)-v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,-  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,-  compTyConKey, rTyConKey, dTyConKey,-  cTyConKey, sTyConKey, rec0TyConKey,-  d1TyConKey, c1TyConKey, s1TyConKey,-  repTyConKey, rep1TyConKey, uRecTyConKey,-  uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,-  uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique--v1TyConKey    = mkPreludeTyConUnique 135-u1TyConKey    = mkPreludeTyConUnique 136-par1TyConKey  = mkPreludeTyConUnique 137-rec1TyConKey  = mkPreludeTyConUnique 138-k1TyConKey    = mkPreludeTyConUnique 139-m1TyConKey    = mkPreludeTyConUnique 140--sumTyConKey   = mkPreludeTyConUnique 141-prodTyConKey  = mkPreludeTyConUnique 142-compTyConKey  = mkPreludeTyConUnique 143--rTyConKey = mkPreludeTyConUnique 144-dTyConKey = mkPreludeTyConUnique 146-cTyConKey = mkPreludeTyConUnique 147-sTyConKey = mkPreludeTyConUnique 148--rec0TyConKey  = mkPreludeTyConUnique 149-d1TyConKey    = mkPreludeTyConUnique 151-c1TyConKey    = mkPreludeTyConUnique 152-s1TyConKey    = mkPreludeTyConUnique 153--repTyConKey  = mkPreludeTyConUnique 155-rep1TyConKey = mkPreludeTyConUnique 156--uRecTyConKey    = mkPreludeTyConUnique 157-uAddrTyConKey   = mkPreludeTyConUnique 158-uCharTyConKey   = mkPreludeTyConUnique 159-uDoubleTyConKey = mkPreludeTyConUnique 160-uFloatTyConKey  = mkPreludeTyConUnique 161-uIntTyConKey    = mkPreludeTyConUnique 162-uWordTyConKey   = mkPreludeTyConUnique 163---- Custom user type-errors-errorMessageTypeErrorFamKey :: Unique-errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 181--coercibleTyConKey :: Unique-coercibleTyConKey = mkPreludeTyConUnique 183--proxyPrimTyConKey :: Unique-proxyPrimTyConKey = mkPreludeTyConUnique 184--specTyConKey :: Unique-specTyConKey = mkPreludeTyConUnique 185--anyTyConKey :: Unique-anyTyConKey = mkPreludeTyConUnique 186--smallArrayPrimTyConKey        = mkPreludeTyConUnique  187-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  188--staticPtrTyConKey  :: Unique-staticPtrTyConKey  = mkPreludeTyConUnique 189--staticPtrInfoTyConKey :: Unique-staticPtrInfoTyConKey = mkPreludeTyConUnique 190--callStackTyConKey :: Unique-callStackTyConKey = mkPreludeTyConUnique 191---- Typeables-typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique-typeRepTyConKey       = mkPreludeTyConUnique 192-someTypeRepTyConKey   = mkPreludeTyConUnique 193-someTypeRepDataConKey = mkPreludeTyConUnique 194---typeSymbolAppendFamNameKey :: Unique-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195---- Unsafe equality-unsafeEqualityTyConKey :: Unique-unsafeEqualityTyConKey = mkPreludeTyConUnique 196---- Linear types-multiplicityTyConKey :: Unique-multiplicityTyConKey = mkPreludeTyConUnique 197--unrestrictedFunTyConKey :: Unique-unrestrictedFunTyConKey = mkPreludeTyConUnique 198--multMulTyConKey :: Unique-multMulTyConKey = mkPreludeTyConUnique 199------------------ Template Haskell ----------------------      GHC.Builtin.Names.TH: USES TyConUniques 200-299------------------------------------------------------------------------------- SIMD ---------------------------      USES TyConUniques 300-399--------------------------------------------------------#include "primop-vector-uniques.hs-incl"--------------- Type-level Symbol, Nat, Char -------------      USES TyConUniques 400-499-------------------------------------------------------typeSymbolKindConNameKey, typeCharKindConNameKey,-  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,-  typeNatSubTyFamNameKey-  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey-  , typeLeqCharTyFamNameKey-  , typeNatDivTyFamNameKey-  , typeNatModTyFamNameKey-  , typeNatLogTyFamNameKey-  , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey-  , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey-  :: Unique-typeSymbolKindConNameKey  = mkPreludeTyConUnique 400-typeCharKindConNameKey    = mkPreludeTyConUnique 401-typeNatAddTyFamNameKey    = mkPreludeTyConUnique 402-typeNatMulTyFamNameKey    = mkPreludeTyConUnique 403-typeNatExpTyFamNameKey    = mkPreludeTyConUnique 404-typeNatSubTyFamNameKey    = mkPreludeTyConUnique 405-typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406-typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 407-typeCharCmpTyFamNameKey   = mkPreludeTyConUnique 408-typeLeqCharTyFamNameKey   = mkPreludeTyConUnique 409-typeNatDivTyFamNameKey  = mkPreludeTyConUnique 410-typeNatModTyFamNameKey  = mkPreludeTyConUnique 411-typeNatLogTyFamNameKey  = mkPreludeTyConUnique 412-typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413-typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414-typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415-typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416-constPtrTyConKey = mkPreludeTyConUnique 417--{--************************************************************************-*                                                                      *-\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}-*                                                                      *-************************************************************************--}--charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,-    floatDataConKey, intDataConKey, nilDataConKey,-    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,-    word8DataConKey, ioDataConKey, heqDataConKey,-    eqDataConKey, nothingDataConKey, justDataConKey :: Unique--charDataConKey                          = mkPreludeDataConUnique  1-consDataConKey                          = mkPreludeDataConUnique  2-doubleDataConKey                        = mkPreludeDataConUnique  3-falseDataConKey                         = mkPreludeDataConUnique  4-floatDataConKey                         = mkPreludeDataConUnique  5-intDataConKey                           = mkPreludeDataConUnique  6-nothingDataConKey                       = mkPreludeDataConUnique  7-justDataConKey                          = mkPreludeDataConUnique  8-eqDataConKey                            = mkPreludeDataConUnique  9-nilDataConKey                           = mkPreludeDataConUnique 10-ratioDataConKey                         = mkPreludeDataConUnique 11-word8DataConKey                         = mkPreludeDataConUnique 12-stableNameDataConKey                    = mkPreludeDataConUnique 13-trueDataConKey                          = mkPreludeDataConUnique 14-wordDataConKey                          = mkPreludeDataConUnique 15-ioDataConKey                            = mkPreludeDataConUnique 16-heqDataConKey                           = mkPreludeDataConUnique 18---- Generic data constructors-crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique-crossDataConKey                         = mkPreludeDataConUnique 20-inlDataConKey                           = mkPreludeDataConUnique 21-inrDataConKey                           = mkPreludeDataConUnique 22-genUnitDataConKey                       = mkPreludeDataConUnique 23--leftDataConKey, rightDataConKey :: Unique-leftDataConKey                          = mkPreludeDataConUnique 25-rightDataConKey                         = mkPreludeDataConUnique 26--ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique-ordLTDataConKey                         = mkPreludeDataConUnique 27-ordEQDataConKey                         = mkPreludeDataConUnique 28-ordGTDataConKey                         = mkPreludeDataConUnique 29--mkDictDataConKey :: Unique-mkDictDataConKey                        = mkPreludeDataConUnique 30--coercibleDataConKey :: Unique-coercibleDataConKey                     = mkPreludeDataConUnique 32--staticPtrDataConKey :: Unique-staticPtrDataConKey                     = mkPreludeDataConUnique 33--staticPtrInfoDataConKey :: Unique-staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34--fingerprintDataConKey :: Unique-fingerprintDataConKey                   = mkPreludeDataConUnique 35--srcLocDataConKey :: Unique-srcLocDataConKey                        = mkPreludeDataConUnique 37--trTyConDataConKey, trModuleDataConKey,-  trNameSDataConKey, trNameDDataConKey,-  trGhcPrimModuleKey :: Unique-trTyConDataConKey                       = mkPreludeDataConUnique 41-trModuleDataConKey                      = mkPreludeDataConUnique 43-trNameSDataConKey                       = mkPreludeDataConUnique 45-trNameDDataConKey                       = mkPreludeDataConUnique 46-trGhcPrimModuleKey                      = mkPreludeDataConUnique 47--typeErrorTextDataConKey,-  typeErrorAppendDataConKey,-  typeErrorVAppendDataConKey,-  typeErrorShowTypeDataConKey-  :: Unique-typeErrorTextDataConKey                 = mkPreludeDataConUnique 50-typeErrorAppendDataConKey               = mkPreludeDataConUnique 51-typeErrorVAppendDataConKey              = mkPreludeDataConUnique 52-typeErrorShowTypeDataConKey             = mkPreludeDataConUnique 53--prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,-    rightAssociativeDataConKey, notAssociativeDataConKey,-    sourceUnpackDataConKey, sourceNoUnpackDataConKey,-    noSourceUnpackednessDataConKey, sourceLazyDataConKey,-    sourceStrictDataConKey, noSourceStrictnessDataConKey,-    decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey,-    metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique-prefixIDataConKey                       = mkPreludeDataConUnique 54-infixIDataConKey                        = mkPreludeDataConUnique 55-leftAssociativeDataConKey               = mkPreludeDataConUnique 56-rightAssociativeDataConKey              = mkPreludeDataConUnique 57-notAssociativeDataConKey                = mkPreludeDataConUnique 58-sourceUnpackDataConKey                  = mkPreludeDataConUnique 59-sourceNoUnpackDataConKey                = mkPreludeDataConUnique 60-noSourceUnpackednessDataConKey          = mkPreludeDataConUnique 61-sourceLazyDataConKey                    = mkPreludeDataConUnique 62-sourceStrictDataConKey                  = mkPreludeDataConUnique 63-noSourceStrictnessDataConKey            = mkPreludeDataConUnique 64-decidedLazyDataConKey                   = mkPreludeDataConUnique 65-decidedStrictDataConKey                 = mkPreludeDataConUnique 66-decidedUnpackDataConKey                 = mkPreludeDataConUnique 67-metaDataDataConKey                      = mkPreludeDataConUnique 68-metaConsDataConKey                      = mkPreludeDataConUnique 69-metaSelDataConKey                       = mkPreludeDataConUnique 70--vecRepDataConKey, sumRepDataConKey,-  tupleRepDataConKey, boxedRepDataConKey :: Unique-vecRepDataConKey                        = mkPreludeDataConUnique 71-tupleRepDataConKey                      = mkPreludeDataConUnique 72-sumRepDataConKey                        = mkPreludeDataConUnique 73-boxedRepDataConKey                      = mkPreludeDataConUnique 74--boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique--- A promoted data constructors (i.e. a TyCon) has--- the same key as the data constructor itself-boxedRepDataConTyConKey = boxedRepDataConKey-tupleRepDataConTyConKey = tupleRepDataConKey---- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types--- Includes all nullary-data-constructor reps. Does not--- include BoxedRep, VecRep, SumRep, TupleRep.-runtimeRepSimpleDataConKeys :: [Unique]-runtimeRepSimpleDataConKeys-  = map mkPreludeDataConUnique [75..87]--liftedDataConKey,unliftedDataConKey :: Unique-liftedDataConKey = mkPreludeDataConUnique 88-unliftedDataConKey = mkPreludeDataConUnique 89---- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types--- VecCount-vecCountDataConKeys :: [Unique]-vecCountDataConKeys = map mkPreludeDataConUnique [90..95]---- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types--- VecElem-vecElemDataConKeys :: [Unique]-vecElemDataConKeys = map mkPreludeDataConUnique [96..105]---- Typeable things-kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,-    kindRepFunDataConKey, kindRepTYPEDataConKey,-    kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey-    :: Unique-kindRepTyConAppDataConKey = mkPreludeDataConUnique 106-kindRepVarDataConKey      = mkPreludeDataConUnique 107-kindRepAppDataConKey      = mkPreludeDataConUnique 108-kindRepFunDataConKey      = mkPreludeDataConUnique 109-kindRepTYPEDataConKey     = mkPreludeDataConUnique 110-kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111-kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112--typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique-typeLitSymbolDataConKey   = mkPreludeDataConUnique 113-typeLitNatDataConKey      = mkPreludeDataConUnique 114-typeLitCharDataConKey     = mkPreludeDataConUnique 115---- Unsafe equality-unsafeReflDataConKey :: Unique-unsafeReflDataConKey      = mkPreludeDataConUnique 116---- Multiplicity--oneDataConKey, manyDataConKey :: Unique-oneDataConKey = mkPreludeDataConUnique 117-manyDataConKey = mkPreludeDataConUnique 118---- ghc-bignum-integerISDataConKey, integerINDataConKey, integerIPDataConKey,-   naturalNSDataConKey, naturalNBDataConKey :: Unique-integerISDataConKey       = mkPreludeDataConUnique 120-integerINDataConKey       = mkPreludeDataConUnique 121-integerIPDataConKey       = mkPreludeDataConUnique 122-naturalNSDataConKey       = mkPreludeDataConUnique 123-naturalNBDataConKey       = mkPreludeDataConUnique 124------------------- Template Haskell ----------------------      GHC.Builtin.Names.TH: USES DataUniques 200-250---------------------------------------------------------{--************************************************************************-*                                                                      *-\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}-*                                                                      *-************************************************************************--}--wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey,-    buildIdKey, foldrIdKey, recSelErrorIdKey,-    seqIdKey, eqStringIdKey,-    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,-    impossibleErrorIdKey, impossibleConstraintErrorIdKey,-    patErrorIdKey, voidPrimIdKey,-    realWorldPrimIdKey, recConErrorIdKey,-    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,-    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,-    typeErrorIdKey, divIntIdKey, modIntIdKey,-    absentSumFieldErrorIdKey, cstringLengthIdKey-    :: Unique--wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]-absentErrorIdKey               = mkPreludeMiscIdUnique  1-absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2-augmentIdKey                   = mkPreludeMiscIdUnique  3-appendIdKey                    = mkPreludeMiscIdUnique  4-buildIdKey                     = mkPreludeMiscIdUnique  5-foldrIdKey                     = mkPreludeMiscIdUnique  6-recSelErrorIdKey               = mkPreludeMiscIdUnique  7-seqIdKey                       = mkPreludeMiscIdUnique  8-absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9-eqStringIdKey                  = mkPreludeMiscIdUnique 10-noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11-nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12-impossibleErrorIdKey           = mkPreludeMiscIdUnique 13-impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14-patErrorIdKey                  = mkPreludeMiscIdUnique 15-realWorldPrimIdKey             = mkPreludeMiscIdUnique 16-recConErrorIdKey               = mkPreludeMiscIdUnique 17--unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18-unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19-unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20--unpackCStringIdKey            = mkPreludeMiscIdUnique 21-unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22-unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23--voidPrimIdKey                 = mkPreludeMiscIdUnique 24-typeErrorIdKey                = mkPreludeMiscIdUnique 25-divIntIdKey                   = mkPreludeMiscIdUnique 26-modIntIdKey                   = mkPreludeMiscIdUnique 27-cstringLengthIdKey            = mkPreludeMiscIdUnique 28--concatIdKey, filterIdKey, zipIdKey,-    bindIOIdKey, returnIOIdKey, newStablePtrIdKey,-    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,-    otherwiseIdKey, assertIdKey :: Unique-concatIdKey                   = mkPreludeMiscIdUnique 31-filterIdKey                   = mkPreludeMiscIdUnique 32-zipIdKey                      = mkPreludeMiscIdUnique 33-bindIOIdKey                   = mkPreludeMiscIdUnique 34-returnIOIdKey                 = mkPreludeMiscIdUnique 35-newStablePtrIdKey             = mkPreludeMiscIdUnique 36-printIdKey                    = mkPreludeMiscIdUnique 37-failIOIdKey                   = mkPreludeMiscIdUnique 38-nullAddrIdKey                 = mkPreludeMiscIdUnique 39-voidArgIdKey                  = mkPreludeMiscIdUnique 40-otherwiseIdKey                = mkPreludeMiscIdUnique 43-assertIdKey                   = mkPreludeMiscIdUnique 44--leftSectionKey, rightSectionKey :: Unique-leftSectionKey                = mkPreludeMiscIdUnique 45-rightSectionKey               = mkPreludeMiscIdUnique 46--rootMainKey, runMainKey :: Unique-rootMainKey                   = mkPreludeMiscIdUnique 101-runMainKey                    = mkPreludeMiscIdUnique 102--thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique-thenIOIdKey                   = mkPreludeMiscIdUnique 103-lazyIdKey                     = mkPreludeMiscIdUnique 104-assertErrorIdKey              = mkPreludeMiscIdUnique 105-oneShotKey                    = mkPreludeMiscIdUnique 106-runRWKey                      = mkPreludeMiscIdUnique 107--traceKey :: Unique-traceKey                      = mkPreludeMiscIdUnique 108--nospecIdKey :: Unique-nospecIdKey                   = mkPreludeMiscIdUnique 109--inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique-inlineIdKey                   = mkPreludeMiscIdUnique 120--- see below--mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique-mapIdKey                = mkPreludeMiscIdUnique 121-dollarIdKey             = mkPreludeMiscIdUnique 123-coercionTokenIdKey      = mkPreludeMiscIdUnique 124-considerAccessibleIdKey = mkPreludeMiscIdUnique 125-noinlineIdKey           = mkPreludeMiscIdUnique 126-noinlineConstraintIdKey = mkPreludeMiscIdUnique 127--integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique-integerToFloatIdKey    = mkPreludeMiscIdUnique 128-integerToDoubleIdKey   = mkPreludeMiscIdUnique 129-naturalToFloatIdKey    = mkPreludeMiscIdUnique 130-naturalToDoubleIdKey   = mkPreludeMiscIdUnique 131--rationalToFloatIdKey, rationalToDoubleIdKey :: Unique-rationalToFloatIdKey   = mkPreludeMiscIdUnique 132-rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133--coerceKey :: Unique-coerceKey                     = mkPreludeMiscIdUnique 157--{--Certain class operations from Prelude classes.  They get their own-uniques so we can look them up easily when we want to conjure them up-during type checking.--}---- Just a placeholder for unbound variables produced by the renamer:-unboundKey :: Unique-unboundKey                    = mkPreludeMiscIdUnique 158--fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,-    enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,-    enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,-    bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey-    :: Unique-fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160-minusClassOpKey               = mkPreludeMiscIdUnique 161-fromRationalClassOpKey        = mkPreludeMiscIdUnique 162-enumFromClassOpKey            = mkPreludeMiscIdUnique 163-enumFromThenClassOpKey        = mkPreludeMiscIdUnique 164-enumFromToClassOpKey          = mkPreludeMiscIdUnique 165-enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166-eqClassOpKey                  = mkPreludeMiscIdUnique 167-geClassOpKey                  = mkPreludeMiscIdUnique 168-negateClassOpKey              = mkPreludeMiscIdUnique 169-bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)-thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)-fmapClassOpKey                = mkPreludeMiscIdUnique 173-returnMClassOpKey             = mkPreludeMiscIdUnique 174---- Recursive do notation-mfixIdKey :: Unique-mfixIdKey       = mkPreludeMiscIdUnique 175---- MonadFail operations-failMClassOpKey :: Unique-failMClassOpKey = mkPreludeMiscIdUnique 176---- fromLabel-fromLabelClassOpKey :: Unique-fromLabelClassOpKey = mkPreludeMiscIdUnique 177---- Arrow notation-arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,-    loopAIdKey :: Unique-arrAIdKey       = mkPreludeMiscIdUnique 180-composeAIdKey   = mkPreludeMiscIdUnique 181 -- >>>-firstAIdKey     = mkPreludeMiscIdUnique 182-appAIdKey       = mkPreludeMiscIdUnique 183-choiceAIdKey    = mkPreludeMiscIdUnique 184 --  |||-loopAIdKey      = mkPreludeMiscIdUnique 185--fromStringClassOpKey :: Unique-fromStringClassOpKey          = mkPreludeMiscIdUnique 186---- Annotation type checking-toAnnotationWrapperIdKey :: Unique-toAnnotationWrapperIdKey      = mkPreludeMiscIdUnique 187---- Conversion functions-fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique-fromIntegralIdKey    = mkPreludeMiscIdUnique 190-realToFracIdKey      = mkPreludeMiscIdUnique 191-toIntegerClassOpKey  = mkPreludeMiscIdUnique 192-toRationalClassOpKey = mkPreludeMiscIdUnique 193---- Monad comprehensions-guardMIdKey, liftMIdKey, mzipIdKey :: Unique-guardMIdKey     = mkPreludeMiscIdUnique 194-liftMIdKey      = mkPreludeMiscIdUnique 195-mzipIdKey       = mkPreludeMiscIdUnique 196---- GHCi-ghciStepIoMClassOpKey :: Unique-ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197---- Overloaded lists-isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique-isListClassKey = mkPreludeMiscIdUnique 198-fromListClassOpKey = mkPreludeMiscIdUnique 199-fromListNClassOpKey = mkPreludeMiscIdUnique 500-toListClassOpKey = mkPreludeMiscIdUnique 501--proxyHashKey :: Unique-proxyHashKey = mkPreludeMiscIdUnique 502------------------ Template Haskell ----------------------      GHC.Builtin.Names.TH: USES IdUniques 200-499---------------------------------------------------------- Used to make `Typeable` dictionaries-mkTyConKey-  , mkTrTypeKey-  , mkTrConKey-  , mkTrAppKey-  , mkTrFunKey-  , typeNatTypeRepKey-  , typeSymbolTypeRepKey-  , typeCharTypeRepKey-  , typeRepIdKey-  :: Unique-mkTyConKey            = mkPreludeMiscIdUnique 503-mkTrTypeKey           = mkPreludeMiscIdUnique 504-mkTrConKey            = mkPreludeMiscIdUnique 505-mkTrAppKey            = mkPreludeMiscIdUnique 506-typeNatTypeRepKey     = mkPreludeMiscIdUnique 507-typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508-typeCharTypeRepKey    = mkPreludeMiscIdUnique 509-typeRepIdKey          = mkPreludeMiscIdUnique 510-mkTrFunKey            = mkPreludeMiscIdUnique 511---- Representations for primitive types-trTYPEKey-  , trTYPE'PtrRepLiftedKey-  , trRuntimeRepKey-  , tr'PtrRepLiftedKey-  , trLiftedRepKey-  :: Unique-trTYPEKey              = mkPreludeMiscIdUnique 512-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513-trRuntimeRepKey        = mkPreludeMiscIdUnique 514-tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 515-trLiftedRepKey         = mkPreludeMiscIdUnique 516---- KindReps for common cases-starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique-starKindRepKey               = mkPreludeMiscIdUnique 520-starArrStarKindRepKey        = mkPreludeMiscIdUnique 521-starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522-constraintKindRepKey         = mkPreludeMiscIdUnique 523---- Dynamic-toDynIdKey :: Unique-toDynIdKey            = mkPreludeMiscIdUnique 530---bitIntegerIdKey :: Unique-bitIntegerIdKey       = mkPreludeMiscIdUnique 550--heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique-eqSCSelIdKey        = mkPreludeMiscIdUnique 551-heqSCSelIdKey       = mkPreludeMiscIdUnique 552-coercibleSCSelIdKey = mkPreludeMiscIdUnique 553--sappendClassOpKey :: Unique-sappendClassOpKey = mkPreludeMiscIdUnique 554--memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique-memptyClassOpKey  = mkPreludeMiscIdUnique 555-mappendClassOpKey = mkPreludeMiscIdUnique 556-mconcatClassOpKey = mkPreludeMiscIdUnique 557--emptyCallStackKey, pushCallStackKey :: Unique-emptyCallStackKey = mkPreludeMiscIdUnique 558-pushCallStackKey  = mkPreludeMiscIdUnique 559--fromStaticPtrClassOpKey :: Unique-fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560--makeStaticKey :: Unique-makeStaticKey = mkPreludeMiscIdUnique 561---- Unsafe coercion proofs-unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique-unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570-unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571---- HasField class ops-getFieldClassOpKey, setFieldClassOpKey :: Unique-getFieldClassOpKey = mkPreludeMiscIdUnique 572-setFieldClassOpKey = mkPreludeMiscIdUnique 573----------------------------------------------------------- ghc-bignum uses 600-699 uniques---------------------------------------------------------integerFromNaturalIdKey-   , integerToNaturalClampIdKey-   , integerToNaturalThrowIdKey-   , integerToNaturalIdKey-   , integerToWordIdKey-   , integerToIntIdKey-   , integerToWord64IdKey-   , integerToInt64IdKey-   , integerAddIdKey-   , integerMulIdKey-   , integerSubIdKey-   , integerNegateIdKey-   , integerAbsIdKey-   , integerPopCountIdKey-   , integerQuotIdKey-   , integerRemIdKey-   , integerDivIdKey-   , integerModIdKey-   , integerDivModIdKey-   , integerQuotRemIdKey-   , integerEncodeFloatIdKey-   , integerEncodeDoubleIdKey-   , integerGcdIdKey-   , integerLcmIdKey-   , integerAndIdKey-   , integerOrIdKey-   , integerXorIdKey-   , integerComplementIdKey-   , integerBitIdKey-   , integerTestBitIdKey-   , integerShiftLIdKey-   , integerShiftRIdKey-   , integerFromWordIdKey-   , integerFromWord64IdKey-   , integerFromInt64IdKey-   , naturalToWordIdKey-   , naturalPopCountIdKey-   , naturalShiftRIdKey-   , naturalShiftLIdKey-   , naturalAddIdKey-   , naturalSubIdKey-   , naturalSubThrowIdKey-   , naturalSubUnsafeIdKey-   , naturalMulIdKey-   , naturalQuotRemIdKey-   , naturalQuotIdKey-   , naturalRemIdKey-   , naturalAndIdKey-   , naturalAndNotIdKey-   , naturalOrIdKey-   , naturalXorIdKey-   , naturalTestBitIdKey-   , naturalBitIdKey-   , naturalGcdIdKey-   , naturalLcmIdKey-   , naturalLog2IdKey-   , naturalLogBaseWordIdKey-   , naturalLogBaseIdKey-   , naturalPowModIdKey-   , naturalSizeInBaseIdKey-   , bignatFromWordListIdKey-   , bignatEqIdKey-   , bignatCompareIdKey-   , bignatCompareWordIdKey-   :: Unique--integerFromNaturalIdKey    = mkPreludeMiscIdUnique 600-integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601-integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602-integerToNaturalIdKey      = mkPreludeMiscIdUnique 603-integerToWordIdKey         = mkPreludeMiscIdUnique 604-integerToIntIdKey          = mkPreludeMiscIdUnique 605-integerToWord64IdKey       = mkPreludeMiscIdUnique 606-integerToInt64IdKey        = mkPreludeMiscIdUnique 607-integerAddIdKey            = mkPreludeMiscIdUnique 608-integerMulIdKey            = mkPreludeMiscIdUnique 609-integerSubIdKey            = mkPreludeMiscIdUnique 610-integerNegateIdKey         = mkPreludeMiscIdUnique 611-integerAbsIdKey            = mkPreludeMiscIdUnique 618-integerPopCountIdKey       = mkPreludeMiscIdUnique 621-integerQuotIdKey           = mkPreludeMiscIdUnique 622-integerRemIdKey            = mkPreludeMiscIdUnique 623-integerDivIdKey            = mkPreludeMiscIdUnique 624-integerModIdKey            = mkPreludeMiscIdUnique 625-integerDivModIdKey         = mkPreludeMiscIdUnique 626-integerQuotRemIdKey        = mkPreludeMiscIdUnique 627-integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 630-integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 631-integerGcdIdKey            = mkPreludeMiscIdUnique 632-integerLcmIdKey            = mkPreludeMiscIdUnique 633-integerAndIdKey            = mkPreludeMiscIdUnique 634-integerOrIdKey             = mkPreludeMiscIdUnique 635-integerXorIdKey            = mkPreludeMiscIdUnique 636-integerComplementIdKey     = mkPreludeMiscIdUnique 637-integerBitIdKey            = mkPreludeMiscIdUnique 638-integerTestBitIdKey        = mkPreludeMiscIdUnique 639-integerShiftLIdKey         = mkPreludeMiscIdUnique 640-integerShiftRIdKey         = mkPreludeMiscIdUnique 641-integerFromWordIdKey       = mkPreludeMiscIdUnique 642-integerFromWord64IdKey     = mkPreludeMiscIdUnique 643-integerFromInt64IdKey      = mkPreludeMiscIdUnique 644--naturalToWordIdKey         = mkPreludeMiscIdUnique 650-naturalPopCountIdKey       = mkPreludeMiscIdUnique 659-naturalShiftRIdKey         = mkPreludeMiscIdUnique 660-naturalShiftLIdKey         = mkPreludeMiscIdUnique 661-naturalAddIdKey            = mkPreludeMiscIdUnique 662-naturalSubIdKey            = mkPreludeMiscIdUnique 663-naturalSubThrowIdKey       = mkPreludeMiscIdUnique 664-naturalSubUnsafeIdKey      = mkPreludeMiscIdUnique 665-naturalMulIdKey            = mkPreludeMiscIdUnique 666-naturalQuotRemIdKey        = mkPreludeMiscIdUnique 669-naturalQuotIdKey           = mkPreludeMiscIdUnique 670-naturalRemIdKey            = mkPreludeMiscIdUnique 671-naturalAndIdKey            = mkPreludeMiscIdUnique 672-naturalAndNotIdKey         = mkPreludeMiscIdUnique 673-naturalOrIdKey             = mkPreludeMiscIdUnique 674-naturalXorIdKey            = mkPreludeMiscIdUnique 675-naturalTestBitIdKey        = mkPreludeMiscIdUnique 676-naturalBitIdKey            = mkPreludeMiscIdUnique 677-naturalGcdIdKey            = mkPreludeMiscIdUnique 678-naturalLcmIdKey            = mkPreludeMiscIdUnique 679-naturalLog2IdKey           = mkPreludeMiscIdUnique 680-naturalLogBaseWordIdKey    = mkPreludeMiscIdUnique 681-naturalLogBaseIdKey        = mkPreludeMiscIdUnique 682-naturalPowModIdKey         = mkPreludeMiscIdUnique 683-naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684--bignatFromWordListIdKey    = mkPreludeMiscIdUnique 690-bignatEqIdKey              = mkPreludeMiscIdUnique 691-bignatCompareIdKey         = mkPreludeMiscIdUnique 692-bignatCompareWordIdKey     = mkPreludeMiscIdUnique 693------------------------------------------------------------ ghci optimization for big rationals 700-749 uniques----------------------------------------------------------- Creating rationals at runtime.-mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique-mkRationalBase2IdKey  = mkPreludeMiscIdUnique 700-mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique--{--************************************************************************-*                                                                      *-\subsection[Class-std-groups]{Standard groups of Prelude classes}-*                                                                      *-************************************************************************--NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@-even though every numeric class has these two as a superclass,-because the list of ambiguous dictionaries hasn't been simplified.--}--numericClassKeys :: [Unique]-numericClassKeys =-        [ numClassKey-        , realClassKey-        , integralClassKey-        ]-        ++ fractionalClassKeys--fractionalClassKeys :: [Unique]-fractionalClassKeys =-        [ fractionalClassKey-        , floatingClassKey-        , realFracClassKey-        , realFloatClassKey-        ]---- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4),--- and are: "classes defined in the Prelude or a standard library"-standardClassKeys :: [Unique]-standardClassKeys = derivableClassKeys ++ numericClassKeys-                  ++ [randomClassKey, randomGenClassKey,-                      functorClassKey,-                      monadClassKey, monadPlusClassKey, monadFailClassKey,-                      semigroupClassKey, monoidClassKey,-                      isStringClassKey,-                      applicativeClassKey, foldableClassKey,-                      traversableClassKey, alternativeClassKey-                     ]--{--@derivableClassKeys@ is also used in checking \tr{deriving} constructs-(@GHC.Tc.Deriv@).--}--derivableClassKeys :: [Unique]-derivableClassKeys-  = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,-      boundedClassKey, showClassKey, readClassKey ]----- These are the "interactive classes" that are consulted when doing--- defaulting. Does not include Num or IsString, which have special--- handling.-interactiveClassNames :: [Name]-interactiveClassNames-  = [ showClassName, eqClassName, ordClassName, foldableClassName-    , traversableClassName ]--interactiveClassKeys :: [Unique]-interactiveClassKeys = map getUnique interactiveClassNames--{--************************************************************************-*                                                                      *-   Semi-builtin names-*                                                                      *-************************************************************************--Note [pretendNameIsInScope]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general, we filter out instances that mention types whose names are-not in scope. However, in the situations listed below, we make an exception-for some commonly used names, such as Data.Kind.Type, which may not actually-be in scope but should be treated as though they were in scope.-This includes built-in names, as well as a few extra names such as-'Type', 'TYPE', 'BoxedRep', etc.--Situations in which we apply this special logic:--  - GHCi's :info command, see GHC.Runtime.Eval.getInfo.-    This fixes #1581.--  - When reporting instance overlap errors. Not doing so could mean-    that we would omit instances for typeclasses like--      type Cls :: k -> Constraint-      class Cls a--    because BoxedRep/Lifted were not in scope.-    See GHC.Tc.Errors.potentialInstancesErrMsg.-    This fixes one of the issues reported in #20465.--}---- | Should this name be considered in-scope, even though it technically isn't?------ This ensures that we don't filter out information because, e.g.,--- Data.Kind.Type isn't imported.------ See Note [pretendNameIsInScope].-pretendNameIsInScope :: Name -> Bool-pretendNameIsInScope n-  = isBuiltInSyntax n-  || any (n `hasKey`)-    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey-    , liftedDataConKey, unliftedDataConKey-    , tYPETyConKey-    , cONSTRAINTTyConKey-    , runtimeRepTyConKey, boxedRepDataConKey-    , eqTyConKey-    , listTyConKey-    , oneDataConKey-    , manyDataConKey-    , fUNTyConKey, unrestrictedFunTyConKey ]+Nota Bene: all Names defined in here should come from the base package,+the big-num package or (for plugins) the ghc package.++ - ModuleNames for prelude modules,+        e.g.    pRELUDE_NAME :: ModuleName++ - Modules for prelude modules+        e.g.    pRELUDE :: Module++ - Uniques for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    orderingTyConKey :: Unique+                minusClassOpKey :: Unique++ - Names for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    orderingTyConName :: Name+                minusName    :: Name+   One of these Names contains+        (a) the module and occurrence name of the thing+        (b) its Unique+   The way the compiler "knows about" one of these things is+   where the type checker or desugarer needs to look it up. For+   example, when desugaring list comprehensions the desugarer+   needs to conjure up 'foldr'.  It does this by looking up+   foldrName in the environment.++ - RdrNames for Ids, DataCons etc that the compiler may emit into+   generated code (e.g. for deriving).+        e.g.    and_RDR :: RdrName+   It's not necessary to know the uniques for these guys, only their names+++Note [Known-key names]+~~~~~~~~~~~~~~~~~~~~~~+It is *very* important that the compiler gives wired-in things and+things with "known-key" names the correct Uniques wherever they+occur. We have to be careful about this in exactly two places:++  1. When we parse some source code, renaming the AST better yield an+     AST whose Names have the correct uniques++  2. When we read an interface file, the read-in gubbins better have+     the right uniques++This is accomplished through a combination of mechanisms:++  1. When parsing source code, the RdrName-decorated AST has some+     RdrNames which are Exact. These are wired-in RdrNames where+     we could directly tell from the parsed syntax what Name to+     use. For example, when we parse a [] in a type and ListTuplePuns+     are enabled, we can just insert (Exact listTyConName :: RdrName).++     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+     GHC.Builtin.Types) are used to initialise the "OrigNameCache" in+     GHC.Iface.Env.  This initialization ensures that when the type checker+     or renamer (both of which use GHC.Iface.Env) look up an original name+     (i.e. a pair of a Module and an OccName) for a known-key name+     they get the correct Unique.++     This is the most important mechanism for ensuring that known-key+     stuff gets the right Unique, and is why it is so important to+     place your known-key names in the appropriate lists.++  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, 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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Infinite families of known-key things (e.g. tuples and sums) pose a tricky+problem: we can't add them to the knownKeyNames finite map which we use to+ensure that, e.g., a reference to (,) gets assigned the right unique (if this+doesn't sound familiar see Note [Known-key names] above).++We instead handle tuples and sums separately from the "vanilla" known-key+things,++  a) The parser recognises them specially and generates an Exact Name (hence not+     looked up in the orig-name cache)++  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.++  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]++-}++{-# LANGUAGE CPP #-}++module GHC.Builtin.Names+   ( Unique, Uniquable(..), hasKey,  -- Re-exported for convenience++   -----------------------------------------------------------+   module GHC.Builtin.Names, -- A huge bunch of (a) Names,  e.g. intTyConName+                             --                 (b) Uniques e.g. intTyConKey+                             --                 (c) Groups of classes and types+                             --                 (d) miscellaneous things+                             -- So many that we export them all+   )+where++import GHC.Prelude++import GHC.Unit.Types+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.Unique+import GHC.Builtin.Uniques+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Data.FastString+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import Language.Haskell.Syntax.Module.Name++{-+************************************************************************+*                                                                      *+     allNameStrings+*                                                                      *+************************************************************************+-}++allNameStrings :: Infinite String+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStrings = Inf.allListsOf ['a'..'z']++allNameStringList :: [String]+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStringList = Inf.toList allNameStrings++{-+************************************************************************+*                                                                      *+\subsection{Local Names}+*                                                                      *+************************************************************************++This *local* name is used by the interactive stuff+-}++itName :: Unique -> SrcSpan -> Name+itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc++-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly+-- during compiler debugging.+mkUnboundName :: OccName -> Name+mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan++isUnboundName :: Name -> Bool+isUnboundName name = name `hasKey` unboundKey++{-+************************************************************************+*                                                                      *+\subsection{Known key Names}+*                                                                      *+************************************************************************++This section tells what the compiler knows about the association of+names with uniques.  These ones are the *non* wired-in ones.  The+wired in ones are defined in GHC.Builtin.Types etc.+-}++basicKnownKeyNames :: [Name]  -- See Note [Known-key names]+basicKnownKeyNames+ = genericTyConNames+ ++ [   --  Classes.  *Must* include:+        --      classes that are grabbed by key (e.g., eqClassKey)+        --      classes in "Class.standardClassKeys" (quite a few)+        eqClassName,                    -- mentioned, derivable+        ordClassName,                   -- derivable+        boundedClassName,               -- derivable+        numClassName,                   -- mentioned, numeric+        enumClassName,                  -- derivable+        monadClassName,+        functorClassName,+        realClassName,                  -- numeric+        integralClassName,              -- numeric+        fractionalClassName,            -- numeric+        floatingClassName,              -- numeric+        realFracClassName,              -- numeric+        realFloatClassName,             -- numeric+        dataClassName,+        isStringClassName,+        applicativeClassName,+        alternativeClassName,+        foldableClassName,+        traversableClassName,+        semigroupClassName, sappendName,+        monoidClassName, memptyName, mappendName, mconcatName,++        -- The IO type+        ioTyConName, ioDataConName,+        runMainIOName,+        runRWName,++        -- Type representation types+        trModuleTyConName, trModuleDataConName,+        trNameTyConName, trNameSDataConName, trNameDDataConName,+        trTyConTyConName, trTyConDataConName,++        -- Typeable+        typeableClassName,+        typeRepTyConName,+        someTypeRepTyConName,+        someTypeRepDataConName,+        kindRepTyConName,+        kindRepTyConAppDataConName,+        kindRepVarDataConName,+        kindRepAppDataConName,+        kindRepFunDataConName,+        kindRepTYPEDataConName,+        kindRepTypeLitSDataConName,+        kindRepTypeLitDDataConName,+        typeLitSortTyConName,+        typeLitSymbolDataConName,+        typeLitNatDataConName,+        typeLitCharDataConName,+        typeRepIdName,+        mkTrTypeName,+        mkTrConName,+        mkTrAppCheckedName,+        mkTrFunName,+        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,+        trGhcPrimModuleName,++        -- KindReps for common cases+        starKindRepName,+        starArrStarKindRepName,+        starArrStarArrStarKindRepName,+        constraintKindRepName,++        -- WithDict+        withDictClassName,++        -- DataToTag+        dataToTagClassName,++        -- seq#+        seqHashName,++        -- Dynamic+        toDynName,++        -- Numeric stuff+        negateName, minusName, geName, eqName,+        mkRationalBase2Name, mkRationalBase10Name,++        -- Conversion functions+        rationalTyConName,+        ratioTyConName, ratioDataConName,+        fromRationalName, fromIntegerName,+        toIntegerName, toRationalName,+        fromIntegralName, realToFracName,++        -- Int# stuff+        divIntName, modIntName,++        -- String stuff+        fromStringName,++        -- Enum stuff+        enumFromName, enumFromThenName,+        enumFromThenToName, enumFromToName,++        -- Applicative stuff+        pureAName, apAName, thenAName,++        -- Functor stuff+        fmapName,++        -- Monad stuff+        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,+        returnMName, joinMName,++        -- MonadFail+        monadFailClassName, failMName,++        -- MonadFix+        monadFixClassName, mfixName,++        -- Arrow stuff+        arrAName, composeAName, firstAName,+        appAName, choiceAName, loopAName,++        -- Ix stuff+        ixClassName,++        -- Show stuff+        showClassName,++        -- Read stuff+        readClassName,++        -- Stable pointers+        newStablePtrName,++        -- GHC Extensions+        considerAccessibleName,++        -- Strings and lists+        unpackCStringName, unpackCStringUtf8Name,+        unpackCStringAppendName, unpackCStringAppendUtf8Name,+        unpackCStringFoldrName, unpackCStringFoldrUtf8Name,+        cstringLengthName,++        -- Overloaded lists+        isListClassName,+        fromListName,+        fromListNName,+        toListName,++        -- Non-empty lists+        nonEmptyTyConName,++        -- Overloaded record dot, record update+        getFieldName, setFieldName,++        -- List operations+        concatName, filterName, mapName,+        zipName, foldrName, buildName, augmentName, appendName,++        -- FFI primitive types that are not wired-in.+        stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,+        int8TyConName, int16TyConName, int32TyConName, int64TyConName,+        word8TyConName, word16TyConName, word32TyConName, word64TyConName,+        jsvalTyConName,++        -- Others+        otherwiseIdName, inlineIdName,+        eqStringName, assertName,+        assertErrorName, traceName,+        printName,+        dollarName,++        -- ghc-bignum+        integerFromNaturalName,+        integerToNaturalClampName,+        integerToNaturalThrowName,+        integerToNaturalName,+        integerToWordName,+        integerToIntName,+        integerToWord64Name,+        integerToInt64Name,+        integerFromWordName,+        integerFromWord64Name,+        integerFromInt64Name,+        integerAddName,+        integerMulName,+        integerSubName,+        integerNegateName,+        integerAbsName,+        integerPopCountName,+        integerQuotName,+        integerRemName,+        integerDivName,+        integerModName,+        integerDivModName,+        integerQuotRemName,+        integerEncodeFloatName,+        integerEncodeDoubleName,+        integerGcdName,+        integerLcmName,+        integerAndName,+        integerOrName,+        integerXorName,+        integerComplementName,+        integerBitName,+        integerTestBitName,+        integerShiftLName,+        integerShiftRName,++        naturalToWordName,+        naturalPopCountName,+        naturalShiftRName,+        naturalShiftLName,+        naturalAddName,+        naturalSubName,+        naturalSubThrowName,+        naturalSubUnsafeName,+        naturalMulName,+        naturalQuotRemName,+        naturalQuotName,+        naturalRemName,+        naturalAndName,+        naturalAndNotName,+        naturalOrName,+        naturalXorName,+        naturalTestBitName,+        naturalBitName,+        naturalGcdName,+        naturalLcmName,+        naturalLog2Name,+        naturalLogBaseWordName,+        naturalLogBaseName,+        naturalPowModName,+        naturalSizeInBaseName,++        bignatEqName,++        -- Float/Double+        integerToFloatName,+        integerToDoubleName,+        naturalToFloatName,+        naturalToDoubleName,+        rationalToFloatName,+        rationalToDoubleName,++        -- Other classes+        monadPlusClassName,++        -- Type-level naturals+        knownNatClassName, knownSymbolClassName, knownCharClassName,++        -- Overloaded labels+        fromLabelClassOpName,++        -- Implicit Parameters+        ipClassName,++        -- Overloaded record fields+        hasFieldClassName,++        -- ExceptionContext+        exceptionContextTyConName,+        emptyExceptionContextName,++        -- Call Stacks+        callStackTyConName,+        emptyCallStackName, pushCallStackName,++        -- Source Locations+        srcLocDataConName,++        -- Annotation type checking+        toAnnotationWrapperName++        -- The SPEC type for SpecConstr+        , specTyConName++        -- The Either type+        , eitherTyConName, leftDataConName, rightDataConName++        -- The Void type+        , voidTyConName++        -- Plugins+        , pluginTyConName+        , frontendPluginTyConName++        -- Generics+        , genClassName, gen1ClassName+        , datatypeClassName, constructorClassName, selectorClassName++        -- Monad comprehensions+        , guardMName+        , liftMName+        , mzipName++        -- GHCi Sandbox+        , ghciIoClassName, ghciStepIoMName++        -- StaticPtr+        , makeStaticName+        , staticPtrTyConName+        , staticPtrDataConName, staticPtrInfoDataConName+        , fromStaticPtrName++        -- Fingerprint+        , fingerprintDataConName++        -- Custom type errors+        , errorMessageTypeErrorFamName+        , typeErrorTextDataConName+        , typeErrorAppendDataConName+        , typeErrorVAppendDataConName+        , typeErrorShowTypeDataConName++        -- "Unsatisfiable" constraint+        , unsatisfiableClassName+        , unsatisfiableIdName++        -- Unsafe coercion proofs+        , unsafeEqualityProofName+        , unsafeEqualityTyConName+        , unsafeReflDataConName+        , unsafeCoercePrimName++        , unsafeUnpackJSStringUtf8ShShName+    ]++genericTyConNames :: [Name]+genericTyConNames = [+    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+    k1TyConName, m1TyConName, sumTyConName, prodTyConName,+    compTyConName, rTyConName, dTyConName,+    cTyConName, sTyConName, rec0TyConName,+    d1TyConName, c1TyConName, s1TyConName,+    repTyConName, rep1TyConName, uRecTyConName,+    uAddrTyConName, uCharTyConName, uDoubleTyConName,+    uFloatTyConName, uIntTyConName, uWordTyConName,+    prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+    rightAssociativeDataConName, notAssociativeDataConName,+    sourceUnpackDataConName, sourceNoUnpackDataConName,+    noSourceUnpackednessDataConName, sourceLazyDataConName,+    sourceStrictDataConName, noSourceStrictnessDataConName,+    decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+    metaDataDataConName, metaConsDataConName, metaSelDataConName+  ]++{-+************************************************************************+*                                                                      *+\subsection{Module names}+*                                                                      *+************************************************************************+++--MetaHaskell Extension Add a new module here+-}++gHC_PRIM, gHC_PRIM_PANIC,+    gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT,+    gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module+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            = 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,+    gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE,+    gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER,+    gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE,+    gHC_INTERNAL_EXCEPTION_CONTEXT,+    gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception,+    gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL,+    gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC,+    gHC_INTERNAL_TYPEABLE, gHC_INTERNAL_TYPEABLE_INTERNAL, gHC_INTERNAL_GENERICS,+    gHC_INTERNAL_READ_PREC, gHC_INTERNAL_LEX, gHC_INTERNAL_INT, gHC_INTERNAL_WORD, gHC_INTERNAL_MONAD, gHC_INTERNAL_MONAD_FIX,  gHC_INTERNAL_MONAD_FAIL,+    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,+    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")+gHC_INTERNAL_GHCI_HELPERS           = mkGhcInternalModule (fsLit "GHC.Internal.GHCi.Helpers")+gHC_INTERNAL_SHOW                   = mkGhcInternalModule (fsLit "GHC.Internal.Show")+gHC_INTERNAL_READ                   = mkGhcInternalModule (fsLit "GHC.Internal.Read")+gHC_INTERNAL_NUM                    = mkGhcInternalModule (fsLit "GHC.Internal.Num")+gHC_INTERNAL_MAYBE                  = mkGhcInternalModule (fsLit "GHC.Internal.Maybe")+gHC_INTERNAL_LIST                   = mkGhcInternalModule (fsLit "GHC.Internal.List")+gHC_INTERNAL_DATA_EITHER            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Either")+gHC_INTERNAL_DATA_STRING            = mkGhcInternalModule (fsLit "GHC.Internal.Data.String")+gHC_INTERNAL_DATA_FOLDABLE          = mkGhcInternalModule (fsLit "GHC.Internal.Data.Foldable")+gHC_INTERNAL_DATA_TRAVERSABLE       = mkGhcInternalModule (fsLit "GHC.Internal.Data.Traversable")+gHC_INTERNAL_CONC                   = mkGhcInternalModule (fsLit "GHC.Internal.GHC.Conc")+gHC_INTERNAL_IO                     = mkGhcInternalModule (fsLit "GHC.Internal.IO")+gHC_INTERNAL_IO_Exception           = mkGhcInternalModule (fsLit "GHC.Internal.IO.Exception")+gHC_INTERNAL_ST                     = mkGhcInternalModule (fsLit "GHC.Internal.ST")+gHC_INTERNAL_IX                     = mkGhcInternalModule (fsLit "GHC.Internal.Ix")+gHC_INTERNAL_STABLE                 = mkGhcInternalModule (fsLit "GHC.Internal.Stable")+gHC_INTERNAL_PTR                    = mkGhcInternalModule (fsLit "GHC.Internal.Ptr")+gHC_INTERNAL_ERR                    = mkGhcInternalModule (fsLit "GHC.Internal.Err")+gHC_INTERNAL_REAL                   = mkGhcInternalModule (fsLit "GHC.Internal.Real")+gHC_INTERNAL_FLOAT                  = mkGhcInternalModule (fsLit "GHC.Internal.Float")+gHC_INTERNAL_TOP_HANDLER            = mkGhcInternalModule (fsLit "GHC.Internal.TopHandler")+gHC_INTERNAL_SYSTEM_IO              = mkGhcInternalModule (fsLit "GHC.Internal.System.IO")+gHC_INTERNAL_DYNAMIC                = mkGhcInternalModule (fsLit "GHC.Internal.Data.Dynamic")+gHC_INTERNAL_TYPEABLE               = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable")+gHC_INTERNAL_TYPEABLE_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable.Internal")+gHC_INTERNAL_DATA_DATA              = mkGhcInternalModule (fsLit "GHC.Internal.Data.Data")+gHC_INTERNAL_READ_PREC              = mkGhcInternalModule (fsLit "GHC.Internal.Text.ParserCombinators.ReadPrec")+gHC_INTERNAL_LEX                    = mkGhcInternalModule (fsLit "GHC.Internal.Text.Read.Lex")+gHC_INTERNAL_INT                    = mkGhcInternalModule (fsLit "GHC.Internal.Int")+gHC_INTERNAL_WORD                   = mkGhcInternalModule (fsLit "GHC.Internal.Word")+gHC_INTERNAL_MONAD                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad")+gHC_INTERNAL_MONAD_FIX              = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fix")+gHC_INTERNAL_MONAD_FAIL             = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fail")+gHC_INTERNAL_ARROW                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Arrow")+gHC_INTERNAL_DESUGAR                = mkGhcInternalModule (fsLit "GHC.Internal.Desugar")+gHC_INTERNAL_RANDOM                 = mkGhcInternalModule (fsLit "GHC.Internal.System.Random")+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_GENERICS               = mkGhcInternalModule (fsLit "GHC.Internal.Generics")+gHC_INTERNAL_TYPEERROR              = mkGhcInternalModule (fsLit "GHC.Internal.TypeError")+gHC_INTERNAL_TYPELITS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")+gHC_INTERNAL_TYPELITS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits.Internal")+gHC_INTERNAL_TYPENATS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats")+gHC_INTERNAL_TYPENATS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats.Internal")+gHC_INTERNAL_DATA_COERCE            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Coerce")+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")++gHC_INTERNAL_STACK, gHC_INTERNAL_STACK_TYPES :: Module+gHC_INTERNAL_STACK = mkGhcInternalModule (fsLit "GHC.Internal.Stack")+gHC_INTERNAL_STACK_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Stack.Types")++gHC_INTERNAL_STATICPTR :: Module+gHC_INTERNAL_STATICPTR = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr")++gHC_INTERNAL_STATICPTR_INTERNAL :: Module+gHC_INTERNAL_STATICPTR_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr.Internal")++gHC_INTERNAL_FINGERPRINT_TYPE :: Module+gHC_INTERNAL_FINGERPRINT_TYPE = mkGhcInternalModule (fsLit "GHC.Internal.Fingerprint.Type")++gHC_INTERNAL_OVER_LABELS :: Module+gHC_INTERNAL_OVER_LABELS = mkGhcInternalModule (fsLit "GHC.Internal.OverloadedLabels")++gHC_INTERNAL_RECORDS :: Module+gHC_INTERNAL_RECORDS = mkGhcInternalModule (fsLit "GHC.Internal.Records")++rOOT_MAIN :: Module+rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation++mkInteractiveModule :: String -> Module+-- (mkInteractiveMoudule "9") makes module 'interactive:Ghci9'+mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n))++pRELUDE_NAME, mAIN_NAME :: ModuleName+pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")+mAIN_NAME      = mkModuleNameFS (fsLit "Main")++mkGhcInternalModule :: FastString -> Module+mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m)++mkGhcInternalModule_ :: ModuleName -> Module+mkGhcInternalModule_ m = mkModule ghcInternalUnit m++mkThisGhcModule :: FastString -> Module+mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)++mkThisGhcModule_ :: ModuleName -> Module+mkThisGhcModule_ m = mkModule thisGhcUnit m++mkMainModule :: FastString -> Module+mkMainModule m = mkModule mainUnit (mkModuleNameFS m)++mkMainModule_ :: ModuleName -> Module+mkMainModule_ m = mkModule mainUnit m++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++main_RDR_Unqual    :: RdrName+main_RDR_Unqual = mkUnqual varName (fsLit "main")+        -- We definitely don't want an Orig RdrName, because+        -- main might, in principle, be imported into module Main++eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR,+    ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName+eq_RDR                  = nameRdrName eqName+ge_RDR                  = nameRdrName geName+le_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<=")+lt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<")+gt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit ">")+compare_RDR             = varQual_RDR  gHC_CLASSES (fsLit "compare")+ltTag_RDR               = nameRdrName  ordLTDataConName+eqTag_RDR               = nameRdrName  ordEQDataConName+gtTag_RDR               = nameRdrName  ordGTDataConName++map_RDR, append_RDR :: RdrName+map_RDR                 = nameRdrName mapName+append_RDR              = nameRdrName appendName++foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR+    :: RdrName+foldr_RDR               = nameRdrName foldrName+build_RDR               = nameRdrName buildName+returnM_RDR             = nameRdrName returnMName+bindM_RDR               = nameRdrName bindMName+failM_RDR               = nameRdrName failMName++left_RDR, right_RDR :: RdrName+left_RDR                = nameRdrName leftDataConName+right_RDR               = nameRdrName rightDataConName++fromEnum_RDR, toEnum_RDR, toEnumError_RDR, succError_RDR, predError_RDR, enumIntToWord_RDR :: RdrName+fromEnum_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "fromEnum")+toEnum_RDR              = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnum")+toEnumError_RDR         = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnumError")+succError_RDR           = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succError")+predError_RDR           = varQual_RDR gHC_INTERNAL_ENUM (fsLit "predError")+enumIntToWord_RDR       = varQual_RDR gHC_INTERNAL_ENUM (fsLit "enumIntToWord")++enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName+enumFrom_RDR            = nameRdrName enumFromName+enumFromTo_RDR          = nameRdrName enumFromToName+enumFromThen_RDR        = nameRdrName enumFromThenName+enumFromThenTo_RDR      = nameRdrName enumFromThenToName++times_RDR, plus_RDR :: RdrName+times_RDR               = varQual_RDR  gHC_INTERNAL_NUM (fsLit "*")+plus_RDR                = varQual_RDR gHC_INTERNAL_NUM (fsLit "+")++compose_RDR :: RdrName+compose_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit ".")++not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,+    and_RDR, range_RDR, inRange_RDR, index_RDR,+    unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName+and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&")+not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")+dataToTag_RDR           = varQual_RDR gHC_MAGIC (fsLit "dataToTag#")+succ_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succ")+pred_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "pred")+minBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "minBound")+maxBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "maxBound")+range_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "range")+inRange_RDR             = varQual_RDR gHC_INTERNAL_IX (fsLit "inRange")+index_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "index")+unsafeIndex_RDR         = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeIndex")+unsafeRangeSize_RDR     = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeRangeSize")++readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,+    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName+readList_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readList")+readListDefault_RDR     = varQual_RDR gHC_INTERNAL_READ (fsLit "readListDefault")+readListPrec_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrec")+readListPrecDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrecDefault")+readPrec_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readPrec")+parens_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "parens")+choose_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "choose")+lexP_RDR                = varQual_RDR gHC_INTERNAL_READ (fsLit "lexP")+expectP_RDR             = varQual_RDR gHC_INTERNAL_READ (fsLit "expectP")++readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName+readField_RDR           = varQual_RDR gHC_INTERNAL_READ (fsLit "readField")+readFieldHash_RDR       = varQual_RDR gHC_INTERNAL_READ (fsLit "readFieldHash")+readSymField_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readSymField")++punc_RDR, ident_RDR, symbol_RDR :: RdrName+punc_RDR                = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Punc")+ident_RDR               = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Ident")+symbol_RDR              = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Symbol")++step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName+step_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "step")+alt_RDR                 = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "+++")+reset_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "reset")+prec_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "prec")+pfail_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "pfail")++showsPrec_RDR, shows_RDR, showString_RDR,+    showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName+showsPrec_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showsPrec")+shows_RDR               = varQual_RDR gHC_INTERNAL_SHOW (fsLit "shows")+showString_RDR          = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showString")+showSpace_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showSpace")+showCommaSpace_RDR      = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showCommaSpace")+showParen_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showParen")++error_RDR :: RdrName+error_RDR = varQual_RDR gHC_INTERNAL_ERR (fsLit "error")++-- Generics (constructors and functions)+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,+  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,+  prodDataCon_RDR, comp1DataCon_RDR,+  unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,+  from_RDR, from1_RDR, to_RDR, to1_RDR,+  datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,+  conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR,+  prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,+  rightAssocDataCon_RDR, notAssocDataCon_RDR,+  uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,+  uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,+  uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,+  uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName++u1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "U1")+par1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")+rec1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")+k1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")+m1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "M1")++l1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "L1")+r1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "R1")++prodDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit ":*:")+comp1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1")++unPar1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")  (fsLit "unPar1")+unRec1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")  (fsLit "unRec1")+unK1_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")    (fsLit "unK1")+unComp1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") (fsLit "unComp1")++from_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from")+from1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from1")+to_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to")+to1_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to1")++datatypeName_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "datatypeName")+moduleName_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "moduleName")+packageName_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "packageName")+isNewtypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "isNewtype")+selName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "selName")+conName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conName")+conFixity_RDR     = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conFixity")+conIsRecord_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conIsRecord")++prefixDataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Prefix")+infixDataCon_RDR      = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Infix")+leftAssocDataCon_RDR  = nameRdrName leftAssociativeDataConName+rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName+notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName++uAddrDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")+uCharDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")+uDoubleDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble")+uFloatDataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")+uIntDataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")+uWordDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")++uAddrHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")   (fsLit "uAddr#")+uCharHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")   (fsLit "uChar#")+uDoubleHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") (fsLit "uDouble#")+uFloatHash_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")  (fsLit "uFloat#")+uIntHash_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")    (fsLit "uInt#")+uWordHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")   (fsLit "uWord#")++fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,+    foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,+    mappend_RDR :: RdrName+fmap_RDR                = nameRdrName fmapName+replace_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$")+pure_RDR                = nameRdrName pureAName+ap_RDR                  = nameRdrName apAName+liftA2_RDR              = varQual_RDR gHC_INTERNAL_BASE (fsLit "liftA2")+foldable_foldr_RDR      = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldr")+foldMap_RDR             = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldMap")+null_RDR                = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "null")+all_RDR                 = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "all")+traverse_RDR            = varQual_RDR gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "traverse")+mempty_RDR              = nameRdrName memptyName+mappend_RDR             = nameRdrName mappendName++----------------------+varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR+    :: Module -> FastString -> RdrName+varQual_RDR  mod str = mkOrig mod (mkOccNameFS varName str)+tcQual_RDR   mod str = mkOrig mod (mkOccNameFS tcName str)+clsQual_RDR  mod str = mkOrig mod (mkOccNameFS clsName str)+dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)++fieldQual_RDR :: Module -> FastString -> FastString -> RdrName+fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str)++{-+************************************************************************+*                                                                      *+\subsection{Known-key names}+*                                                                      *+************************************************************************++Many of these Names are not really "built in", but some parts of the+compiler (notably the deriving mechanism) need to mention their names,+and it's convenient to write them all down in one place.+-}++wildCardName :: Name+wildCardName = mkSystemVarName wildCardKey (fsLit "wild")++runMainIOName, runRWName :: Name+runMainIOName = varQual gHC_INTERNAL_TOP_HANDLER (fsLit "runMainIO") runMainKey+runRWName     = varQual gHC_MAGIC       (fsLit "runRW#")    runRWKey++orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name+orderingTyConName = tcQual  gHC_TYPES (fsLit "Ordering") orderingTyConKey+ordLTDataConName     = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey+ordEQDataConName     = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey+ordGTDataConName     = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey++specTyConName :: Name+specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey++eitherTyConName, leftDataConName, rightDataConName :: Name+eitherTyConName   = tcQual  gHC_INTERNAL_DATA_EITHER (fsLit "Either") eitherTyConKey+leftDataConName   = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Left")   leftDataConKey+rightDataConName  = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Right")  rightDataConKey++voidTyConName :: Name+voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey++-- Generics (types)+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+  k1TyConName, m1TyConName, sumTyConName, prodTyConName,+  compTyConName, rTyConName, dTyConName,+  cTyConName, sTyConName, rec0TyConName,+  d1TyConName, c1TyConName, s1TyConName,+  repTyConName, rep1TyConName, uRecTyConName,+  uAddrTyConName, uCharTyConName, uDoubleTyConName,+  uFloatTyConName, uIntTyConName, uWordTyConName,+  prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+  rightAssociativeDataConName, notAssociativeDataConName,+  sourceUnpackDataConName, sourceNoUnpackDataConName,+  noSourceUnpackednessDataConName, sourceLazyDataConName,+  sourceStrictDataConName, noSourceStrictnessDataConName,+  decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+  metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name++v1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey+u1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey+par1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey+rec1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey+k1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey+m1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey++sumTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey+prodTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey+compTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey++rTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey+dTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey+cTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey+sTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey++rec0TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey+d1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey+c1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey+s1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey++repTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep")  repTyConKey+rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey++uRecTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey+uAddrTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey+uCharTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey+uDoubleTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey+uFloatTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit "UFloat") uFloatTyConKey+uIntTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "UInt") uIntTyConKey+uWordTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UWord") uWordTyConKey++prefixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "PrefixI")  prefixIDataConKey+infixIDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "InfixI")   infixIDataConKey+leftAssociativeDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey+rightAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey+notAssociativeDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey++sourceUnpackDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey+sourceNoUnpackDataConName       = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey+noSourceUnpackednessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey+sourceLazyDataConName           = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey+sourceStrictDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey+noSourceStrictnessDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey+decidedLazyDataConName          = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey+decidedStrictDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey+decidedUnpackDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey++metaDataDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData")  metaDataDataConKey+metaConsDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons")  metaConsDataConKey+metaSelDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel")   metaSelDataConKey++-- Primitive Int+divIntName, modIntName :: Name+divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey+modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey++-- Base strings Strings+unpackCStringName, unpackCStringFoldrName,+    unpackCStringUtf8Name, unpackCStringFoldrUtf8Name,+    unpackCStringAppendName, unpackCStringAppendUtf8Name,+    eqStringName, cstringLengthName :: Name+cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey+eqStringName            = varQual gHC_INTERNAL_BASE (fsLit "eqString")  eqStringIdKey++unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey+unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey++unpackCStringUtf8Name       = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey+unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey+unpackCStringFoldrUtf8Name  = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey+++-- The 'inline' function+inlineIdName :: Name+inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey++-- Base classes (Eq, Ord, Functor)+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name+eqClassName       = clsQual gHC_CLASSES (fsLit "Eq")      eqClassKey+eqName            = varQual gHC_CLASSES (fsLit "==")      eqClassOpKey+ordClassName      = clsQual gHC_CLASSES (fsLit "Ord")     ordClassKey+geName            = varQual gHC_CLASSES (fsLit ">=")      geClassOpKey+functorClassName  = clsQual gHC_INTERNAL_BASE    (fsLit "Functor") functorClassKey+fmapName          = varQual gHC_INTERNAL_BASE    (fsLit "fmap")    fmapClassOpKey++-- Class Monad+monadClassName, thenMName, bindMName, returnMName :: Name+monadClassName     = clsQual gHC_INTERNAL_BASE (fsLit "Monad")  monadClassKey+thenMName          = varQual gHC_INTERNAL_BASE (fsLit ">>")     thenMClassOpKey+bindMName          = varQual gHC_INTERNAL_BASE (fsLit ">>=")    bindMClassOpKey+returnMName        = varQual gHC_INTERNAL_BASE (fsLit "return") returnMClassOpKey++-- Class MonadFail+monadFailClassName, failMName :: Name+monadFailClassName = clsQual gHC_INTERNAL_MONAD_FAIL (fsLit "MonadFail") monadFailClassKey+failMName          = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail")      failMClassOpKey++-- Class Applicative+applicativeClassName, pureAName, apAName, thenAName :: Name+applicativeClassName = clsQual gHC_INTERNAL_BASE (fsLit "Applicative") applicativeClassKey+apAName              = varQual gHC_INTERNAL_BASE (fsLit "<*>")         apAClassOpKey+pureAName            = varQual gHC_INTERNAL_BASE (fsLit "pure")        pureAClassOpKey+thenAName            = varQual gHC_INTERNAL_BASE (fsLit "*>")          thenAClassOpKey++-- Classes (Foldable, Traversable)+foldableClassName, traversableClassName :: Name+foldableClassName     = clsQual  gHC_INTERNAL_DATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey+traversableClassName  = clsQual  gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey++-- Classes (Semigroup, Monoid)+semigroupClassName, sappendName :: Name+semigroupClassName = clsQual gHC_INTERNAL_BASE       (fsLit "Semigroup") semigroupClassKey+sappendName        = varQual gHC_INTERNAL_BASE       (fsLit "<>")        sappendClassOpKey+monoidClassName, memptyName, mappendName, mconcatName :: Name+monoidClassName    = clsQual gHC_INTERNAL_BASE       (fsLit "Monoid")    monoidClassKey+memptyName         = varQual gHC_INTERNAL_BASE       (fsLit "mempty")    memptyClassOpKey+mappendName        = varQual gHC_INTERNAL_BASE       (fsLit "mappend")   mappendClassOpKey+mconcatName        = varQual gHC_INTERNAL_BASE       (fsLit "mconcat")   mconcatClassOpKey++++-- AMP additions++joinMName, alternativeClassName :: Name+joinMName            = varQual gHC_INTERNAL_BASE (fsLit "join")        joinMIdKey+alternativeClassName = clsQual gHC_INTERNAL_MONAD (fsLit "Alternative") alternativeClassKey++--+joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey,+    alternativeClassKey :: Unique+joinMIdKey          = mkPreludeMiscIdUnique 750+apAClassOpKey       = mkPreludeMiscIdUnique 751 -- <*>+pureAClassOpKey     = mkPreludeMiscIdUnique 752+thenAClassOpKey     = mkPreludeMiscIdUnique 753+alternativeClassKey = mkPreludeMiscIdUnique 754+++-- Functions for GHC extensions+considerAccessibleName :: Name+considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey++-- Random GHC.Internal.Base functions+fromStringName, otherwiseIdName, foldrName, buildName, augmentName,+    mapName, appendName, assertName,+    dollarName :: Name+dollarName        = varQual gHC_INTERNAL_BASE (fsLit "$")          dollarIdKey+otherwiseIdName   = varQual gHC_INTERNAL_BASE (fsLit "otherwise")  otherwiseIdKey+foldrName         = varQual gHC_INTERNAL_BASE (fsLit "foldr")      foldrIdKey+buildName         = varQual gHC_INTERNAL_BASE (fsLit "build")      buildIdKey+augmentName       = varQual gHC_INTERNAL_BASE (fsLit "augment")    augmentIdKey+mapName           = varQual gHC_INTERNAL_BASE (fsLit "map")        mapIdKey+appendName        = varQual gHC_INTERNAL_BASE (fsLit "++")         appendIdKey+assertName        = varQual gHC_INTERNAL_BASE (fsLit "assert")     assertIdKey+fromStringName    = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey++-- Module GHC.Internal.Num+numClassName, fromIntegerName, minusName, negateName :: Name+numClassName      = clsQual gHC_INTERNAL_NUM (fsLit "Num")         numClassKey+fromIntegerName   = varQual gHC_INTERNAL_NUM (fsLit "fromInteger") fromIntegerClassOpKey+minusName         = varQual gHC_INTERNAL_NUM (fsLit "-")           minusClassOpKey+negateName        = varQual gHC_INTERNAL_NUM (fsLit "negate")      negateClassOpKey++---------------------------------+-- ghc-bignum+---------------------------------+integerFromNaturalName+   , integerToNaturalClampName+   , integerToNaturalThrowName+   , integerToNaturalName+   , integerToWordName+   , integerToIntName+   , integerToWord64Name+   , integerToInt64Name+   , integerFromWordName+   , integerFromWord64Name+   , integerFromInt64Name+   , integerAddName+   , integerMulName+   , integerSubName+   , integerNegateName+   , integerAbsName+   , integerPopCountName+   , integerQuotName+   , integerRemName+   , integerDivName+   , integerModName+   , integerDivModName+   , integerQuotRemName+   , integerEncodeFloatName+   , integerEncodeDoubleName+   , integerGcdName+   , integerLcmName+   , integerAndName+   , integerOrName+   , integerXorName+   , integerComplementName+   , integerBitName+   , integerTestBitName+   , integerShiftLName+   , integerShiftRName+   , naturalToWordName+   , naturalPopCountName+   , naturalShiftRName+   , naturalShiftLName+   , naturalAddName+   , naturalSubName+   , naturalSubThrowName+   , naturalSubUnsafeName+   , naturalMulName+   , naturalQuotRemName+   , naturalQuotName+   , naturalRemName+   , naturalAndName+   , naturalAndNotName+   , naturalOrName+   , naturalXorName+   , naturalTestBitName+   , naturalBitName+   , naturalGcdName+   , naturalLcmName+   , naturalLog2Name+   , naturalLogBaseWordName+   , naturalLogBaseName+   , naturalPowModName+   , naturalSizeInBaseName+   , bignatEqName+   , bignatCompareName+   , bignatCompareWordName+   :: Name++bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name+bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT  (fsLit str) key+bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key+bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key++-- Types and DataCons+bignatEqName              = bnbVarQual "bigNatEq#"                 bignatEqIdKey+bignatCompareName         = bnbVarQual "bigNatCompare"             bignatCompareIdKey+bignatCompareWordName     = bnbVarQual "bigNatCompareWord#"        bignatCompareWordIdKey++naturalToWordName         = bnnVarQual "naturalToWord#"            naturalToWordIdKey+naturalPopCountName       = bnnVarQual "naturalPopCount#"          naturalPopCountIdKey+naturalShiftRName         = bnnVarQual "naturalShiftR#"            naturalShiftRIdKey+naturalShiftLName         = bnnVarQual "naturalShiftL#"            naturalShiftLIdKey+naturalAddName            = bnnVarQual "naturalAdd"                naturalAddIdKey+naturalSubName            = bnnVarQual "naturalSub"                naturalSubIdKey+naturalSubThrowName       = bnnVarQual "naturalSubThrow"           naturalSubThrowIdKey+naturalSubUnsafeName      = bnnVarQual "naturalSubUnsafe"          naturalSubUnsafeIdKey+naturalMulName            = bnnVarQual "naturalMul"                naturalMulIdKey+naturalQuotRemName        = bnnVarQual "naturalQuotRem#"           naturalQuotRemIdKey+naturalQuotName           = bnnVarQual "naturalQuot"               naturalQuotIdKey+naturalRemName            = bnnVarQual "naturalRem"                naturalRemIdKey+naturalAndName            = bnnVarQual "naturalAnd"                naturalAndIdKey+naturalAndNotName         = bnnVarQual "naturalAndNot"             naturalAndNotIdKey+naturalOrName             = bnnVarQual "naturalOr"                 naturalOrIdKey+naturalXorName            = bnnVarQual "naturalXor"                naturalXorIdKey+naturalTestBitName        = bnnVarQual "naturalTestBit#"           naturalTestBitIdKey+naturalBitName            = bnnVarQual "naturalBit#"               naturalBitIdKey+naturalGcdName            = bnnVarQual "naturalGcd"                naturalGcdIdKey+naturalLcmName            = bnnVarQual "naturalLcm"                naturalLcmIdKey+naturalLog2Name           = bnnVarQual "naturalLog2#"              naturalLog2IdKey+naturalLogBaseWordName    = bnnVarQual "naturalLogBaseWord#"       naturalLogBaseWordIdKey+naturalLogBaseName        = bnnVarQual "naturalLogBase#"           naturalLogBaseIdKey+naturalPowModName         = bnnVarQual "naturalPowMod"             naturalPowModIdKey+naturalSizeInBaseName     = bnnVarQual "naturalSizeInBase#"        naturalSizeInBaseIdKey++integerFromNaturalName    = bniVarQual "integerFromNatural"        integerFromNaturalIdKey+integerToNaturalClampName = bniVarQual "integerToNaturalClamp"     integerToNaturalClampIdKey+integerToNaturalThrowName = bniVarQual "integerToNaturalThrow"     integerToNaturalThrowIdKey+integerToNaturalName      = bniVarQual "integerToNatural"          integerToNaturalIdKey+integerToWordName         = bniVarQual "integerToWord#"            integerToWordIdKey+integerToIntName          = bniVarQual "integerToInt#"             integerToIntIdKey+integerToWord64Name       = bniVarQual "integerToWord64#"          integerToWord64IdKey+integerToInt64Name        = bniVarQual "integerToInt64#"           integerToInt64IdKey+integerFromWordName       = bniVarQual "integerFromWord#"          integerFromWordIdKey+integerFromWord64Name     = bniVarQual "integerFromWord64#"        integerFromWord64IdKey+integerFromInt64Name      = bniVarQual "integerFromInt64#"         integerFromInt64IdKey+integerAddName            = bniVarQual "integerAdd"                integerAddIdKey+integerMulName            = bniVarQual "integerMul"                integerMulIdKey+integerSubName            = bniVarQual "integerSub"                integerSubIdKey+integerNegateName         = bniVarQual "integerNegate"             integerNegateIdKey+integerAbsName            = bniVarQual "integerAbs"                integerAbsIdKey+integerPopCountName       = bniVarQual "integerPopCount#"          integerPopCountIdKey+integerQuotName           = bniVarQual "integerQuot"               integerQuotIdKey+integerRemName            = bniVarQual "integerRem"                integerRemIdKey+integerDivName            = bniVarQual "integerDiv"                integerDivIdKey+integerModName            = bniVarQual "integerMod"                integerModIdKey+integerDivModName         = bniVarQual "integerDivMod#"            integerDivModIdKey+integerQuotRemName        = bniVarQual "integerQuotRem#"           integerQuotRemIdKey+integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey+integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey+integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey+integerLcmName            = bniVarQual "integerLcm"                integerLcmIdKey+integerAndName            = bniVarQual "integerAnd"                integerAndIdKey+integerOrName             = bniVarQual "integerOr"                 integerOrIdKey+integerXorName            = bniVarQual "integerXor"                integerXorIdKey+integerComplementName     = bniVarQual "integerComplement"         integerComplementIdKey+integerBitName            = bniVarQual "integerBit#"               integerBitIdKey+integerTestBitName        = bniVarQual "integerTestBit#"           integerTestBitIdKey+integerShiftLName         = bniVarQual "integerShiftL#"            integerShiftLIdKey+integerShiftRName         = bniVarQual "integerShiftR#"            integerShiftRIdKey++++---------------------------------+-- End of ghc-bignum+---------------------------------++-- GHC.Internal.Real types and classes+rationalTyConName, ratioTyConName, ratioDataConName, realClassName,+    integralClassName, realFracClassName, fractionalClassName,+    fromRationalName, toIntegerName, toRationalName, fromIntegralName,+    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name+rationalTyConName   = tcQual  gHC_INTERNAL_REAL (fsLit "Rational")     rationalTyConKey+ratioTyConName      = tcQual  gHC_INTERNAL_REAL (fsLit "Ratio")        ratioTyConKey+ratioDataConName    = dcQual  gHC_INTERNAL_REAL (fsLit ":%")           ratioDataConKey+realClassName       = clsQual gHC_INTERNAL_REAL (fsLit "Real")         realClassKey+integralClassName   = clsQual gHC_INTERNAL_REAL (fsLit "Integral")     integralClassKey+realFracClassName   = clsQual gHC_INTERNAL_REAL (fsLit "RealFrac")     realFracClassKey+fractionalClassName = clsQual gHC_INTERNAL_REAL (fsLit "Fractional")   fractionalClassKey+fromRationalName    = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey+toIntegerName       = varQual gHC_INTERNAL_REAL (fsLit "toInteger")    toIntegerClassOpKey+toRationalName      = varQual gHC_INTERNAL_REAL (fsLit "toRational")   toRationalClassOpKey+fromIntegralName    = varQual  gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey+realToFracName      = varQual  gHC_INTERNAL_REAL (fsLit "realToFrac")  realToFracIdKey+mkRationalBase2Name  = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey+mkRationalBase10Name = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey++-- GHC.Internal.Float classes+floatingClassName, realFloatClassName :: Name+floatingClassName  = clsQual gHC_INTERNAL_FLOAT (fsLit "Floating")  floatingClassKey+realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatClassKey++-- other GHC.Internal.Float functions+integerToFloatName, integerToDoubleName,+  naturalToFloatName, naturalToDoubleName,+  rationalToFloatName, rationalToDoubleName :: Name+integerToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey+integerToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey+naturalToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey+naturalToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey+rationalToFloatName  = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey+rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey++-- Class Ix+ixClassName :: Name+ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey++-- Typeable representation types+trModuleTyConName+  , trModuleDataConName+  , trNameTyConName+  , trNameSDataConName+  , trNameDDataConName+  , trTyConTyConName+  , trTyConDataConName+  :: Name+trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey+trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey+trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey+trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey+trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey+trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey+trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey++kindRepTyConName+  , kindRepTyConAppDataConName+  , kindRepVarDataConName+  , kindRepAppDataConName+  , kindRepFunDataConName+  , kindRepTYPEDataConName+  , kindRepTypeLitSDataConName+  , kindRepTypeLitDDataConName+  :: Name+kindRepTyConName      = tcQual gHC_TYPES          (fsLit "KindRep")        kindRepTyConKey+kindRepTyConAppDataConName = dcQual gHC_TYPES     (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey+kindRepVarDataConName = dcQual gHC_TYPES          (fsLit "KindRepVar")     kindRepVarDataConKey+kindRepAppDataConName = dcQual gHC_TYPES          (fsLit "KindRepApp")     kindRepAppDataConKey+kindRepFunDataConName = dcQual gHC_TYPES          (fsLit "KindRepFun")     kindRepFunDataConKey+kindRepTYPEDataConName = dcQual gHC_TYPES         (fsLit "KindRepTYPE")    kindRepTYPEDataConKey+kindRepTypeLitSDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey+kindRepTypeLitDDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey++typeLitSortTyConName+  , typeLitSymbolDataConName+  , typeLitNatDataConName+  , typeLitCharDataConName+  :: Name+typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey+typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey+typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey+typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey++-- Class Typeable, and functions for constructing `Typeable` dictionaries+typeableClassName+  , typeRepTyConName+  , someTypeRepTyConName+  , someTypeRepDataConName+  , mkTrTypeName+  , mkTrConName+  , mkTrAppCheckedName+  , mkTrFunName+  , typeRepIdName+  , typeNatTypeRepName+  , typeSymbolTypeRepName+  , typeCharTypeRepName+  , trGhcPrimModuleName+  :: Name+typeableClassName     = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey+typeRepTyConName      = tcQual  gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey+someTypeRepTyConName   = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey+someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey+typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey+mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey+mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey+mkTrAppCheckedName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey+mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey+typeNatTypeRepName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey+typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+typeCharTypeRepName   = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey+-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)+-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.+trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey++-- Typeable KindReps for some common cases+starKindRepName, starArrStarKindRepName,+  starArrStarArrStarKindRepName, constraintKindRepName :: Name+starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")          starKindRepKey+starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")      starArrStarKindRepKey+starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")    starArrStarArrStarKindRepKey+constraintKindRepName  = varQual gHC_TYPES         (fsLit "krep$Constraint") constraintKindRepKey++-- WithDict+withDictClassName :: Name+withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey++nonEmptyTyConName :: Name+nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey++-- DataToTag+dataToTagClassName :: Name+dataToTagClassName    = clsQual gHC_MAGIC      (fsLit "DataToTag") dataToTagClassKey++-- seq#+seqHashName :: Name+seqHashName = varQual gHC_INTERNAL_IO (fsLit "seq#") seqHashKey++-- Custom type errors+errorMessageTypeErrorFamName+  , typeErrorTextDataConName+  , typeErrorAppendDataConName+  , typeErrorVAppendDataConName+  , typeErrorShowTypeDataConName+  :: Name++errorMessageTypeErrorFamName =+  tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey++typeErrorTextDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey++typeErrorAppendDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey++typeErrorVAppendDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey++typeErrorShowTypeDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey++-- "Unsatisfiable" constraint+unsatisfiableClassName, unsatisfiableIdName :: Name+unsatisfiableClassName =+  clsQual gHC_INTERNAL_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey+unsatisfiableIdName =+  varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey++-- Unsafe coercion proofs+unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,+  unsafeReflDataConName :: Name+unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey+unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey+unsafeReflDataConName   = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey+unsafeCoercePrimName    = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey++-- Dynamic+toDynName :: Name+toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey++-- Class Data+dataClassName :: Name+dataClassName = clsQual gHC_INTERNAL_DATA_DATA (fsLit "Data") dataClassKey++-- Error module+assertErrorName    :: Name+assertErrorName   = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey++-- GHC.Internal.Debug.Trace+traceName          :: Name+traceName         = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey++-- Enum module (Enum, Bounded)+enumClassName, enumFromName, enumFromToName, enumFromThenName,+    enumFromThenToName, boundedClassName :: Name+enumClassName      = clsQual gHC_INTERNAL_ENUM (fsLit "Enum")           enumClassKey+enumFromName       = varQual gHC_INTERNAL_ENUM (fsLit "enumFrom")       enumFromClassOpKey+enumFromToName     = varQual gHC_INTERNAL_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey+enumFromThenName   = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey+enumFromThenToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey+boundedClassName   = clsQual gHC_INTERNAL_ENUM (fsLit "Bounded")        boundedClassKey++-- List functions+concatName, filterName, zipName :: Name+concatName        = varQual gHC_INTERNAL_LIST (fsLit "concat") concatIdKey+filterName        = varQual gHC_INTERNAL_LIST (fsLit "filter") filterIdKey+zipName           = varQual gHC_INTERNAL_LIST (fsLit "zip")    zipIdKey++-- Overloaded lists+isListClassName, fromListName, fromListNName, toListName :: Name+isListClassName = clsQual gHC_INTERNAL_IS_LIST (fsLit "IsList")    isListClassKey+fromListName    = varQual gHC_INTERNAL_IS_LIST (fsLit "fromList")  fromListClassOpKey+fromListNName   = varQual gHC_INTERNAL_IS_LIST (fsLit "fromListN") fromListNClassOpKey+toListName      = varQual gHC_INTERNAL_IS_LIST (fsLit "toList")    toListClassOpKey++-- HasField class ops+getFieldName, setFieldName :: Name+getFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "getField") getFieldClassOpKey+setFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "setField") setFieldClassOpKey++-- Class Show+showClassName :: Name+showClassName   = clsQual gHC_INTERNAL_SHOW (fsLit "Show")      showClassKey++-- Class Read+readClassName :: Name+readClassName   = clsQual gHC_INTERNAL_READ (fsLit "Read")      readClassKey++-- Classes Generic and Generic1, Datatype, Constructor and Selector+genClassName, gen1ClassName, datatypeClassName, constructorClassName,+  selectorClassName :: Name+genClassName  = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic")  genClassKey+gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey++datatypeClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype")    datatypeClassKey+constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey+selectorClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector")    selectorClassKey++genericClassNames :: [Name]+genericClassNames = [genClassName, gen1ClassName]++-- GHCi things+ghciIoClassName, ghciStepIoMName :: Name+ghciIoClassName = clsQual gHC_INTERNAL_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey+ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey++-- IO things+ioTyConName, ioDataConName,+  thenIOName, bindIOName, returnIOName, failIOName :: Name+ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey+ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey+thenIOName        = varQual gHC_INTERNAL_BASE  (fsLit "thenIO")   thenIOIdKey+bindIOName        = varQual gHC_INTERNAL_BASE  (fsLit "bindIO")   bindIOIdKey+returnIOName      = varQual gHC_INTERNAL_BASE  (fsLit "returnIO") returnIOIdKey+failIOName        = varQual gHC_INTERNAL_IO    (fsLit "failIO")   failIOIdKey++-- IO things+printName :: Name+printName         = varQual gHC_INTERNAL_SYSTEM_IO (fsLit "print") printIdKey++-- Int, Word, and Addr things+int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name+int8TyConName     = tcQual gHC_INTERNAL_INT  (fsLit "Int8")  int8TyConKey+int16TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int16") int16TyConKey+int32TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int32") int32TyConKey+int64TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int64") int64TyConKey++-- Word module+word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name+word8TyConName    = tcQual  gHC_INTERNAL_WORD (fsLit "Word8")  word8TyConKey+word16TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey+word32TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey+word64TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey++-- PrelPtr module+ptrTyConName, funPtrTyConName :: Name+ptrTyConName      = tcQual   gHC_INTERNAL_PTR (fsLit "Ptr")    ptrTyConKey+funPtrTyConName   = tcQual   gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey++-- Foreign objects and weak pointers+stablePtrTyConName, newStablePtrName :: Name+stablePtrTyConName    = tcQual   gHC_INTERNAL_STABLE (fsLit "StablePtr")    stablePtrTyConKey+newStablePtrName      = varQual  gHC_INTERNAL_STABLE (fsLit "newStablePtr") newStablePtrIdKey++-- Recursive-do notation+monadFixClassName, mfixName :: Name+monadFixClassName  = clsQual gHC_INTERNAL_MONAD_FIX (fsLit "MonadFix") monadFixClassKey+mfixName           = varQual gHC_INTERNAL_MONAD_FIX (fsLit "mfix")     mfixIdKey++-- Arrow notation+arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name+arrAName           = varQual gHC_INTERNAL_ARROW (fsLit "arr")       arrAIdKey+composeAName       = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey+firstAName         = varQual gHC_INTERNAL_ARROW (fsLit "first")     firstAIdKey+appAName           = varQual gHC_INTERNAL_ARROW (fsLit "app")       appAIdKey+choiceAName        = varQual gHC_INTERNAL_ARROW (fsLit "|||")       choiceAIdKey+loopAName          = varQual gHC_INTERNAL_ARROW (fsLit "loop")      loopAIdKey++-- Monad comprehensions+guardMName, liftMName, mzipName :: Name+guardMName         = varQual gHC_INTERNAL_MONAD (fsLit "guard")    guardMIdKey+liftMName          = varQual gHC_INTERNAL_MONAD (fsLit "liftM")    liftMIdKey+mzipName           = varQual gHC_INTERNAL_CONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey+++-- Annotation type checking+toAnnotationWrapperName :: Name+toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey++-- Other classes, needed for type defaulting+monadPlusClassName, isStringClassName :: Name+monadPlusClassName  = clsQual gHC_INTERNAL_MONAD (fsLit "MonadPlus")      monadPlusClassKey+isStringClassName   = clsQual gHC_INTERNAL_DATA_STRING (fsLit "IsString") isStringClassKey++-- Type-level naturals+knownNatClassName :: Name+knownNatClassName     = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassNameKey+knownSymbolClassName :: Name+knownSymbolClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey+knownCharClassName :: Name+knownCharClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassNameKey++-- Overloaded labels+fromLabelClassOpName :: Name+fromLabelClassOpName+ = varQual gHC_INTERNAL_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey++-- Implicit Parameters+ipClassName :: Name+ipClassName+  = clsQual gHC_CLASSES (fsLit "IP") ipClassKey++-- Overloaded record fields+hasFieldClassName :: Name+hasFieldClassName+ = clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey++-- ExceptionContext+exceptionContextTyConName, emptyExceptionContextName :: Name+exceptionContextTyConName =+    tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey+emptyExceptionContextName+  = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey++-- Source Locations+callStackTyConName, emptyCallStackName, pushCallStackName,+  srcLocDataConName :: Name+callStackTyConName+  = tcQual gHC_INTERNAL_STACK_TYPES  (fsLit "CallStack") callStackTyConKey+emptyCallStackName+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey+pushCallStackName+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey+srcLocDataConName+  = dcQual gHC_INTERNAL_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey++-- plugins+pLUGINS :: Module+pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins")+pluginTyConName :: Name+pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey+frontendPluginTyConName :: Name+frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey++-- Static pointers+makeStaticName :: Name+makeStaticName =+    varQual gHC_INTERNAL_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey++staticPtrInfoTyConName :: Name+staticPtrInfoTyConName =+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey++staticPtrInfoDataConName :: Name+staticPtrInfoDataConName =+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey++staticPtrTyConName :: Name+staticPtrTyConName =+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey++staticPtrDataConName :: Name+staticPtrDataConName =+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey++fromStaticPtrName :: Name+fromStaticPtrName =+    varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey++fingerprintDataConName :: Name+fingerprintDataConName =+    dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey++constPtrConName :: Name+constPtrConName =+    tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey++jsvalTyConName :: Name+jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey++unsafeUnpackJSStringUtf8ShShName :: Name+unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey++{-+************************************************************************+*                                                                      *+\subsection{Local helpers}+*                                                                      *+************************************************************************++All these are original names; hence mkOrig+-}++{-# INLINE varQual #-}+{-# INLINE tcQual #-}+{-# INLINE clsQual #-}+{-# INLINE dcQual #-}+varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name+varQual  modu str unique = mk_known_key_name varName modu str unique+tcQual   modu str unique = mk_known_key_name tcName modu str unique+clsQual  modu str unique = mk_known_key_name clsName modu str unique+dcQual   modu str unique = mk_known_key_name dataName modu str unique++mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name+{-# INLINE mk_known_key_name #-}+mk_known_key_name space modu str unique+  = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}+*                                                                      *+************************************************************************+--MetaHaskell extension hand allocate keys here+-}++boundedClassKey, enumClassKey, eqClassKey, floatingClassKey,+    fractionalClassKey, integralClassKey, monadClassKey, dataClassKey,+    functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey,+    realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique+boundedClassKey         = mkPreludeClassUnique 1+enumClassKey            = mkPreludeClassUnique 2+eqClassKey              = mkPreludeClassUnique 3+floatingClassKey        = mkPreludeClassUnique 5+fractionalClassKey      = mkPreludeClassUnique 6+integralClassKey        = mkPreludeClassUnique 7+monadClassKey           = mkPreludeClassUnique 8+dataClassKey            = mkPreludeClassUnique 9+functorClassKey         = mkPreludeClassUnique 10+numClassKey             = mkPreludeClassUnique 11+ordClassKey             = mkPreludeClassUnique 12+readClassKey            = mkPreludeClassUnique 13+realClassKey            = mkPreludeClassUnique 14+realFloatClassKey       = mkPreludeClassUnique 15+realFracClassKey        = mkPreludeClassUnique 16+showClassKey            = mkPreludeClassUnique 17+ixClassKey              = mkPreludeClassUnique 18++typeableClassKey :: Unique+typeableClassKey        = mkPreludeClassUnique 20++withDictClassKey :: Unique+withDictClassKey        = mkPreludeClassUnique 21++dataToTagClassKey :: Unique+dataToTagClassKey       = mkPreludeClassUnique 23++monadFixClassKey :: Unique+monadFixClassKey        = mkPreludeClassUnique 28++monadFailClassKey :: Unique+monadFailClassKey       = mkPreludeClassUnique 29++monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique+monadPlusClassKey       = mkPreludeClassUnique 30+randomClassKey          = mkPreludeClassUnique 31+randomGenClassKey       = mkPreludeClassUnique 32++isStringClassKey :: Unique+isStringClassKey        = mkPreludeClassUnique 33++applicativeClassKey, foldableClassKey, traversableClassKey :: Unique+applicativeClassKey     = mkPreludeClassUnique 34+foldableClassKey        = mkPreludeClassUnique 35+traversableClassKey     = mkPreludeClassUnique 36++genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,+  selectorClassKey :: Unique+genClassKey   = mkPreludeClassUnique 37+gen1ClassKey  = mkPreludeClassUnique 38++datatypeClassKey    = mkPreludeClassUnique 39+constructorClassKey = mkPreludeClassUnique 40+selectorClassKey    = mkPreludeClassUnique 41++-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class+knownNatClassNameKey :: Unique+knownNatClassNameKey = mkPreludeClassUnique 42++-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class+knownSymbolClassNameKey :: Unique+knownSymbolClassNameKey = mkPreludeClassUnique 43++knownCharClassNameKey :: Unique+knownCharClassNameKey = mkPreludeClassUnique 44++ghciIoClassKey :: Unique+ghciIoClassKey = mkPreludeClassUnique 45++semigroupClassKey, monoidClassKey :: Unique+semigroupClassKey = mkPreludeClassUnique 47+monoidClassKey    = mkPreludeClassUnique 48++-- Implicit Parameters+ipClassKey :: Unique+ipClassKey = mkPreludeClassUnique 49++-- Overloaded record fields+hasFieldClassNameKey :: Unique+hasFieldClassNameKey = mkPreludeClassUnique 50+++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES ClassUniques 200-299+-----------------------------------------------------++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}+*                                                                      *+************************************************************************+-}++addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,+    byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,+    doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey,+    intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,+    int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey,+    int64PrimTyConKey, int64TyConKey,+    integerTyConKey, naturalTyConKey,+    listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,+    weakPrimTyConKey, mutableArrayPrimTyConKey,+    mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,+    ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,+    stablePtrTyConKey, eqTyConKey, heqTyConKey,+    smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,+    stringTyConKey,+    ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique+addrPrimTyConKey                        = mkPreludeTyConUnique  1+arrayPrimTyConKey                       = mkPreludeTyConUnique  3+boolTyConKey                            = mkPreludeTyConUnique  4+byteArrayPrimTyConKey                   = mkPreludeTyConUnique  5+stringTyConKey                          = mkPreludeTyConUnique  6+charPrimTyConKey                        = mkPreludeTyConUnique  7+charTyConKey                            = mkPreludeTyConUnique  8+doublePrimTyConKey                      = mkPreludeTyConUnique  9+doubleTyConKey                          = mkPreludeTyConUnique 10+floatPrimTyConKey                       = mkPreludeTyConUnique 11+floatTyConKey                           = mkPreludeTyConUnique 12+fUNTyConKey                             = mkPreludeTyConUnique 13+intPrimTyConKey                         = mkPreludeTyConUnique 14+intTyConKey                             = mkPreludeTyConUnique 15+int8PrimTyConKey                        = mkPreludeTyConUnique 16+int8TyConKey                            = mkPreludeTyConUnique 17+int16PrimTyConKey                       = mkPreludeTyConUnique 18+int16TyConKey                           = mkPreludeTyConUnique 19+int32PrimTyConKey                       = mkPreludeTyConUnique 20+int32TyConKey                           = mkPreludeTyConUnique 21+int64PrimTyConKey                       = mkPreludeTyConUnique 22+int64TyConKey                           = mkPreludeTyConUnique 23+integerTyConKey                         = mkPreludeTyConUnique 24+naturalTyConKey                         = mkPreludeTyConUnique 25++listTyConKey                            = mkPreludeTyConUnique 26+foreignObjPrimTyConKey                  = mkPreludeTyConUnique 27+maybeTyConKey                           = mkPreludeTyConUnique 28+weakPrimTyConKey                        = mkPreludeTyConUnique 29+mutableArrayPrimTyConKey                = mkPreludeTyConUnique 30+mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 31+orderingTyConKey                        = mkPreludeTyConUnique 32+mVarPrimTyConKey                        = mkPreludeTyConUnique 33+-- ioPortPrimTyConKey (34) was killed+ratioTyConKey                           = mkPreludeTyConUnique 35+rationalTyConKey                        = mkPreludeTyConUnique 36+realWorldTyConKey                       = mkPreludeTyConUnique 37+stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38+stablePtrTyConKey                       = mkPreludeTyConUnique 39+eqTyConKey                              = mkPreludeTyConUnique 40+heqTyConKey                             = mkPreludeTyConUnique 41++ctArrowTyConKey                       = mkPreludeTyConUnique 42+ccArrowTyConKey                       = mkPreludeTyConUnique 43+tcArrowTyConKey                       = mkPreludeTyConUnique 44++statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,+    mutVarPrimTyConKey, ioTyConKey,+    wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,+    word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey,+    word64PrimTyConKey, word64TyConKey,+    kindConKey, boxityConKey,+    typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,+    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,+    eqReprPrimTyConKey, eqPhantPrimTyConKey,+    compactPrimTyConKey, stackSnapshotPrimTyConKey,+    promptTagPrimTyConKey, constPtrTyConKey, jsvalTyConKey :: Unique+statePrimTyConKey                       = mkPreludeTyConUnique 50+stableNamePrimTyConKey                  = mkPreludeTyConUnique 51+stableNameTyConKey                      = mkPreludeTyConUnique 52+eqPrimTyConKey                          = mkPreludeTyConUnique 53+eqReprPrimTyConKey                      = mkPreludeTyConUnique 54+eqPhantPrimTyConKey                     = mkPreludeTyConUnique 55+mutVarPrimTyConKey                      = mkPreludeTyConUnique 56+ioTyConKey                              = mkPreludeTyConUnique 57+wordPrimTyConKey                        = mkPreludeTyConUnique 59+wordTyConKey                            = mkPreludeTyConUnique 60+word8PrimTyConKey                       = mkPreludeTyConUnique 61+word8TyConKey                           = mkPreludeTyConUnique 62+word16PrimTyConKey                      = mkPreludeTyConUnique 63+word16TyConKey                          = mkPreludeTyConUnique 64+word32PrimTyConKey                      = mkPreludeTyConUnique 65+word32TyConKey                          = mkPreludeTyConUnique 66+word64PrimTyConKey                      = mkPreludeTyConUnique 67+word64TyConKey                          = mkPreludeTyConUnique 68+kindConKey                              = mkPreludeTyConUnique 72+boxityConKey                            = mkPreludeTyConUnique 73+typeConKey                              = mkPreludeTyConUnique 74+threadIdPrimTyConKey                    = mkPreludeTyConUnique 75+bcoPrimTyConKey                         = mkPreludeTyConUnique 76+ptrTyConKey                             = mkPreludeTyConUnique 77+funPtrTyConKey                          = mkPreludeTyConUnique 78+tVarPrimTyConKey                        = mkPreludeTyConUnique 79+compactPrimTyConKey                     = mkPreludeTyConUnique 80+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81+promptTagPrimTyConKey                   = mkPreludeTyConUnique 82++eitherTyConKey :: Unique+eitherTyConKey                          = mkPreludeTyConUnique 84++voidTyConKey :: Unique+voidTyConKey                            = mkPreludeTyConUnique 85++nonEmptyTyConKey :: Unique+nonEmptyTyConKey                        = mkPreludeTyConUnique 86++dictTyConKey :: Unique+dictTyConKey                            = mkPreludeTyConUnique 87++-- Kind constructors+liftedTypeKindTyConKey, unliftedTypeKindTyConKey,+  tYPETyConKey, cONSTRAINTTyConKey,+  liftedRepTyConKey, unliftedRepTyConKey,+  constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,+  vecCountTyConKey, vecElemTyConKey,+  zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique+liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88+unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89+tYPETyConKey                            = mkPreludeTyConUnique 91+cONSTRAINTTyConKey                      = mkPreludeTyConUnique 92+constraintKindTyConKey                  = mkPreludeTyConUnique 93+levityTyConKey                          = mkPreludeTyConUnique 94+runtimeRepTyConKey                      = mkPreludeTyConUnique 95+vecCountTyConKey                        = mkPreludeTyConUnique 96+vecElemTyConKey                         = mkPreludeTyConUnique 97+liftedRepTyConKey                       = mkPreludeTyConUnique 98+unliftedRepTyConKey                     = mkPreludeTyConUnique 99+zeroBitRepTyConKey                         = mkPreludeTyConUnique 100+zeroBitTypeTyConKey                        = mkPreludeTyConUnique 101++pluginTyConKey, frontendPluginTyConKey :: Unique+pluginTyConKey                          = mkPreludeTyConUnique 102+frontendPluginTyConKey                  = mkPreludeTyConUnique 103++trTyConTyConKey, trModuleTyConKey, trNameTyConKey,+  kindRepTyConKey, typeLitSortTyConKey :: Unique+trTyConTyConKey                         = mkPreludeTyConUnique 104+trModuleTyConKey                        = mkPreludeTyConUnique 105+trNameTyConKey                          = mkPreludeTyConUnique 106+kindRepTyConKey                         = mkPreludeTyConUnique 107+typeLitSortTyConKey                     = mkPreludeTyConUnique 108++-- Generics (Unique keys)+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,+  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,+  compTyConKey, rTyConKey, dTyConKey,+  cTyConKey, sTyConKey, rec0TyConKey,+  d1TyConKey, c1TyConKey, s1TyConKey,+  repTyConKey, rep1TyConKey, uRecTyConKey,+  uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,+  uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique++v1TyConKey    = mkPreludeTyConUnique 135+u1TyConKey    = mkPreludeTyConUnique 136+par1TyConKey  = mkPreludeTyConUnique 137+rec1TyConKey  = mkPreludeTyConUnique 138+k1TyConKey    = mkPreludeTyConUnique 139+m1TyConKey    = mkPreludeTyConUnique 140++sumTyConKey   = mkPreludeTyConUnique 141+prodTyConKey  = mkPreludeTyConUnique 142+compTyConKey  = mkPreludeTyConUnique 143++rTyConKey = mkPreludeTyConUnique 144+dTyConKey = mkPreludeTyConUnique 146+cTyConKey = mkPreludeTyConUnique 147+sTyConKey = mkPreludeTyConUnique 148++rec0TyConKey  = mkPreludeTyConUnique 149+d1TyConKey    = mkPreludeTyConUnique 151+c1TyConKey    = mkPreludeTyConUnique 152+s1TyConKey    = mkPreludeTyConUnique 153++repTyConKey  = mkPreludeTyConUnique 155+rep1TyConKey = mkPreludeTyConUnique 156++uRecTyConKey    = mkPreludeTyConUnique 157+uAddrTyConKey   = mkPreludeTyConUnique 158+uCharTyConKey   = mkPreludeTyConUnique 159+uDoubleTyConKey = mkPreludeTyConUnique 160+uFloatTyConKey  = mkPreludeTyConUnique 161+uIntTyConKey    = mkPreludeTyConUnique 162+uWordTyConKey   = mkPreludeTyConUnique 163++-- "Unsatisfiable" constraint+unsatisfiableClassNameKey :: Unique+unsatisfiableClassNameKey = mkPreludeTyConUnique 170++anyTyConKey :: Unique+anyTyConKey = mkPreludeTyConUnique 171++zonkAnyTyConKey :: Unique+zonkAnyTyConKey = mkPreludeTyConUnique 172++-- Custom user type-errors+errorMessageTypeErrorFamKey :: Unique+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181++coercibleTyConKey :: Unique+coercibleTyConKey = mkPreludeTyConUnique 183++proxyPrimTyConKey :: Unique+proxyPrimTyConKey = mkPreludeTyConUnique 184++specTyConKey :: Unique+specTyConKey = mkPreludeTyConUnique 185++smallArrayPrimTyConKey        = mkPreludeTyConUnique  187+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  188++staticPtrTyConKey  :: Unique+staticPtrTyConKey  = mkPreludeTyConUnique 189++staticPtrInfoTyConKey :: Unique+staticPtrInfoTyConKey = mkPreludeTyConUnique 190++callStackTyConKey :: Unique+callStackTyConKey = mkPreludeTyConUnique 191++-- Typeables+typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique+typeRepTyConKey       = mkPreludeTyConUnique 192+someTypeRepTyConKey   = mkPreludeTyConUnique 193+someTypeRepDataConKey = mkPreludeTyConUnique 194+++typeSymbolAppendFamNameKey :: Unique+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195++-- Unsafe equality+unsafeEqualityTyConKey :: Unique+unsafeEqualityTyConKey = mkPreludeTyConUnique 196++-- Linear types+multiplicityTyConKey :: Unique+multiplicityTyConKey = mkPreludeTyConUnique 197++unrestrictedFunTyConKey :: Unique+unrestrictedFunTyConKey = mkPreludeTyConUnique 198++multMulTyConKey :: Unique+multMulTyConKey = mkPreludeTyConUnique 199++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES TyConUniques 200-299+-----------------------------------------------------++----------------------- SIMD ------------------------+--      USES TyConUniques 300-399+-----------------------------------------------------++#include "primop-vector-uniques.hs-incl"++------------- Type-level Symbol, Nat, Char ----------+--      USES TyConUniques 400-499+-----------------------------------------------------+typeSymbolKindConNameKey, typeCharKindConNameKey,+  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,+  typeNatSubTyFamNameKey+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey+  , typeLeqCharTyFamNameKey+  , typeNatDivTyFamNameKey+  , typeNatModTyFamNameKey+  , typeNatLogTyFamNameKey+  , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey+  , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey+  , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey+  :: Unique+typeSymbolKindConNameKey  = mkPreludeTyConUnique 400+typeCharKindConNameKey    = mkPreludeTyConUnique 401+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 402+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 403+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 404+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 405+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 407+typeCharCmpTyFamNameKey   = mkPreludeTyConUnique 408+typeLeqCharTyFamNameKey   = mkPreludeTyConUnique 409+typeNatDivTyFamNameKey  = mkPreludeTyConUnique 410+typeNatModTyFamNameKey  = mkPreludeTyConUnique 411+typeNatLogTyFamNameKey  = mkPreludeTyConUnique 412+typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413+typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414+typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415+typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416+constPtrTyConKey = mkPreludeTyConUnique 417++jsvalTyConKey = mkPreludeTyConUnique 418++exceptionContextTyConKey = mkPreludeTyConUnique 420++unsafeUnpackJSStringUtf8ShShKey  = mkPreludeMiscIdUnique 805++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}+*                                                                      *+************************************************************************+-}++charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,+    floatDataConKey, intDataConKey, nilDataConKey,+    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,+    word8DataConKey, ioDataConKey, heqDataConKey,+    eqDataConKey, nothingDataConKey, justDataConKey :: Unique++charDataConKey                          = mkPreludeDataConUnique  1+consDataConKey                          = mkPreludeDataConUnique  2+doubleDataConKey                        = mkPreludeDataConUnique  3+falseDataConKey                         = mkPreludeDataConUnique  4+floatDataConKey                         = mkPreludeDataConUnique  5+intDataConKey                           = mkPreludeDataConUnique  6+nothingDataConKey                       = mkPreludeDataConUnique  7+justDataConKey                          = mkPreludeDataConUnique  8+eqDataConKey                            = mkPreludeDataConUnique  9+nilDataConKey                           = mkPreludeDataConUnique 10+ratioDataConKey                         = mkPreludeDataConUnique 11+word8DataConKey                         = mkPreludeDataConUnique 12+stableNameDataConKey                    = mkPreludeDataConUnique 13+trueDataConKey                          = mkPreludeDataConUnique 14+wordDataConKey                          = mkPreludeDataConUnique 15+ioDataConKey                            = mkPreludeDataConUnique 16+heqDataConKey                           = mkPreludeDataConUnique 18++-- Generic data constructors+crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique+crossDataConKey                         = mkPreludeDataConUnique 20+inlDataConKey                           = mkPreludeDataConUnique 21+inrDataConKey                           = mkPreludeDataConUnique 22+genUnitDataConKey                       = mkPreludeDataConUnique 23++leftDataConKey, rightDataConKey :: Unique+leftDataConKey                          = mkPreludeDataConUnique 25+rightDataConKey                         = mkPreludeDataConUnique 26++ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique+ordLTDataConKey                         = mkPreludeDataConUnique 27+ordEQDataConKey                         = mkPreludeDataConUnique 28+ordGTDataConKey                         = mkPreludeDataConUnique 29++mkDictDataConKey :: Unique+mkDictDataConKey                        = mkPreludeDataConUnique 30++coercibleDataConKey :: Unique+coercibleDataConKey                     = mkPreludeDataConUnique 32++staticPtrDataConKey :: Unique+staticPtrDataConKey                     = mkPreludeDataConUnique 33++staticPtrInfoDataConKey :: Unique+staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34++fingerprintDataConKey :: Unique+fingerprintDataConKey                   = mkPreludeDataConUnique 35++srcLocDataConKey :: Unique+srcLocDataConKey                        = mkPreludeDataConUnique 37++trTyConDataConKey, trModuleDataConKey,+  trNameSDataConKey, trNameDDataConKey,+  trGhcPrimModuleKey :: Unique+trTyConDataConKey                       = mkPreludeDataConUnique 41+trModuleDataConKey                      = mkPreludeDataConUnique 43+trNameSDataConKey                       = mkPreludeDataConUnique 45+trNameDDataConKey                       = mkPreludeDataConUnique 46+trGhcPrimModuleKey                      = mkPreludeDataConUnique 47++typeErrorTextDataConKey,+  typeErrorAppendDataConKey,+  typeErrorVAppendDataConKey,+  typeErrorShowTypeDataConKey+  :: Unique+typeErrorTextDataConKey                 = mkPreludeDataConUnique 50+typeErrorAppendDataConKey               = mkPreludeDataConUnique 51+typeErrorVAppendDataConKey              = mkPreludeDataConUnique 52+typeErrorShowTypeDataConKey             = mkPreludeDataConUnique 53++prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,+    rightAssociativeDataConKey, notAssociativeDataConKey,+    sourceUnpackDataConKey, sourceNoUnpackDataConKey,+    noSourceUnpackednessDataConKey, sourceLazyDataConKey,+    sourceStrictDataConKey, noSourceStrictnessDataConKey,+    decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey,+    metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique+prefixIDataConKey                       = mkPreludeDataConUnique 54+infixIDataConKey                        = mkPreludeDataConUnique 55+leftAssociativeDataConKey               = mkPreludeDataConUnique 56+rightAssociativeDataConKey              = mkPreludeDataConUnique 57+notAssociativeDataConKey                = mkPreludeDataConUnique 58+sourceUnpackDataConKey                  = mkPreludeDataConUnique 59+sourceNoUnpackDataConKey                = mkPreludeDataConUnique 60+noSourceUnpackednessDataConKey          = mkPreludeDataConUnique 61+sourceLazyDataConKey                    = mkPreludeDataConUnique 62+sourceStrictDataConKey                  = mkPreludeDataConUnique 63+noSourceStrictnessDataConKey            = mkPreludeDataConUnique 64+decidedLazyDataConKey                   = mkPreludeDataConUnique 65+decidedStrictDataConKey                 = mkPreludeDataConUnique 66+decidedUnpackDataConKey                 = mkPreludeDataConUnique 67+metaDataDataConKey                      = mkPreludeDataConUnique 68+metaConsDataConKey                      = mkPreludeDataConUnique 69+metaSelDataConKey                       = mkPreludeDataConUnique 70++vecRepDataConKey, sumRepDataConKey,+  tupleRepDataConKey, boxedRepDataConKey :: Unique+vecRepDataConKey                        = mkPreludeDataConUnique 71+tupleRepDataConKey                      = mkPreludeDataConUnique 72+sumRepDataConKey                        = mkPreludeDataConUnique 73+boxedRepDataConKey                      = mkPreludeDataConUnique 74++boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique+-- A promoted data constructors (i.e. a TyCon) has+-- the same key as the data constructor itself+boxedRepDataConTyConKey = boxedRepDataConKey+tupleRepDataConTyConKey = tupleRepDataConKey++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- Includes all nullary-data-constructor reps. Does not+-- include BoxedRep, VecRep, SumRep, TupleRep.+runtimeRepSimpleDataConKeys :: [Unique]+runtimeRepSimpleDataConKeys+  = map mkPreludeDataConUnique [75..87]++liftedDataConKey,unliftedDataConKey :: Unique+liftedDataConKey = mkPreludeDataConUnique 88+unliftedDataConKey = mkPreludeDataConUnique 89++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- VecCount+vecCountDataConKeys :: [Unique]+vecCountDataConKeys = map mkPreludeDataConUnique [90..95]++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- VecElem+vecElemDataConKeys :: [Unique]+vecElemDataConKeys = map mkPreludeDataConUnique [96..105]++-- Typeable things+kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,+    kindRepFunDataConKey, kindRepTYPEDataConKey,+    kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey+    :: Unique+kindRepTyConAppDataConKey = mkPreludeDataConUnique 106+kindRepVarDataConKey      = mkPreludeDataConUnique 107+kindRepAppDataConKey      = mkPreludeDataConUnique 108+kindRepFunDataConKey      = mkPreludeDataConUnique 109+kindRepTYPEDataConKey     = mkPreludeDataConUnique 110+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112++typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique+typeLitSymbolDataConKey   = mkPreludeDataConUnique 113+typeLitNatDataConKey      = mkPreludeDataConUnique 114+typeLitCharDataConKey     = mkPreludeDataConUnique 115++-- Unsafe equality+unsafeReflDataConKey :: Unique+unsafeReflDataConKey      = mkPreludeDataConUnique 116++-- Multiplicity++oneDataConKey, manyDataConKey :: Unique+oneDataConKey = mkPreludeDataConUnique 117+manyDataConKey = mkPreludeDataConUnique 118++-- ghc-bignum+integerISDataConKey, integerINDataConKey, integerIPDataConKey,+   naturalNSDataConKey, naturalNBDataConKey :: Unique+integerISDataConKey       = mkPreludeDataConUnique 120+integerINDataConKey       = mkPreludeDataConUnique 121+integerIPDataConKey       = mkPreludeDataConUnique 122+naturalNSDataConKey       = mkPreludeDataConUnique 123+naturalNBDataConKey       = mkPreludeDataConUnique 124+++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES DataUniques 200-250+-----------------------------------------------------+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}+*                                                                      *+************************************************************************+-}++wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey,+    buildIdKey, foldrIdKey, recSelErrorIdKey,+    seqIdKey, eqStringIdKey,+    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,+    impossibleErrorIdKey, impossibleConstraintErrorIdKey,+    patErrorIdKey, voidPrimIdKey,+    realWorldPrimIdKey, recConErrorIdKey,+    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,+    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,+    typeErrorIdKey, divIntIdKey, modIntIdKey,+    absentSumFieldErrorIdKey, cstringLengthIdKey+    :: Unique++wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]+absentErrorIdKey               = mkPreludeMiscIdUnique  1+absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2+augmentIdKey                   = mkPreludeMiscIdUnique  3+appendIdKey                    = mkPreludeMiscIdUnique  4+buildIdKey                     = mkPreludeMiscIdUnique  5+foldrIdKey                     = mkPreludeMiscIdUnique  6+recSelErrorIdKey               = mkPreludeMiscIdUnique  7+seqIdKey                       = mkPreludeMiscIdUnique  8+absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9+eqStringIdKey                  = mkPreludeMiscIdUnique 10+noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11+nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12+impossibleErrorIdKey           = mkPreludeMiscIdUnique 13+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14+patErrorIdKey                  = mkPreludeMiscIdUnique 15+realWorldPrimIdKey             = mkPreludeMiscIdUnique 16+recConErrorIdKey               = mkPreludeMiscIdUnique 17++unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20++unpackCStringIdKey            = mkPreludeMiscIdUnique 21+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23++voidPrimIdKey                 = mkPreludeMiscIdUnique 24+typeErrorIdKey                = mkPreludeMiscIdUnique 25+divIntIdKey                   = mkPreludeMiscIdUnique 26+modIntIdKey                   = mkPreludeMiscIdUnique 27+cstringLengthIdKey            = mkPreludeMiscIdUnique 28++concatIdKey, filterIdKey, zipIdKey,+    bindIOIdKey, returnIOIdKey, newStablePtrIdKey,+    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,+    otherwiseIdKey, assertIdKey :: Unique+concatIdKey                   = mkPreludeMiscIdUnique 31+filterIdKey                   = mkPreludeMiscIdUnique 32+zipIdKey                      = mkPreludeMiscIdUnique 33+bindIOIdKey                   = mkPreludeMiscIdUnique 34+returnIOIdKey                 = mkPreludeMiscIdUnique 35+newStablePtrIdKey             = mkPreludeMiscIdUnique 36+printIdKey                    = mkPreludeMiscIdUnique 37+failIOIdKey                   = mkPreludeMiscIdUnique 38+nullAddrIdKey                 = mkPreludeMiscIdUnique 39+voidArgIdKey                  = mkPreludeMiscIdUnique 40+otherwiseIdKey                = mkPreludeMiscIdUnique 43+assertIdKey                   = mkPreludeMiscIdUnique 44++leftSectionKey, rightSectionKey :: Unique+leftSectionKey                = mkPreludeMiscIdUnique 45+rightSectionKey               = mkPreludeMiscIdUnique 46++rootMainKey, runMainKey :: Unique+rootMainKey                   = mkPreludeMiscIdUnique 101+runMainKey                    = mkPreludeMiscIdUnique 102++thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: Unique+thenIOIdKey                   = mkPreludeMiscIdUnique 103+lazyIdKey                     = mkPreludeMiscIdUnique 104+assertErrorIdKey              = mkPreludeMiscIdUnique 105+oneShotKey                    = mkPreludeMiscIdUnique 106+runRWKey                      = mkPreludeMiscIdUnique 107++traceKey :: Unique+traceKey                      = mkPreludeMiscIdUnique 108++nospecIdKey :: Unique+nospecIdKey                   = mkPreludeMiscIdUnique 109++inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique+inlineIdKey                   = mkPreludeMiscIdUnique 120+-- see below++mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique+mapIdKey                = mkPreludeMiscIdUnique 121+dollarIdKey             = mkPreludeMiscIdUnique 123+coercionTokenIdKey      = mkPreludeMiscIdUnique 124+considerAccessibleIdKey = mkPreludeMiscIdUnique 125+noinlineIdKey           = mkPreludeMiscIdUnique 126+noinlineConstraintIdKey = mkPreludeMiscIdUnique 127++integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique+integerToFloatIdKey    = mkPreludeMiscIdUnique 128+integerToDoubleIdKey   = mkPreludeMiscIdUnique 129+naturalToFloatIdKey    = mkPreludeMiscIdUnique 130+naturalToDoubleIdKey   = mkPreludeMiscIdUnique 131++rationalToFloatIdKey, rationalToDoubleIdKey :: Unique+rationalToFloatIdKey   = mkPreludeMiscIdUnique 132+rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133++seqHashKey             = mkPreludeMiscIdUnique 134++coerceKey :: Unique+coerceKey                     = mkPreludeMiscIdUnique 157++{-+Certain class operations from Prelude classes.  They get their own+uniques so we can look them up easily when we want to conjure them up+during type checking.+-}++-- Just a placeholder for unbound variables produced by the renamer:+unboundKey :: Unique+unboundKey                    = mkPreludeMiscIdUnique 158++fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,+    enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,+    enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,+    bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey+    :: Unique+fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160+minusClassOpKey               = mkPreludeMiscIdUnique 161+fromRationalClassOpKey        = mkPreludeMiscIdUnique 162+enumFromClassOpKey            = mkPreludeMiscIdUnique 163+enumFromThenClassOpKey        = mkPreludeMiscIdUnique 164+enumFromToClassOpKey          = mkPreludeMiscIdUnique 165+enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166+eqClassOpKey                  = mkPreludeMiscIdUnique 167+geClassOpKey                  = mkPreludeMiscIdUnique 168+negateClassOpKey              = mkPreludeMiscIdUnique 169+bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)+thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)+fmapClassOpKey                = mkPreludeMiscIdUnique 173+returnMClassOpKey             = mkPreludeMiscIdUnique 174++-- Recursive do notation+mfixIdKey :: Unique+mfixIdKey       = mkPreludeMiscIdUnique 175++-- MonadFail operations+failMClassOpKey :: Unique+failMClassOpKey = mkPreludeMiscIdUnique 176++-- fromLabel+fromLabelClassOpKey :: Unique+fromLabelClassOpKey = mkPreludeMiscIdUnique 177++-- Arrow notation+arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,+    loopAIdKey :: Unique+arrAIdKey       = mkPreludeMiscIdUnique 180+composeAIdKey   = mkPreludeMiscIdUnique 181 -- >>>+firstAIdKey     = mkPreludeMiscIdUnique 182+appAIdKey       = mkPreludeMiscIdUnique 183+choiceAIdKey    = mkPreludeMiscIdUnique 184 --  |||+loopAIdKey      = mkPreludeMiscIdUnique 185++fromStringClassOpKey :: Unique+fromStringClassOpKey          = mkPreludeMiscIdUnique 186++-- Annotation type checking+toAnnotationWrapperIdKey :: Unique+toAnnotationWrapperIdKey      = mkPreludeMiscIdUnique 187++-- Conversion functions+fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique+fromIntegralIdKey    = mkPreludeMiscIdUnique 190+realToFracIdKey      = mkPreludeMiscIdUnique 191+toIntegerClassOpKey  = mkPreludeMiscIdUnique 192+toRationalClassOpKey = mkPreludeMiscIdUnique 193++-- Monad comprehensions+guardMIdKey, liftMIdKey, mzipIdKey :: Unique+guardMIdKey     = mkPreludeMiscIdUnique 194+liftMIdKey      = mkPreludeMiscIdUnique 195+mzipIdKey       = mkPreludeMiscIdUnique 196++-- GHCi+ghciStepIoMClassOpKey :: Unique+ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197++-- Overloaded lists+isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique+isListClassKey = mkPreludeMiscIdUnique 198+fromListClassOpKey = mkPreludeMiscIdUnique 199+fromListNClassOpKey = mkPreludeMiscIdUnique 500+toListClassOpKey = mkPreludeMiscIdUnique 501++proxyHashKey :: Unique+proxyHashKey = mkPreludeMiscIdUnique 502++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES IdUniques 200-499+-----------------------------------------------------++-- Used to make `Typeable` dictionaries+mkTyConKey+  , mkTrTypeKey+  , mkTrConKey+  , mkTrAppCheckedKey+  , mkTrFunKey+  , typeNatTypeRepKey+  , typeSymbolTypeRepKey+  , typeCharTypeRepKey+  , typeRepIdKey+  :: Unique+mkTyConKey            = mkPreludeMiscIdUnique 503+mkTrTypeKey           = mkPreludeMiscIdUnique 504+mkTrConKey            = mkPreludeMiscIdUnique 505+mkTrAppCheckedKey     = mkPreludeMiscIdUnique 506+typeNatTypeRepKey     = mkPreludeMiscIdUnique 507+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508+typeCharTypeRepKey    = mkPreludeMiscIdUnique 509+typeRepIdKey          = mkPreludeMiscIdUnique 510+mkTrFunKey            = mkPreludeMiscIdUnique 511++-- KindReps for common cases+starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique+starKindRepKey               = mkPreludeMiscIdUnique 520+starArrStarKindRepKey        = mkPreludeMiscIdUnique 521+starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522+constraintKindRepKey         = mkPreludeMiscIdUnique 523++-- Dynamic+toDynIdKey :: Unique+toDynIdKey            = mkPreludeMiscIdUnique 530+++heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique+eqSCSelIdKey        = mkPreludeMiscIdUnique 551+heqSCSelIdKey       = mkPreludeMiscIdUnique 552+coercibleSCSelIdKey = mkPreludeMiscIdUnique 553++sappendClassOpKey :: Unique+sappendClassOpKey = mkPreludeMiscIdUnique 554++memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique+memptyClassOpKey  = mkPreludeMiscIdUnique 555+mappendClassOpKey = mkPreludeMiscIdUnique 556+mconcatClassOpKey = mkPreludeMiscIdUnique 557++emptyCallStackKey, pushCallStackKey :: Unique+emptyCallStackKey = mkPreludeMiscIdUnique 558+pushCallStackKey  = mkPreludeMiscIdUnique 559++fromStaticPtrClassOpKey :: Unique+fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560++makeStaticKey :: Unique+makeStaticKey = mkPreludeMiscIdUnique 561++emptyExceptionContextKey :: Unique+emptyExceptionContextKey = mkPreludeMiscIdUnique 562++-- Unsafe coercion proofs+unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique+unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570+unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571++-- HasField class ops+getFieldClassOpKey, setFieldClassOpKey :: Unique+getFieldClassOpKey = mkPreludeMiscIdUnique 572+setFieldClassOpKey = mkPreludeMiscIdUnique 573++-- "Unsatisfiable" constraints+unsatisfiableIdNameKey :: Unique+unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580++------------------------------------------------------+-- ghc-bignum uses 600-699 uniques+------------------------------------------------------++integerFromNaturalIdKey+   , integerToNaturalClampIdKey+   , integerToNaturalThrowIdKey+   , integerToNaturalIdKey+   , integerToWordIdKey+   , integerToIntIdKey+   , integerToWord64IdKey+   , integerToInt64IdKey+   , integerAddIdKey+   , integerMulIdKey+   , integerSubIdKey+   , integerNegateIdKey+   , integerAbsIdKey+   , integerPopCountIdKey+   , integerQuotIdKey+   , integerRemIdKey+   , integerDivIdKey+   , integerModIdKey+   , integerDivModIdKey+   , integerQuotRemIdKey+   , integerEncodeFloatIdKey+   , integerEncodeDoubleIdKey+   , integerGcdIdKey+   , integerLcmIdKey+   , integerAndIdKey+   , integerOrIdKey+   , integerXorIdKey+   , integerComplementIdKey+   , integerBitIdKey+   , integerTestBitIdKey+   , integerShiftLIdKey+   , integerShiftRIdKey+   , integerFromWordIdKey+   , integerFromWord64IdKey+   , integerFromInt64IdKey+   , naturalToWordIdKey+   , naturalPopCountIdKey+   , naturalShiftRIdKey+   , naturalShiftLIdKey+   , naturalAddIdKey+   , naturalSubIdKey+   , naturalSubThrowIdKey+   , naturalSubUnsafeIdKey+   , naturalMulIdKey+   , naturalQuotRemIdKey+   , naturalQuotIdKey+   , naturalRemIdKey+   , naturalAndIdKey+   , naturalAndNotIdKey+   , naturalOrIdKey+   , naturalXorIdKey+   , naturalTestBitIdKey+   , naturalBitIdKey+   , naturalGcdIdKey+   , naturalLcmIdKey+   , naturalLog2IdKey+   , naturalLogBaseWordIdKey+   , naturalLogBaseIdKey+   , naturalPowModIdKey+   , naturalSizeInBaseIdKey+   , bignatEqIdKey+   , bignatCompareIdKey+   , bignatCompareWordIdKey+   :: Unique++integerFromNaturalIdKey    = mkPreludeMiscIdUnique 600+integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601+integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602+integerToNaturalIdKey      = mkPreludeMiscIdUnique 603+integerToWordIdKey         = mkPreludeMiscIdUnique 604+integerToIntIdKey          = mkPreludeMiscIdUnique 605+integerToWord64IdKey       = mkPreludeMiscIdUnique 606+integerToInt64IdKey        = mkPreludeMiscIdUnique 607+integerAddIdKey            = mkPreludeMiscIdUnique 608+integerMulIdKey            = mkPreludeMiscIdUnique 609+integerSubIdKey            = mkPreludeMiscIdUnique 610+integerNegateIdKey         = mkPreludeMiscIdUnique 611+integerAbsIdKey            = mkPreludeMiscIdUnique 618+integerPopCountIdKey       = mkPreludeMiscIdUnique 621+integerQuotIdKey           = mkPreludeMiscIdUnique 622+integerRemIdKey            = mkPreludeMiscIdUnique 623+integerDivIdKey            = mkPreludeMiscIdUnique 624+integerModIdKey            = mkPreludeMiscIdUnique 625+integerDivModIdKey         = mkPreludeMiscIdUnique 626+integerQuotRemIdKey        = mkPreludeMiscIdUnique 627+integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 630+integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 631+integerGcdIdKey            = mkPreludeMiscIdUnique 632+integerLcmIdKey            = mkPreludeMiscIdUnique 633+integerAndIdKey            = mkPreludeMiscIdUnique 634+integerOrIdKey             = mkPreludeMiscIdUnique 635+integerXorIdKey            = mkPreludeMiscIdUnique 636+integerComplementIdKey     = mkPreludeMiscIdUnique 637+integerBitIdKey            = mkPreludeMiscIdUnique 638+integerTestBitIdKey        = mkPreludeMiscIdUnique 639+integerShiftLIdKey         = mkPreludeMiscIdUnique 640+integerShiftRIdKey         = mkPreludeMiscIdUnique 641+integerFromWordIdKey       = mkPreludeMiscIdUnique 642+integerFromWord64IdKey     = mkPreludeMiscIdUnique 643+integerFromInt64IdKey      = mkPreludeMiscIdUnique 644++naturalToWordIdKey         = mkPreludeMiscIdUnique 650+naturalPopCountIdKey       = mkPreludeMiscIdUnique 659+naturalShiftRIdKey         = mkPreludeMiscIdUnique 660+naturalShiftLIdKey         = mkPreludeMiscIdUnique 661+naturalAddIdKey            = mkPreludeMiscIdUnique 662+naturalSubIdKey            = mkPreludeMiscIdUnique 663+naturalSubThrowIdKey       = mkPreludeMiscIdUnique 664+naturalSubUnsafeIdKey      = mkPreludeMiscIdUnique 665+naturalMulIdKey            = mkPreludeMiscIdUnique 666+naturalQuotRemIdKey        = mkPreludeMiscIdUnique 669+naturalQuotIdKey           = mkPreludeMiscIdUnique 670+naturalRemIdKey            = mkPreludeMiscIdUnique 671+naturalAndIdKey            = mkPreludeMiscIdUnique 672+naturalAndNotIdKey         = mkPreludeMiscIdUnique 673+naturalOrIdKey             = mkPreludeMiscIdUnique 674+naturalXorIdKey            = mkPreludeMiscIdUnique 675+naturalTestBitIdKey        = mkPreludeMiscIdUnique 676+naturalBitIdKey            = mkPreludeMiscIdUnique 677+naturalGcdIdKey            = mkPreludeMiscIdUnique 678+naturalLcmIdKey            = mkPreludeMiscIdUnique 679+naturalLog2IdKey           = mkPreludeMiscIdUnique 680+naturalLogBaseWordIdKey    = mkPreludeMiscIdUnique 681+naturalLogBaseIdKey        = mkPreludeMiscIdUnique 682+naturalPowModIdKey         = mkPreludeMiscIdUnique 683+naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684++bignatEqIdKey              = mkPreludeMiscIdUnique 691+bignatCompareIdKey         = mkPreludeMiscIdUnique 692+bignatCompareWordIdKey     = mkPreludeMiscIdUnique 693+++------------------------------------------------------+-- ghci optimization for big rationals 700-749 uniques+------------------------------------------------------++-- Creating rationals at runtime.+mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique+mkRationalBase2IdKey  = mkPreludeMiscIdUnique 700+mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique++{-+************************************************************************+*                                                                      *+\subsection[Class-std-groups]{Standard groups of Prelude classes}+*                                                                      *+************************************************************************++NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@+even though every numeric class has these two as a superclass,+because the list of ambiguous dictionaries hasn't been simplified.+-}++numericClassKeys :: [Unique]+numericClassKeys =+        [ numClassKey+        , realClassKey+        , integralClassKey+        ]+        ++ fractionalClassKeys++fractionalClassKeys :: [Unique]+fractionalClassKeys =+        [ fractionalClassKey+        , floatingClassKey+        , realFracClassKey+        , realFloatClassKey+        ]++-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4),+-- and are: "classes defined in the Prelude or a standard library"+standardClassKeys :: [Unique]+standardClassKeys = derivableClassKeys ++ numericClassKeys+                  ++ [randomClassKey, randomGenClassKey,+                      functorClassKey,+                      monadClassKey, monadPlusClassKey, monadFailClassKey,+                      semigroupClassKey, monoidClassKey,+                      isStringClassKey,+                      applicativeClassKey, foldableClassKey,+                      traversableClassKey, alternativeClassKey+                     ]++{-+@derivableClassKeys@ is also used in checking \tr{deriving} constructs+(@GHC.Tc.Deriv@).+-}++derivableClassKeys :: [Unique]+derivableClassKeys+  = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,+      boundedClassKey, showClassKey, readClassKey ]+++-- These are the "interactive classes" that are consulted when doing+-- defaulting. Does not include Num or IsString, which have special+-- handling.+interactiveClassNames :: [Name]+interactiveClassNames+  = [ showClassName, eqClassName, ordClassName, foldableClassName+    , traversableClassName ]++interactiveClassKeys :: [Unique]+interactiveClassKeys = map getUnique interactiveClassNames
+ 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.hs view
@@ -17,10 +17,12 @@         tagToEnumKey,          primOpOutOfLine, primOpCodeSize,-        primOpOkForSpeculation, primOpOkForSideEffects,-        primOpIsCheap, primOpFixity, primOpDocs,+        primOpOkForSpeculation, primOpOkToDiscard,+        primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs, primOpDeprecations,         primOpIsDiv, primOpIsReallyInline, +        PrimOpEffect(..), primOpEffect,+         getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),          PrimCall(..)@@ -33,7 +35,7 @@ import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) -import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )+import GHC.Core.TyCon    ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) ) import GHC.Core.Type  import GHC.Cmm.Type@@ -42,17 +44,17 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name-import GHC.Types.RepType ( tyConPrimRep1 )+import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc  ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString )-import GHC.Types.SourceText  ( SourceText(..) )-import GHC.Types.Unique  ( Unique)+import GHC.Types.Unique  ( Unique )  import GHC.Unit.Types    ( Unit )  import GHC.Utils.Outputable+import GHC.Utils.Panic  import GHC.Data.FastString @@ -160,12 +162,15 @@ *                                                                      * ************************************************************************ -See Note [GHC.Prim Docs]+See Note [GHC.Prim Docs] in GHC.Builtin.Utils -} -primOpDocs :: [(String, String)]+primOpDocs :: [(FastString, String)] #include "primop-docs.hs-incl" +primOpDeprecations :: [(OccName, FastString)]+#include "primop-deprecations.hs-incl"+ {- ************************************************************************ *                                                                      *@@ -311,221 +316,316 @@ *                                                                      * ************************************************************************ -Note [Checking versus non-checking primops]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -  In GHC primops break down into two classes:+Note [Exceptions: asynchronous, synchronous, and unchecked]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are three very different sorts of things in GHC-Haskell that are+sometimes called exceptions: -   a. Checking primops behave, for instance, like division. In this-      case the primop may throw an exception (e.g. division-by-zero)-      and is consequently is marked with the can_fail flag described below.-      The ability to fail comes at the expense of precluding some optimizations.+* Haskell exceptions: -   b. Non-checking primops behavior, for instance, like addition. While-      addition can overflow it does not produce an exception. So can_fail is-      set to False, and we get more optimisation opportunities.  But we must-      never throw an exception, so we cannot rewrite to a call to error.+  These are ordinary exceptions that users can raise with the likes+  of 'throw' and handle with the likes of 'catch'.  They come in two+  very different flavors: -  It is important that a non-checking primop never be transformed in a way that-  would cause it to bottom. Doing so would violate Core's let-can-float invariant-  (see Note [Core let-can-float invariant] in GHC.Core) which is critical to-  the simplifier's ability to float without fear of changing program meaning.+  * Asynchronous exceptions:+    * These can arise at nearly any time, and may have nothing to do+      with the code being executed.+    * The compiler itself mostly doesn't need to care about them.+    * Examples: a signal from another process, running out of heap or stack+    * Even pure code can receive asynchronous exceptions; in this+      case, executing the same code again may lead to different+      results, because the exception may not happen next time.+    * See rts/RaiseAsync.c for the gory details of how they work. +  * Synchronous exceptions:+    * These are produced by the code being executed, most commonly via+      a call to the `raise#` or `raiseIO#` primops.+    * At run-time, if a piece of pure code raises a synchronous+      exception, it will always raise the same synchronous exception+      if it is run again (and not interrupted by an asynchronous+      exception).+    * In particular, if an updatable thunk does some work and then+      raises a synchronous exception, it is safe to overwrite it with+      a thunk that /immediately/ raises the same exception.+    * Although we are careful not to discard synchronous exceptions, we+      are very liberal about re-ordering them with respect to most other+      operations.  See the paper "A semantics for imprecise exceptions"+      as well as Note [Precise exceptions and strictness analysis] in+      GHC.Types.Demand. -Note [PrimOp can_fail and has_side_effects]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both can_fail and has_side_effects mean that the primop has-some effect that is not captured entirely by its result value.+* Unchecked exceptions: -----------  has_side_effects ----------------------A primop "has_side_effects" if it has some side effect, visible-elsewhere, apart from the result it returns-    - reading or writing to the world (I/O)-    - reading or writing to a mutable data structure (writeIORef)-    - throwing a synchronous Haskell exception+  * These are nasty failures like seg-faults or primitive Int# division+    by zero.  They differ from Haskell exceptions in that they are+    un-recoverable and typically bring execution to an immediate halt.+  * We generally treat unchecked exceptions as undefined behavior, on+    the assumption that the programmer never intends to crash the+    program in this way.  Thus we have no qualms about replacing a+    division-by-zero with a recoverable Haskell exception or+    discarding an indexArray# operation whose result is unused. -Often such primops have a type like-   State -> input -> (State, output)-so the state token guarantees ordering.  In general we rely on-data dependencies of the state token to enforce write-effect ordering,-but as the notes below make clear, the matter is a bit more complicated-than that. - * NB1: if you inline unsafePerformIO, you may end up with-   side-effecting ops whose 'state' output is discarded.-   And programmers may do that by hand; see #9390.-   That is why we (conservatively) do not discard write-effecting-   primops even if both their state and result is discarded.+Note [Classifying primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each primop has an associated 'PrimOpEffect', based on what that+primop can or cannot do at runtime.  This classification is - * NB2: We consider primops, such as raiseIO#, that can raise a-   (Haskell) synchronous exception to "have_side_effects" but not-   "can_fail".  We must be careful about not discarding such things;-   see the paper "A semantics for imprecise exceptions".+* Recorded in the 'effect' field in primops.txt.pp, and+* Exposed to the compiler via the 'primOpEffect' function in this module. - * NB3: *Read* effects on *mutable* cells (like reading an IORef or a-   MutableArray#) /are/ included.  You may find this surprising because it-   doesn't matter if we don't do them, or do them more than once.  *Sequencing*-   is maintained by the data dependency of the state token.  But see-   "Duplication" below under-   Note [Transformations affected by can_fail and has_side_effects]+See Note [Transformations affected by primop effects] for how we make+use of this categorisation. -   Note that read operations on *immutable* values (like indexArray#) do not-   have has_side_effects.   (They might be marked can_fail, however, because-   you might index out of bounds.)+The meanings of the four constructors of 'PrimOpEffect' are as+follows, in decreasing order of permissiveness: -   Using has_side_effects in this way is a bit of a blunt instrument.  We could-   be more refined by splitting read and write effects (see comments with #3207-   and #20195)+* ReadWriteEffect+    A primop is marked ReadWriteEffect if it can+    - read or write to the world (I/O), or+    - read or write to a mutable data structure (e.g. readMutVar#). -----------  can_fail -----------------------------A primop "can_fail" if it can fail with an *unchecked* exception on-some elements of its input domain. Main examples:-   division (fails on zero denominator)-   array indexing (fails if the index is out of bounds)+    Every such primop uses State# tokens for sequencing, with a type like:+      Inputs -> State# s -> (# State# s, Outputs #)+    The state token threading expresses ordering, but duplicating even+    a read-only effect would defeat this.  (See "duplication" under+    Note [Transformations affected by primop effects] for details.) -An "unchecked exception" is one that is an outright error, (not-turned into a Haskell exception,) such as seg-fault or-divide-by-zero error.  Such can_fail primops are ALWAYS surrounded-with a test that checks for the bad cases, but we need to be-very careful about code motion that might move it out of-the scope of the test.+    Note that operations like `indexArray#` that read *immutable*+    data structures do not need such special sequencing-related care,+    and are therefore not marked ReadWriteEffect. -Note [Transformations affected by can_fail and has_side_effects]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The can_fail and has_side_effects properties have the following effect-on program transformations.  Summary table is followed by details.+* ThrowsException+    A primop is marked ThrowsException if+    - it is not marked ReadWriteEffect, and+    - it may diverge or throw a synchronous Haskell exception+      even when used in a "correct" and well-specified way. -            can_fail     has_side_effects-Discard        YES           NO-Float in       YES           YES-Float out      NO            NO-Duplicate      YES           NO+    See also Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include raise#, raiseIO#, dataToTagLarge#, and seq#. -* Discarding.   case (a `op` b) of _ -> rhs  ===>   rhs-  You should not discard a has_side_effects primop; e.g.-     case (writeIntArray# a i v s of (# _, _ #) -> True-  Arguably you should be able to discard this, since the-  returned stat token is not used, but that relies on NEVER-  inlining unsafePerformIO, and programmers sometimes write-  this kind of stuff by hand (#9390).  So we (conservatively)-  never discard a has_side_effects primop.+    Note that whether an exception is considered precise or imprecise+    does not matter for the purposes of the PrimOpEffect flag. -  However, it's fine to discard a can_fail primop.  For example-     case (indexIntArray# a i) of _ -> True-  We can discard indexIntArray#; it has can_fail, but not-  has_side_effects; see #5658 which was all about this.-  Notice that indexIntArray# is (in a more general handling of-  effects) read effect, but we don't care about that here, and-  treat read effects as *not* has_side_effects.+* CanFail+    A primop is marked CanFail if+    - it is not marked ReadWriteEffect or ThrowsException, and+    - it can trigger a (potentially-unchecked) exception when used incorrectly. -  Similarly (a `/#` b) can be discarded.  It can seg-fault or-  cause a hardware exception, but not a synchronous Haskell-  exception.+    See Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include quotWord# and indexIntArray#, which can fail with+    division-by-zero and a segfault respectively. +    A correct use of a CanFail primop is usually surrounded by a test+    that screens out the bad cases such as a zero divisor or an+    out-of-bounds array index.  We must take care never to move a+    CanFail primop outside the scope of such a test. +* NoEffect+    A primop is marked NoEffect if it does not belong to any of the+    other three categories.  We can very aggressively shuffle these+    operations around without fear of changing a program's meaning. -  Synchronous Haskell exceptions, e.g. from raiseIO#, are treated-  as has_side_effects and hence are not discarded.+    Perhaps surprisingly, this aggressive shuffling imposes another+    restriction: The tricky NoEffect primop uncheckedShiftLWord32# has+    an undefined result when the provided shift amount is not between+    0 and 31.  Thus, a call like `uncheckedShiftLWord32# x 95#` is+    obviously invalid.  But since uncheckedShiftLWord32# is marked+    NoEffect, we may float such an invalid call out of a dead branch+    and speculatively evaluate it. -* Float in.  You can float a can_fail or has_side_effects primop-  *inwards*, but not inside a lambda (see Duplication below).+    In particular, we cannot safely rewrite such an invalid call to a+    runtime error; we must emit code that produces a valid Word32#.+    (If we're lucky, Core Lint may complain that the result of such a+    rewrite violates the let-can-float invariant (#16742), but the+    rewrite is always wrong!)  See also Note [Guarding against silly shifts]+    in GHC.Core.Opt.ConstantFold. -* Float out.  You must not float a can_fail primop *outwards* lest-  you escape the dynamic scope of the test.  Example:+    Marking uncheckedShiftLWord32# as CanFail instead of NoEffect+    would give us the freedom to rewrite such invalid calls to runtime+    errors, but would get in the way of optimization: When speculatively+    executing a bit-shift prevents the allocation of a thunk, that's a+    big win.+++Note [Transformations affected by primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The PrimOpEffect properties have the following effect on program+transformations.  The summary table is followed by details.  See also+Note [Classifying primop effects] for exactly what each column means.++                    NoEffect    CanFail    ThrowsException    ReadWriteEffect+Discard                YES        YES            NO                 NO+Defer (float in)       YES        YES           SAFE               SAFE+Speculate (float out)  YES        NO             NO                 NO+Duplicate              YES        YES            YES                NO++(SAFE means we could perform the transformation but do not.)++* Discarding:   case (a `op` b) of _ -> rhs  ===>   rhs+    You should not discard a ReadWriteEffect primop; e.g.+       case (writeIntArray# a i v s of (# _, _ #) -> True+    One could argue in favor of discarding this, since the returned+    State# token is not used.  But in practice unsafePerformIO can+    easily produce similar code, and programmers sometimes write this+    kind of stuff by hand (#9390).  So we (conservatively) never discard+    a ReadWriteEffect primop.++      Digression: We could try to track read-only effects separately+      from write effects to allow the former to be discarded.  But in+      fact we want a more general rewrite for read-only operations:+        case readOp# state# of (# newState#, _unused_result #) -> body+        ==> case state# of newState# -> body+      Such a rewrite is not yet implemented, but would have to be done+      in a different place anyway.++    Discarding a ThrowsException primop would also discard any exception+    it might have thrown.  For `raise#` or `raiseIO#` this would defeat+    the whole point of the primop, while for `dataToTagLarge#` or `seq#`+    this would make programs unexpectly lazier.++    However, it's fine to discard a CanFail primop.  For example+       case (indexIntArray# a i) of _ -> True+    We can discard indexIntArray# here; this came up in #5658.  Notice+    that CanFail primops like indexIntArray# can only trigger an+    exception when used incorrectly, i.e. a call that might not succeed+    is undefined behavior anyway.++* Deferring (float-in):+    See Note [Floating primops] in GHC.Core.Opt.FloatIn.++    In the absence of data dependencies (including state token threading),+    we reserve the right to re-order the following things arbitrarily:+      * Side effects+      * Imprecise exceptions+      * Divergent computations (infinite loops)+    This lets us safely float almost any primop *inwards*, but not+    inside a (multi-shot) lambda.  (See "Duplication" below.)++    However, the main reason to float-in a primop application would be+    to discard it (by floating it into some but not all branches of a+    case), so we actually only float-in NoEffect and CanFail operations.+    See also Note [Floating primops] in GHC.Core.Opt.FloatIn.++    (This automatically side-steps the question of precise exceptions, which+    mustn't be re-ordered arbitrarily but need at least ThrowsException.)++* Speculation (strict float-out):+    You must not float a CanFail primop *outwards* lest it escape the+    dynamic scope of a run-time validity test.  Example:       case d ># 0# of         True  -> case x /# d of r -> r +# 1         False -> 0-  Here we must not float the case outwards to give+    Here we must not float the case outwards to give       case x/# d of r ->       case d ># 0# of         True  -> r +# 1         False -> 0+    Otherwise, if this block is reached when d is zero, it will crash.+    Exactly the same reasoning applies to ThrowsException primops. -  Nor can you float out a has_side_effects primop.  For example:+    Nor can you float out a ReadWriteEffect primop.  For example:        if blah then case writeMutVar# v True s0 of (# s1 #) -> s1                else s0-  Notice that s0 is mentioned in both branches of the 'if', but-  only one of these two will actually be consumed.  But if we-  float out to+    Notice that s0 is mentioned in both branches of the 'if', but+    only one of these two will actually be consumed.  But if we+    float out to       case writeMutVar# v True s0 of (# s1 #) ->       if blah then s1 else s0-  the writeMutVar will be performed in both branches, which is-  utterly wrong.+    the writeMutVar will be performed in both branches, which is+    utterly wrong. -* Duplication.  You cannot duplicate a has_side_effect primop.  You-  might wonder how this can occur given the state token threading, but-  just look at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get-  something like this+    What about a read-only operation that cannot fail, like+    readMutVar#?  In principle we could safely float these out.  But+    there are not very many such operations and it's not clear if+    there are real-world programs that would benefit from this.++* Duplication:+    You cannot duplicate a ReadWriteEffect primop.  You might wonder+    how this can occur given the state token threading, but just look+    at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get something like this         p = case readMutVar# s v of               (# s', r #) -> (State# s', r)         s' = case p of (s', r) -> s'         r  = case p of (s', r) -> r -  (All these bindings are boxed.)  If we inline p at its two call-  sites, we get a catastrophe: because the read is performed once when-  s' is demanded, and once when 'r' is demanded, which may be much-  later.  Utterly wrong.  #3207 is real example of this happening.+    (All these bindings are boxed.)  If we inline p at its two call+    sites, we get a catastrophe: because the read is performed once when+    s' is demanded, and once when 'r' is demanded, which may be much+    later.  Utterly wrong.  #3207 is real example of this happening.+    Floating p into a multi-shot lambda would be wrong for the same reason. -  However, it's fine to duplicate a can_fail primop.  That is really-  the only difference between can_fail and has_side_effects.+    However, it's fine to duplicate a CanFail or ThrowsException primop. -Note [Implementation: how can_fail/has_side_effects affect transformations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+++Note [Implementation: how PrimOpEffect affects transformations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How do we ensure that floating/duplication/discarding are done right in the simplifier? -Two main predicates on primops test these flags:-  primOpOkForSideEffects <=> not has_side_effects-  primOpOkForSpeculation <=> not (has_side_effects || can_fail)+Several predicates on primops test this flag:+  primOpOkToDiscard      <=> effect < ThrowsException+  primOpOkForSpeculation <=> effect == NoEffect && not (out_of_line)+  primOpIsCheap          <=> cheap  -- ...defaults to primOpOkForSpeculation+    [[But note that the raise# family and seq# are also considered cheap in+      GHC.Core.Utils.exprIsCheap by way of being work-free]] +  * The discarding mentioned above happens in+    GHC.Core.Opt.Simplify.Iteration, specifically in rebuildCase,+    where it is guarded by exprOkToDiscard, which in turn checks+    primOpOkToDiscard.+   * The "no-float-out" thing is achieved by ensuring that we never-    let-bind a can_fail or has_side_effects primop.  The RHS of a-    let-binding (which can float in and out freely) satisfies-    exprOkForSpeculation; this is the let-can-float invariant.  And-    exprOkForSpeculation is false of can_fail and has_side_effects.+    let-bind a saturated primop application unless it has NoEffect.+    The RHS of a let-binding (which can float in and out freely)+    satisfies exprOkForSpeculation; this is the let-can-float+    invariant.  And exprOkForSpeculation is false of a saturated+    primop application unless it has NoEffect. -  * So can_fail and has_side_effects primops will appear only as the+  * So primops that aren't NoEffect will appear only as the     scrutinees of cases, and that's why the FloatIn pass is capable     of floating case bindings inwards. -  * The no-duplicate thing is done via primOpIsCheap, by making-    has_side_effects things (very very very) not-cheap!+  * Duplication via inlining and float-in of (lifted) let-binders is+    controlled via primOpIsWorkFree and primOpIsCheap, by making+    ReadWriteEffect things (among others) not-cheap!  (The test+    PrimOpEffect_Sanity will complain if any ReadWriteEffect primop+    is considered either work-free or cheap.)  Additionally, a+    case binding is only floated inwards if its scrutinee is ok-to-discard. -} -primOpHasSideEffects :: PrimOp -> Bool-#include "primop-has-side-effects.hs-incl"+primOpEffect :: PrimOp -> PrimOpEffect+#include "primop-effects.hs-incl" -primOpCanFail :: PrimOp -> Bool-#include "primop-can-fail.hs-incl"+data PrimOpEffect+  -- See Note [Classifying primop effects]+  = NoEffect+  | CanFail+  | ThrowsException+  | ReadWriteEffect+  deriving (Eq, Ord)  primOpOkForSpeculation :: PrimOp -> Bool-  -- See Note [PrimOp can_fail and has_side_effects]+  -- See Note [Classifying primop effects]   -- See comments with GHC.Core.Utils.exprOkForSpeculation-  -- primOpOkForSpeculation => primOpOkForSideEffects+  -- primOpOkForSpeculation => primOpOkToDiscard primOpOkForSpeculation op-  =  primOpOkForSideEffects op-  && not (primOpOutOfLine op || primOpCanFail op)+  = primOpEffect op == NoEffect && not (primOpOutOfLine op)     -- I think the "out of line" test is because out of line things can     -- be expensive (eg sine, cosine), and so we may not want to speculate them -primOpOkForSideEffects :: PrimOp -> Bool-primOpOkForSideEffects op-  = not (primOpHasSideEffects op)--{--Note [primOpIsCheap]-~~~~~~~~~~~~~~~~~~~~+primOpOkToDiscard :: PrimOp -> Bool+primOpOkToDiscard op+  = primOpEffect op < ThrowsException -@primOpIsCheap@, as used in GHC.Core.Opt.Simplify.Utils.  For now (HACK-WARNING), we just borrow some other predicates for a-what-should-be-good-enough test.  "Cheap" means willing to call it more-than once, and/or push it inside a lambda.  The latter could change the-behaviour of 'seq' for primops that can fail, so we don't treat them as cheap.--}+primOpIsWorkFree :: PrimOp -> Bool+#include "primop-is-work-free.hs-incl"  primOpIsCheap :: PrimOp -> Bool--- See Note [PrimOp can_fail and has_side_effects]-primOpIsCheap op = primOpOkForSpeculation op+-- See Note [Classifying primop effects]+#include "primop-is-cheap.hs-incl" -- In March 2001, we changed this to --      primOpIsCheap op = False -- thereby making *no* primops seem cheap.  But this killed eta@@ -540,7 +640,7 @@ -- The problem that originally gave rise to the change was --      let x = a +# b *# c in x +# x -- were we don't want to inline x. But primopIsCheap doesn't control--- that (it's exprIsDupable that does) so the problem doesn't occur+-- that (it's primOpIsWorkFree that does) so the problem doesn't occur -- even if primOpIsCheap sometimes says 'True'.  @@ -551,37 +651,44 @@ primOpIsDiv :: PrimOp -> Bool primOpIsDiv op = case op of -  -- TODO: quotRemWord2, Int64, Word64   IntQuotOp       -> True   Int8QuotOp      -> True   Int16QuotOp     -> True   Int32QuotOp     -> True+  Int64QuotOp     -> True    IntRemOp        -> True   Int8RemOp       -> True   Int16RemOp      -> True   Int32RemOp      -> True+  Int64RemOp      -> True    IntQuotRemOp    -> True   Int8QuotRemOp   -> True   Int16QuotRemOp  -> True   Int32QuotRemOp  -> True+  -- Int64QuotRemOp doesn't exist (yet)    WordQuotOp      -> True   Word8QuotOp     -> True   Word16QuotOp    -> True   Word32QuotOp    -> True+  Word64QuotOp    -> True    WordRemOp       -> True   Word8RemOp      -> True   Word16RemOp     -> True   Word32RemOp     -> True+  Word64RemOp     -> True    WordQuotRemOp   -> True   Word8QuotRemOp  -> True   Word16QuotRemOp -> True   Word32QuotRemOp -> True+  -- Word64QuotRemOp doesn't exist (yet) +  WordQuotRem2Op  -> True+   FloatDivOp      -> True   DoubleDivOp     -> True   _               -> False@@ -752,8 +859,9 @@         GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )  data PrimOpResultInfo-  = ReturnsPrim     PrimRep-  | ReturnsAlg      TyCon+  = ReturnsVoid+  | ReturnsPrim     PrimRep+  | ReturnsTuple  -- Some PrimOps need not return a manifest primitive or algebraic value -- (i.e. they might return a polymorphic value).  These PrimOps *must*@@ -762,9 +870,13 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op   = case (primOpInfo op) of-      Compare _ _                         -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)-      GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)-                         | otherwise      -> ReturnsAlg tc+      Compare _ _                         -> ReturnsPrim IntRep+      GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of+                                               [] -> ReturnsVoid+                                               [rep] -> ReturnsPrim rep+                                               _ -> pprPanic "getPrimOpResultInfo" (ppr op)+                         | isUnboxedTupleTyCon tc -> ReturnsTuple+                         | otherwise      -> pprPanic "getPrimOpResultInfo" (ppr op)                          where                            tc = tyConAppTyCon ty                         -- All primops return a tycon-app result@@ -810,10 +922,10 @@         = text "__primcall" <+> ppr pkgId <+> ppr lbl  -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it--- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument+-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case-  SeqOp       -> False-  DataToTagOp -> False-  p           -> not (primOpOutOfLine p)+  DataToTagSmallOp -> False+  DataToTagLargeOp -> False+  p                -> not (primOpOutOfLine p)
compiler/GHC/Builtin/PrimOps.hs-boot view
@@ -1,5 +1,6 @@ module GHC.Builtin.PrimOps where -import GHC.Prelude ()+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Base ()  data PrimOp
compiler/GHC/Builtin/PrimOps/Ids.hs view
@@ -1,3 +1,8 @@++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+ -- | PrimOp's Ids module GHC.Builtin.PrimOps.Ids   ( primOpId@@ -9,12 +14,15 @@  -- primop rules are attached to primop ids import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)-import GHC.Core.Type (mkForAllTys, mkVisFunTysMany, argsHaveFixedRuntimeRep )+import GHC.Core.TyCo.Rep ( scaledThing )+import GHC.Core.Type+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) import GHC.Core.FVs (mkRuleInfo)  import GHC.Builtin.PrimOps import GHC.Builtin.Uniques import GHC.Builtin.Names+import GHC.Builtin.Types.Prim  import GHC.Types.Basic import GHC.Types.Cpr@@ -23,11 +31,18 @@ import GHC.Types.Id.Info import GHC.Types.TyThing import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Set +import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType ( ConcreteTvOrigin(..), ConcreteTyVars, TcType )+ import GHC.Data.SmallArray-import Data.Maybe ( maybeToList ) +import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList ) + -- | Build a PrimOp Id mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op@@ -38,9 +53,10 @@     name = mkWiredInName gHC_PRIM (primOpOcc prim_op)                          (mkPrimOpIdUnique (primOpTag prim_op))                          (AnId id) UserSyntax-    id   = mkGlobalId (PrimOpId prim_op lev_poly) name ty info-    lev_poly = not (argsHaveFixedRuntimeRep ty)+    id   = mkGlobalId (PrimOpId prim_op conc_tvs) name ty info +    conc_tvs = computePrimOpConcTyVarsFromType name tyvars arg_tys res_ty+     -- PrimOps don't ever construct a product, but we want to preserve bottoms     cpr       | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr@@ -57,6 +73,85 @@                -- test) about a RULE conflicting with a possible inlining                -- cf #7287 +-- | Analyse the type of a primop to determine which of its outermost forall'd+-- type variables must be instantiated to concrete types when the primop is+-- instantiated.+--+-- These are the Levity and RuntimeRep kinded type-variables which appear in+-- negative position in the type of the primop.+computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars+computePrimOpConcTyVarsFromType nm tyvars arg_tys _res_ty = mkNameEnv concs+  where+    concs = [ (tyVarName kind_tv, ConcreteFRR frr_orig)+            | Bndr tv _af <- tyvars+            , kind_tv    <- tyCoVarsOfTypeWellScoped $ tyVarKind tv+            , neg_pos    <- maybeToList $ frr_tyvar_maybe kind_tv+            , let frr_orig = FixedRuntimeRepOrigin+                           { frr_type    = mkTyVarTy tv+                           , frr_context = FRRRepPolyId nm RepPolyPrimOp neg_pos+                           }+            ]++    -- As per Note [Levity and representation polymorphic primops]+    -- in GHC.Builtin.Primops.txt.pp, we compute the ConcreteTyVars associated+    -- to a primop by inspecting the type variable names.+    frr_tyvar_maybe tv+      | tv `elem` [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar+                  , levity1TyVar, levity2TyVar ]+      = listToMaybe $+          mapMaybe (\ (i,arg) -> mkArgPos i <$> positiveKindPos_maybe tv arg)+            (zip [1..] arg_tys)+      | otherwise+      = Nothing+      -- Compute whether the type variable occurs in the kind of a type variable+      -- in positive position in one of the argument types of the primop.++-- | Does this type variable appear in a kind in a negative position in the+-- type?+--+-- Returns the first such position if so.+--+-- NB: assumes the type is of a simple form, e.g. no foralls, no function+-- arrows nested in a TyCon other than a function arrow.+-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting+-- its type, see 'computePrimOpConcTyVarsFromType'.+negativeKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Neg)+negativeKindPos_maybe tv ty+  | (args, res) <- splitFunTys ty+  = listToMaybe $ catMaybes $+      ( (if null args then Nothing else Result <$> negativeKindPos_maybe tv res)+      : map recur (zip [1..] args)+      )+  where+    recur (pos, 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+-- type?+--+-- Returns the first such position if so.+--+-- NB: assumes the type is of a simple form, e.g. no foralls, no function+-- arrows nested in a TyCon other than a function arrow.+-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting+-- its type, see 'computePrimOpConcTyVarsFromType'.+positiveKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Pos)+positiveKindPos_maybe tv ty+  | (args, res) <- splitFunTys ty+  = listToMaybe $ catMaybes $+      ( (if null args then finish res else Result <$> positiveKindPos_maybe tv res)+      : map recur (zip [1..] args)+      )+  where+    recur (pos, 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)+      = Just Top+      | otherwise+      = Nothing  ------------------------------------------------------------- -- Cache of PrimOp's Ids
compiler/GHC/Builtin/Types.hs view
@@ -5,2410 +5,2944 @@ -}  {-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | This module is about types that can be defined in Haskell, but which---   must be wired into the compiler nonetheless.  C.f module "GHC.Builtin.Types.Prim"-module GHC.Builtin.Types (-        -- * Helper functions defined here-        mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the-                            -- built-in functions for evaluation.--        mkWiredInIdName,    -- used in GHC.Types.Id.Make--        -- * All wired in things-        wiredInTyCons, isBuiltInOcc_maybe, isPunOcc_maybe,--        -- * Bool-        boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,-        trueDataCon,  trueDataConId,  true_RDR,-        falseDataCon, falseDataConId, false_RDR,-        promotedFalseDataCon, promotedTrueDataCon,--        -- * Ordering-        orderingTyCon,-        ordLTDataCon, ordLTDataConId,-        ordEQDataCon, ordEQDataConId,-        ordGTDataCon, ordGTDataConId,-        promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,--        -- * Boxing primitive types-        boxingDataCon, BoxingInfo(..),--        -- * Char-        charTyCon, charDataCon, charTyCon_RDR,-        charTy, stringTy, charTyConName, stringTyCon_RDR,--        -- * Double-        doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,--        -- * Float-        floatTyCon, floatDataCon, floatTy, floatTyConName,--        -- * Int-        intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,-        intTy,--        -- * Word-        wordTyCon, wordDataCon, wordTyConName, wordTy,--        -- * Word8-        word8TyCon, word8DataCon, word8Ty,--        -- * List-        listTyCon, listTyCon_RDR, listTyConName, listTyConKey,-        nilDataCon, nilDataConName, nilDataConKey,-        consDataCon_RDR, consDataCon, consDataConName,-        promotedNilDataCon, promotedConsDataCon,-        mkListTy, mkPromotedListTy,--        -- * Maybe-        maybeTyCon, maybeTyConName,-        nothingDataCon, nothingDataConName, promotedNothingDataCon,-        justDataCon, justDataConName, promotedJustDataCon,-        mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,--        -- * Tuples-        mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,-        tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,-        promotedTupleDataCon,-        unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,-        soloTyCon,-        pairTyCon, mkPromotedPairTy, isPromotedPairType,-        unboxedUnitTy,-        unboxedUnitTyCon, unboxedUnitDataCon,-        unboxedTupleKind, unboxedSumKind,-        filterCTuple, mkConstraintTupleTy,--        -- ** Constraint tuples-        cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,-        cTupleTyConNameArity_maybe,-        cTupleDataCon, cTupleDataConName, cTupleDataConNames,-        cTupleSelId, cTupleSelIdName,--        -- * Any-        anyTyCon, anyTy, anyTypeOfKind,--        -- * Recovery TyCon-        makeRecoveryTyCon,--        -- * Sums-        mkSumTy, sumTyCon, sumDataCon,--        -- * Kinds-        typeSymbolKindCon, typeSymbolKind,-        isLiftedTypeKindTyConName,-        typeToTypeKind,-        liftedRepTyCon, unliftedRepTyCon,-        tYPETyCon, tYPETyConName, tYPEKind,-        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind,-        constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind,-        constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,-        constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,-        liftedRepTyConName, unliftedRepTyConName,--        -- * Equality predicates-        heqTyCon, heqTyConName, heqClass, heqDataCon,-        eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,-        coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,--        -- * RuntimeRep and friends-        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,--        boxedRepDataConTyCon,-        runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,--        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,--        -- * Levity-        levityTyCon, levityTy,-        liftedDataConTyCon, unliftedDataConTyCon,-        liftedDataConTy,    unliftedDataConTy,--        intRepDataConTy,-        int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,-        wordRepDataConTy,-        word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,-        addrRepDataConTy,-        floatRepDataConTy, doubleRepDataConTy,--        vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,-        vec64DataConTy,--        int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,-        int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,-        word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,--        doubleElemRepDataConTy,--        -- * Multiplicity and friends-        multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy,-        multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy,-        oneDataConTyCon, manyDataConTyCon,-        multMulTyCon,--        unrestrictedFunTyCon, unrestrictedFunTyConName,--        -- * Bignum-        integerTy, integerTyCon, integerTyConName,-        integerISDataCon, integerISDataConName,-        integerIPDataCon, integerIPDataConName,-        integerINDataCon, integerINDataConName,-        naturalTy, naturalTyCon, naturalTyConName,-        naturalNSDataCon, naturalNSDataConName,-        naturalNBDataCon, naturalNBDataConName-    ) where--import GHC.Prelude--import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )---- friends:-import GHC.Builtin.Names-import GHC.Builtin.Types.Prim-import GHC.Builtin.Uniques---- others:-import GHC.Core( Expr(Type), mkConApp )-import GHC.Core.Coercion.Axiom-import GHC.Core.Type-import GHC.Types.Id-import GHC.Core.DataCon-import GHC.Core.ConLike-import GHC.Core.TyCon-import GHC.Core.Class     ( Class, mkClass )-import GHC.Core.Map.Type  ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )-import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))--import GHC.Types.TyThing-import GHC.Types.SourceText-import GHC.Types.Var ( VarBndr (Bndr) )-import GHC.Types.RepType-import GHC.Types.Name.Reader-import GHC.Types.Name as Name-import GHC.Types.Name.Env ( lookupNameEnv_NF )-import GHC.Types.Basic-import GHC.Types.ForeignCall-import GHC.Types.Unique.Set---import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )-import GHC.Unit.Module        ( Module )--import Data.Array-import GHC.Data.FastString-import GHC.Data.BooleanFormula ( mkAnd )--import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain--import qualified Data.ByteString.Char8 as BS--import Data.Foldable-import Data.List        ( elemIndex, intersperse )--alpha_tyvar :: [TyVar]-alpha_tyvar = [alphaTyVar]--alpha_ty :: [Type]-alpha_ty = [alphaTy]--{--Note [Wired-in Types and Type Constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--This module include a lot of wired-in types and type constructors. Here,-these are presented in a tabular format to make it easier to find the-wired-in type identifier corresponding to a known Haskell type. Data-constructors are nested under their corresponding types with two spaces-of indentation.--Identifier              Type    Haskell name          Notes------------------------------------------------------------------------------liftedTypeKindTyCon     TyCon   GHC.Types.Type        Synonym for: TYPE LiftedRep-unliftedTypeKindTyCon   TyCon   GHC.Types.Type        Synonym for: TYPE UnliftedRep-liftedRepTyCon          TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Lifted-unliftedRepTyCon        TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Unlifted-levityTyCon             TyCon   GHC.Types.Levity      Data type-  liftedDataConTyCon    TyCon   GHC.Types.Lifted      Data constructor-  unliftedDataConTyCon  TyCon   GHC.Types.Unlifted    Data constructor-vecCountTyCon           TyCon   GHC.Types.VecCount    Data type-  vec2DataConTy         Type    GHC.Types.Vec2        Data constructor-  vec4DataConTy         Type    GHC.Types.Vec4        Data constructor-  vec8DataConTy         Type    GHC.Types.Vec8        Data constructor-  vec16DataConTy        Type    GHC.Types.Vec16       Data constructor-  vec32DataConTy        Type    GHC.Types.Vec32       Data constructor-  vec64DataConTy        Type    GHC.Types.Vec64       Data constructor-runtimeRepTyCon         TyCon   GHC.Types.RuntimeRep  Data type-  boxedRepDataConTyCon  TyCon   GHC.Types.BoxedRep    Data constructor-  intRepDataConTy       Type    GHC.Types.IntRep      Data constructor-  doubleRepDataConTy    Type    GHC.Types.DoubleRep   Data constructor-  floatRepDataConTy     Type    GHC.Types.FloatRep    Data constructor-boolTyCon               TyCon   GHC.Types.Bool        Data type-  trueDataCon           DataCon GHC.Types.True        Data constructor-  falseDataCon          DataCon GHC.Types.False       Data constructor-  promotedTrueDataCon   TyCon   GHC.Types.True        Data constructor-  promotedFalseDataCon  TyCon   GHC.Types.False       Data constructor--************************************************************************-*                                                                      *-\subsection{Wired in type constructors}-*                                                                      *-************************************************************************--If you change which things are wired in, make sure you change their-names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc---}----- This list is used only to define GHC.Builtin.Utils.wiredInThings. 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)--- 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-                , boolTyCon-                , charTyCon-                , stringTyCon-                , doubleTyCon-                , floatTyCon-                , intTyCon-                , wordTyCon-                , listTyCon-                , orderingTyCon-                , maybeTyCon-                , heqTyCon-                , eqTyCon-                , coercibleTyCon-                , typeSymbolKindCon-                , runtimeRepTyCon-                , levityTyCon-                , vecCountTyCon-                , vecElemTyCon-                , constraintKindTyCon-                , liftedTypeKindTyCon-                , unliftedTypeKindTyCon-                , multiplicityTyCon-                , naturalTyCon-                , integerTyCon-                , liftedRepTyCon-                , unliftedRepTyCon-                , zeroBitRepTyCon-                , zeroBitTypeTyCon-                ]--mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name-mkWiredInTyConName built_in modu fs unique tycon-  = mkWiredInName modu (mkTcOccFS fs) unique-                  (ATyCon tycon)        -- Relevant TyCon-                  built_in--mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name-mkWiredInDataConName built_in modu fs unique datacon-  = mkWiredInName modu (mkDataOccFS fs) unique-                  (AConLike (RealDataCon datacon))    -- Relevant DataCon-                  built_in--mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name-mkWiredInIdName mod fs uniq id- = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax---- See Note [Kind-changing of (~) and Coercible]--- in libraries/ghc-prim/GHC/Types.hs-eqTyConName, eqDataConName, eqSCSelIdName :: Name-eqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~")   eqTyConKey   eqTyCon-eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon-eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId--eqTyCon_RDR :: RdrName-eqTyCon_RDR = nameRdrName eqTyConName---- See Note [Kind-changing of (~) and Coercible]--- in libraries/ghc-prim/GHC/Types.hs-heqTyConName, heqDataConName, heqSCSelIdName :: Name-heqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~~")   heqTyConKey      heqTyCon-heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon-heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId---- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs-coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name-coercibleTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Coercible")  coercibleTyConKey   coercibleTyCon-coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon-coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId--charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name-charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char")   charTyConKey charTyCon-charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#")     charDataConKey charDataCon-stringTyConName   = mkWiredInTyConName   UserSyntax gHC_BASE  (fsLit "String") stringTyConKey stringTyCon-intTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int")    intTyConKey   intTyCon-intDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#")     intDataConKey  intDataCon--boolTyConName, falseDataConName, trueDataConName :: Name-boolTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon-falseDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon-trueDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True")  trueDataConKey  trueDataCon--listTyConName, nilDataConName, consDataConName :: Name-listTyConName     = mkWiredInTyConName   UserSyntax    gHC_TYPES (fsLit "List") listTyConKey listTyCon-nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon-consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon--maybeTyConName, nothingDataConName, justDataConName :: Name-maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")-                                          maybeTyConKey maybeTyCon-nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")-                                          nothingDataConKey nothingDataCon-justDataConName    = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")-                                          justDataConKey justDataCon--wordTyConName, wordDataConName, word8DataConName :: Name-wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon-wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon-word8DataConName   = mkWiredInDataConName UserSyntax gHC_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon--floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name-floatTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Float")  floatTyConKey    floatTyCon-floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#")     floatDataConKey  floatDataCon-doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey   doubleTyCon-doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")     doubleDataConKey doubleDataCon---- Any--{--Note [Any types]-~~~~~~~~~~~~~~~~-The type constructor Any,--    type family Any :: k where { }--It has these properties:--  * Note that 'Any' is kind polymorphic since in some program we may-    need to use Any to fill in a type variable of some kind other than *-    (see #959 for examples).  Its kind is thus `forall k. k``.--  * It is defined in module GHC.Types, and exported so that it is-    available to users.  For this reason it's treated like any other-    wired-in type:-      - has a fixed unique, anyTyConKey,-      - lives in the global name cache--  * It is a *closed* type family, with no instances.  This means that-    if   ty :: '(k1, k2)  we add a given coercion-             g :: ty ~ (Fst ty, Snd ty)-    If Any was a *data* type, then we'd get inconsistency because 'ty'-    could be (Any '(k1,k2)) and then we'd have an equality with Any on-    one side and '(,) on the other. See also #9097 and #9636.--  * When instantiated at a lifted type it is inhabited by at least one value,-    namely bottom--  * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce.--  * It does not claim to be a *data* type, and that's important for-    the code generator, because the code gen may *enter* a data value-    but never enters a function value.--  * It is wired-in so we can easily refer to it where we don't have a name-    environment (e.g. see Rules.matchRule for one example)--It's used to instantiate un-constrained type variables after type checking. For-example, 'length' has type--  length :: forall a. [a] -> Int--and the list datacon for the empty list has type--  [] :: forall a. [a]--In order to compose these two terms as @length []@ a type-application is required, but there is no constraint on the-choice.  In this situation GHC uses 'Any',--> length (Any *) ([] (Any *))--Above, we print kinds explicitly, as if with --fprint-explicit-kinds.--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.--}---anyTyConName :: Name-anyTyConName =-    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon--anyTyCon :: TyCon-anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing-                         (ClosedSynFamilyTyCon Nothing)-                         Nothing-                         NotInjective-  where-    binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]-    res_kind = mkTyVarTy (binderVar kv)--anyTy :: Type-anyTy = mkTyConTy anyTyCon--anyTypeOfKind :: Kind -> Type-anyTypeOfKind kind = mkTyConApp anyTyCon [kind]---- | Make a fake, recovery 'TyCon' from an existing one.--- Used when recovering from errors in type declarations-makeRecoveryTyCon :: TyCon -> TyCon-makeRecoveryTyCon tc-  = mkTcTyCon (tyConName tc)-              bndrs res_kind-              noTcTyConScopedTyVars-              True             -- Fully generalised-              flavour          -- Keep old flavour-  where-    flavour = tyConFlavour tc-    [kv] = mkTemplateKindVars [liftedTypeKind]-    (bndrs, res_kind)-       = case flavour of-           PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv)-           _ -> (tyConBinders tc, tyConResKind tc)-        -- For data types we have already validated their kind, so it-        -- makes sense to keep it. For promoted data constructors we haven't,-        -- so we recover with kind (forall k. k).  Otherwise consider-        --     data T a where { MkT :: Show a => T a }-        -- If T is for some reason invalid, we don't want to fall over-        -- at (promoted) use-sites of MkT.---- Kinds-typeSymbolKindConName :: Name-typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon---boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,-    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName-boolTyCon_RDR   = nameRdrName boolTyConName-false_RDR       = nameRdrName falseDataConName-true_RDR        = nameRdrName trueDataConName-intTyCon_RDR    = nameRdrName intTyConName-charTyCon_RDR   = nameRdrName charTyConName-stringTyCon_RDR = nameRdrName stringTyConName-intDataCon_RDR  = nameRdrName intDataConName-listTyCon_RDR   = nameRdrName listTyConName-consDataCon_RDR = nameRdrName consDataConName--{--************************************************************************-*                                                                      *-\subsection{mkWiredInTyCon}-*                                                                      *-************************************************************************--}---- This function assumes that the types it creates have all parameters at--- Representational role, and that there is no kind polymorphism.-pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon-pcTyCon name cType tyvars cons-  = mkAlgTyCon name-                (mkAnonTyConBinders tyvars)-                liftedTypeKind-                (map (const Representational) tyvars)-                cType-                []              -- No stupid theta-                (mkDataTyConRhs cons)-                (VanillaAlgTyCon (mkPrelTyConRepName name))-                False           -- Not in GADT syntax--pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon-pcDataCon n univs tys-  = pcDataConWithFixity False n univs-                      []    -- no ex_tvs-                      univs -- the univs are precisely the user-written tyvars-                      []    -- No theta-                      (map linear tys)--pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon--- Used for data constructors whose arguments are all constraints.--- Notably constraint tuples, Eq# etc.-pcDataConConstraint n univs theta-  = pcDataConWithFixity False n univs-                      []    -- No ex_tvs-                      univs -- The univs are precisely the user-written tyvars-                      theta -- All constraint arguments-                      []    -- No value arguments---- Used for RuntimeRep and friends; things with PromDataConInfo-pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon-pcSpecialDataCon dc_name arg_tys tycon rri-  = pcDataConWithFixity' False dc_name-                         (dataConWorkerUnique (nameUnique dc_name)) rri-                         [] [] [] [] (map linear arg_tys) tycon--pcDataConWithFixity :: Bool      -- ^ declared infix?-                    -> Name      -- ^ datacon name-                    -> [TyVar]   -- ^ univ tyvars-                    -> [TyCoVar] -- ^ ex tycovars-                    -> [TyCoVar] -- ^ user-written tycovars-                    -> ThetaType-                    -> [Scaled Type]    -- ^ args-                    -> TyCon-                    -> DataCon-pcDataConWithFixity infx n = pcDataConWithFixity' infx n-                                 (dataConWorkerUnique (nameUnique n)) NoPromInfo--- The Name's unique is the first of two free uniques;--- the first is used for the datacon itself,--- the second is used for the "worker name"------ To support this the mkPreludeDataConUnique function "allocates"--- one DataCon unique per pair of Ints.--pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo-                     -> [TyVar] -> [TyCoVar] -> [TyCoVar]-                     -> ThetaType -> [Scaled Type] -> TyCon -> DataCon--- The Name should be in the DataName name space; it's the name--- of the DataCon itself.------ IMPORTANT NOTE:---    if you try to wire-in a /GADT/ data constructor you will---    find it hard (we did).  You will need wrapper and worker---    Names, a DataConBoxer, DataConRep, EqSpec, etc.---    Try hard not to wire-in GADT data types. You will live---    to regret doing so (we do).--pcDataConWithFixity' declared_infix dc_name wrk_key rri-                     tyvars ex_tyvars user_tyvars theta arg_tys tycon-  = data_con-  where-    tag_map = mkTyConTagMap tycon-    -- This constructs the constructor Name to ConTag map once per-    -- constructor, which is quadratic. It's OK here, because it's-    -- only called for wired in data types that don't have a lot of-    -- constructors. It's also likely that GHC will lift tag_map, since-    -- we call pcDataConWithFixity' with static TyCons in the same module.-    -- See Note [Constructor tag allocation] and #14657-    data_con = mkDataCon dc_name declared_infix prom_info-                (map (const no_bang) arg_tys)-                []      -- No labelled fields-                tyvars ex_tyvars-                (mkTyVarBinders SpecifiedSpec user_tyvars)-                []      -- No equality spec-                theta-                arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))-                rri-                tycon-                (lookupNameEnv_NF tag_map dc_name)-                []      -- No stupid theta-                (mkDataConWorkId wrk_name data_con)-                NoDataConRep    -- Wired-in types are too simple to need wrappers--    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict--    wrk_name = mkDataConWorkerName data_con wrk_key--    prom_info = mkPrelTyConRepName dc_name--mkDataConWorkerName :: DataCon -> Unique -> Name-mkDataConWorkerName data_con wrk_key =-    mkWiredInName modu wrk_occ wrk_key-                  (AnId (dataConWorkId data_con)) UserSyntax-  where-    modu     = assert (isExternalName dc_name) $-               nameModule dc_name-    dc_name = dataConName data_con-    dc_occ  = nameOccName dc_name-    wrk_occ = mkDataConWorkerOcc dc_occ---{--************************************************************************-*                                                                      *-              Symbol-*                                                                      *-************************************************************************--}--typeSymbolKindCon :: TyCon--- data Symbol-typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []--typeSymbolKind :: Kind-typeSymbolKind = mkTyConTy typeSymbolKindCon---{--************************************************************************-*                                                                      *-                Stuff for dealing with tuples-*                                                                      *-************************************************************************--Note [How tuples work]-~~~~~~~~~~~~~~~~~~~~~~-* There are three families of tuple TyCons and corresponding-  DataCons, expressed by the type BasicTypes.TupleSort:-    data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple--* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon--* BoxedTuples-    - A wired-in type-    - Data type declarations in GHC.Tuple-    - The data constructors really have an info table--* UnboxedTuples-    - A wired-in type-    - Have a pretend DataCon, defined in GHC.Prim,-      but no actual declaration and no info table--* ConstraintTuples-    - A wired-in type.-    - Declared as classes in GHC.Classes, e.g.-         class (c1,c2) => (c1,c2)-    - Given constraints: the superclasses automatically become available-    - Wanted constraints: there is a built-in instance-         instance (c1,c2) => (c1,c2)-      See GHC.Tc.Instance.Class.matchCTuple-    - Currently just go up to 64; beyond that-      you have to use manual nesting-    - Their OccNames look like (%,,,%), so they can easily be-      distinguished from term tuples.  But (following Haskell) we-      pretty-print saturated constraint tuples with round parens;-      see BasicTypes.tupleParens.-    - Unlike BoxedTuples and UnboxedTuples, which only wire-      in type constructors and data constructors, ConstraintTuples also wire in-      superclass selector functions. For instance, $p1(%,%) and $p2(%,%) are-      the selectors for the binary constraint tuple.--* In quite a lot of places things are restricted just to-  BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish-  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.--* Serialization to interface files works via the usual mechanism for known-key-  things: instead of serializing the OccName we just serialize the key. During-  deserialization we lookup the Name associated with the unique with the logic-  in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details.--See also Note [Known-key names] in GHC.Builtin.Names.--Note [One-tuples]-~~~~~~~~~~~~~~~~~-GHC supports both boxed and unboxed one-tuples:- - Unboxed one-tuples are sometimes useful when returning a-   single value after CPR analysis- - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when-   there is just one binder-Basically it keeps everything uniform.--However the /naming/ of the type/data constructors for one-tuples is a-bit odd:-  3-tuples:  (,,)   (,,)#-  2-tuples:  (,)    (,)#-  1-tuples:  ??-  0-tuples:  ()     ()#--Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#'-for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:-  data ()     = ()-  data Solo a = MkSolo a-  data (a,b)  = (a,b)--There is no way to write a boxed one-tuple in Haskell using tuple syntax.-They can, however, be written using other methods:--1. They can be written directly by importing them from GHC.Tuple.-2. They can be generated by way of Template Haskell or in `deriving` code.--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--------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:--  case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x--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.--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.--}---- | 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].------ 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--      -- function tycon-      "FUN"  -> Just fUNTyConName-      "->"  -> Just unrestrictedFunTyConName--      -- boxed 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)--      -- unboxed tuple data/tycon-      "(##)"  -> Just $ tup_name Unboxed 0-      "Solo#" -> Just $ tup_name Unboxed 1-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (commas, rest') <- BS.span (==',') rest-        , "#)" <- rest'-             -> Just $ tup_name Unboxed (1+BS.length commas)--      -- unboxed sum tycon-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (nb_pipes, rest') <- span_pipes rest-        , "#)" <- rest'-             -> Just $ tyConName $ sumTyCon (1+nb_pipes)--      -- 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-      _ -> Nothing-  where-    name = bytesFS $ occNameFS occ--    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)--    choose_ns :: Name -> Name -> Name-    choose_ns tc dc-      | isTcClsNameSpace ns   = tc-      | isDataConNameSpace ns = dc-      | otherwise             = pprPanic "tup_name" (ppr occ)-      where ns = occNameSpace occ--    tup_name boxity arity-      = choose_ns (getName (tupleTyCon   boxity arity))-                  (getName (tupleDataCon boxity arity))---- 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-isPunOcc_maybe _ _ = Nothing--mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName--- No need to cache these, the caching is done in mk_tuple-mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr ns ar)-mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)--mkCTupleOcc :: NameSpace -> Arity -> OccName-mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)--mkTupleStr :: Boxity -> NameSpace -> Arity -> String-mkTupleStr Boxed   = mkBoxedTupleStr-mkTupleStr Unboxed = const mkUnboxedTupleStr--mkBoxedTupleStr :: NameSpace -> Arity -> String-mkBoxedTupleStr _ 0  = "()"-mkBoxedTupleStr ns 1 | isDataConNameSpace ns = "MkSolo"  -- See Note [One-tuples]-mkBoxedTupleStr _ 1 = "Solo"                             -- See Note [One-tuples]-mkBoxedTupleStr _ ar = '(' : commas ar ++ ")"--mkUnboxedTupleStr :: Arity -> String-mkUnboxedTupleStr 0  = "(##)"-mkUnboxedTupleStr 1  = "Solo#"  -- See Note [One-tuples]-mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)"--mkConstraintTupleStr :: Arity -> String-mkConstraintTupleStr 0  = "(%%)"-mkConstraintTupleStr 1  = "Solo%"   -- See Note [One-tuples]-mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"--commas :: Arity -> String-commas ar = take (ar-1) (repeat ',')--cTupleTyCon :: Arity -> TyCon-cTupleTyCon i-  | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially-  | otherwise           = fstOf3 (cTupleArr ! i)--cTupleTyConName :: Arity -> Name-cTupleTyConName a = tyConName (cTupleTyCon a)--cTupleTyConNames :: [Name]-cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE])--cTupleTyConKeys :: UniqSet Unique-cTupleTyConKeys = mkUniqSet $ map getUnique cTupleTyConNames--isCTupleTyConName :: Name -> Bool-isCTupleTyConName n- = assertPpr (isExternalName n) (ppr n) $-   getUnique n `elementOfUniqSet` 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-  | otherwise           = sndOf3 (cTupleArr ! i)--cTupleDataConName :: Arity -> Name-cTupleDataConName i = dataConName (cTupleDataCon i)--cTupleDataConNames :: [Name]-cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE])--cTupleSelId :: ConTag -- Superclass position-            -> Arity  -- Arity-            -> Id-cTupleSelId sc_pos arity-  | sc_pos > arity-  = panic ("cTupleSelId: index out of bounds: superclass position: "-           ++ show sc_pos ++ " > arity " ++ show arity)--  | sc_pos <= 0-  = panic ("cTupleSelId: Superclass positions start from 1. "-           ++ "(superclass position: " ++ show sc_pos-           ++ ", arity: " ++ show arity ++ ")")--  | arity < 2-  = panic ("cTupleSelId: Arity starts from 2. "-           ++ "(superclass position: " ++ show sc_pos-           ++ ", arity: " ++ show arity ++ ")")--  | arity > mAX_CTUPLE_SIZE-  = thdOf3 (mk_ctuple arity) ! (sc_pos - 1)  -- Build one specially--  | otherwise-  = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1)--cTupleSelIdName :: ConTag -- Superclass position-                -> Arity  -- Arity-                -> Name-cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity)--tupleTyCon :: Boxity -> Arity -> TyCon-tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially-tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)-tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)--tupleTyConName :: TupleSort -> Arity -> Name-tupleTyConName ConstraintTuple a = cTupleTyConName a-tupleTyConName BoxedTuple      a = tyConName (tupleTyCon Boxed a)-tupleTyConName UnboxedTuple    a = tyConName (tupleTyCon Unboxed a)--promotedTupleDataCon :: Boxity -> Arity -> TyCon-promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i)--tupleDataCon :: Boxity -> Arity -> DataCon-tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)    -- Build one specially-tupleDataCon Boxed   i = snd (boxedTupleArr   ! i)-tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)--tupleDataConName :: Boxity -> Arity -> Name-tupleDataConName sort i = dataConName (tupleDataCon sort i)--mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type-mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]--isPromotedPairType :: Type -> Maybe (Type, Type)-isPromotedPairType t-  | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t-  , tc == promotedTupleDataCon Boxed 2-  = Just (x, y)-  | otherwise = Nothing--boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)-boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]-unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]---- | Cached type constructors, data constructors, and superclass selectors for--- constraint tuples. The outer array is indexed by the arity of the constraint--- 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--- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep--- [IntRep, LiftedRep])@-unboxedTupleSumKind :: TyCon -> [Type] -> Kind-unboxedTupleSumKind tc rr_tys-  = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])---- | Specialization of 'unboxedTupleSumKind' for tuples-unboxedTupleKind :: [Type] -> Kind-unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon--mk_tuple :: Boxity -> Int -> (TyCon,DataCon)-mk_tuple Boxed arity = (tycon, tuple_con)-  where-    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con-                         BoxedTuple flavour--    tc_binders  = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)-    tc_res_kind = liftedTypeKind-    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)--    dc_tvs     = binderVars tc_binders-    dc_arg_tys = mkTyVarTys dc_tvs-    tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon--    boxity  = Boxed-    modu    = gHC_TUPLE_PRIM-    tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq-                         (ATyCon tycon) BuiltInSyntax-    dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq-                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax-    tc_uniq = mkTupleTyConUnique   boxity arity-    dc_uniq = mkTupleDataConUnique boxity arity--mk_tuple Unboxed arity = (tycon, tuple_con)-  where-    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con-                         UnboxedTuple flavour--    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2])-    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)-                                        (\ks -> map mkTYPEapp ks)--    tc_res_kind = unboxedTupleKind rr_tys-    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)--    dc_tvs               = binderVars tc_binders-    (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs)-    tuple_con            = pcDataCon dc_name dc_tvs dc_arg_tys tycon--    boxity  = Unboxed-    modu    = gHC_PRIM-    tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq-                         (ATyCon tycon) BuiltInSyntax-    dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq-                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax-    tc_uniq = mkTupleTyConUnique   boxity arity-    dc_uniq = mkTupleDataConUnique boxity arity--mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id)-mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr)-  where-    tycon = mkClassTyCon tc_name binders roles-                         rhs klass-                         (mkPrelTyConRepName tc_name)--    klass     = mk_ctuple_class tycon sc_theta sc_sel_ids-    tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon--    binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)-    roles   = replicate arity Nominal-    rhs     = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple}--    modu    = gHC_CLASSES-    tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq-                         (ATyCon tycon) BuiltInSyntax-    dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq-                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax-    tc_uniq = mkCTupleTyConUnique   arity-    dc_uniq = mkCTupleDataConUnique arity--    tvs            = binderVars binders-    sc_theta       = map mkTyVarTy tvs-    sc_sel_ids     = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]]-    sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids--    mk_sc_sel_id sc_pos =-      let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity-          sc_sel_id_occ  = mkCTupleOcc tcName arity-          sc_sel_id_name = mkWiredInIdName-                             gHC_CLASSES-                             (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ))-                             sc_sel_id_uniq-                             sc_sel_id-          sc_sel_id      = mkDictSelId sc_sel_id_name klass--      in sc_sel_id--unitTyCon :: TyCon-unitTyCon = tupleTyCon Boxed 0--unitTyConKey :: Unique-unitTyConKey = getUnique unitTyCon--unitDataCon :: DataCon-unitDataCon   = head (tyConDataCons unitTyCon)--unitDataConId :: Id-unitDataConId = dataConWorkId unitDataCon--soloTyCon :: TyCon-soloTyCon = tupleTyCon Boxed 1--pairTyCon :: TyCon-pairTyCon = tupleTyCon Boxed 2--unboxedUnitTy :: Type-unboxedUnitTy = mkTyConTy unboxedUnitTyCon--unboxedUnitTyCon :: TyCon-unboxedUnitTyCon = tupleTyCon Unboxed 0--unboxedUnitDataCon :: DataCon-unboxedUnitDataCon = tupleDataCon Unboxed 0--{- *********************************************************************-*                                                                      *-      Unboxed sums-*                                                                      *-********************************************************************* -}---- | OccName for n-ary unboxed sum type constructor.-mkSumTyConOcc :: Arity -> OccName-mkSumTyConOcc n = mkOccName tcName str-  where-    -- No need to cache these, the caching is done in mk_sum-    str = '(' : '#' : ' ' : bars ++ " #)"-    bars = intersperse ' ' $ replicate (n-1) '|'---- | OccName for i-th alternative of n-ary unboxed sum data constructor.-mkSumDataConOcc :: ConTag -> Arity -> OccName-mkSumDataConOcc alt n = mkOccName dataName str-  where-    -- No need to cache these, the caching is done in mk_sum-    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"-    bars i = intersperse ' ' $ replicate i '|'---- | Type constructor for n-ary unboxed sum.-sumTyCon :: Arity -> TyCon-sumTyCon arity-  | arity > mAX_SUM_SIZE-  = fst (mk_sum arity)  -- Build one specially--  | arity < 2-  = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")--  | otherwise-  = fst (unboxedSumArr ! arity)---- | Data constructor for i-th alternative of a n-ary unboxed sum.-sumDataCon :: ConTag -- Alternative-           -> Arity  -- Arity-           -> DataCon-sumDataCon alt arity-  | alt > arity-  = panic ("sumDataCon: index out of bounds: alt: "-           ++ show alt ++ " > arity " ++ show arity)--  | alt <= 0-  = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt-           ++ ", arity: " ++ show arity ++ ")")--  | arity < 2-  = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt-           ++ ", arity: " ++ show arity ++ ")")--  | arity > mAX_SUM_SIZE-  = snd (mk_sum arity) ! (alt - 1)  -- Build one specially--  | otherwise-  = snd (unboxedSumArr ! arity) ! (alt - 1)---- | 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.-unboxedSumArr :: Array Int (TyCon, Array Int DataCon)-unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]---- | Specialization of 'unboxedTupleSumKind' for sums-unboxedSumKind :: [Type] -> Kind-unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon---- | Create type constructor and data constructors for n-ary unboxed sum.-mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)-mk_sum arity = (tycon, sum_cons)-  where-    tycon   = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons)-                         UnboxedSumTyCon--    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)-                                        (\ks -> map mkTYPEapp ks)--    tyvars = binderVars tc_binders--    tc_res_kind = unboxedSumKind rr_tys--    (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars)--    tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq-                            (ATyCon tycon) BuiltInSyntax--    sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]]-    sum_con i = let dc = pcDataCon dc_name-                                   tyvars -- univ tyvars-                                   [tyvar_tys !! i] -- arg types-                                   tycon--                    dc_name = mkWiredInName gHC_PRIM-                                            (mkSumDataConOcc i arity)-                                            (dc_uniq i)-                                            (AConLike (RealDataCon dc))-                                            BuiltInSyntax-                in dc--    tc_uniq   = mkSumTyConUnique   arity-    dc_uniq i = mkSumDataConUnique i arity--{--************************************************************************-*                                                                      *-              Equality types and classes-*                                                                      *-********************************************************************* -}---- See Note [The equality types story] in GHC.Builtin.Types.Prim--- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)------ It's tempting to put functional dependencies on (~~), but it's not--- necessary because the functional-dependency coverage check looks--- through superclasses, and (~#) is handled in that check.--eqTyCon,   heqTyCon,   coercibleTyCon   :: TyCon-eqClass,   heqClass,   coercibleClass   :: Class-eqDataCon, heqDataCon, coercibleDataCon :: DataCon-eqSCSelId, heqSCSelId, coercibleSCSelId :: Id--(eqTyCon, eqClass, eqDataCon, eqSCSelId)-  = (tycon, klass, datacon, sc_sel_id)-  where-    tycon     = mkClassTyCon eqTyConName binders roles-                             rhs klass-                             (mkPrelTyConRepName eqTyConName)-    klass     = mk_class tycon sc_pred sc_sel_id-    datacon   = pcDataConConstraint eqDataConName tvs [sc_pred] tycon--    -- Kind: forall k. k -> k -> Constraint-    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])-    roles     = [Nominal, Nominal, Nominal]-    rhs       = mkDataTyConRhs [datacon]--    tvs@[k,a,b] = binderVars binders-    sc_pred     = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])-    sc_sel_id   = mkDictSelId eqSCSelIdName klass--(heqTyCon, heqClass, heqDataCon, heqSCSelId)-  = (tycon, klass, datacon, sc_sel_id)-  where-    tycon     = mkClassTyCon heqTyConName binders roles-                             rhs klass-                             (mkPrelTyConRepName heqTyConName)-    klass     = mk_class tycon sc_pred sc_sel_id-    datacon   = pcDataConConstraint heqDataConName tvs [sc_pred] tycon--    -- Kind: forall k1 k2. k1 -> k2 -> Constraint-    binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    roles     = [Nominal, Nominal, Nominal, Nominal]-    rhs       = mkDataTyConRhs [datacon]--    tvs       = binderVars binders-    sc_pred   = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)-    sc_sel_id = mkDictSelId heqSCSelIdName klass--(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)-  = (tycon, klass, datacon, sc_sel_id)-  where-    tycon     = mkClassTyCon coercibleTyConName binders roles-                             rhs klass-                             (mkPrelTyConRepName coercibleTyConName)-    klass     = mk_class tycon sc_pred sc_sel_id-    datacon   = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon--    -- Kind: forall k. k -> k -> Constraint-    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])-    roles     = [Nominal, Representational, Representational]-    rhs       = mkDataTyConRhs [datacon]--    tvs@[k,a,b] = binderVars binders-    sc_pred     = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])-    sc_sel_id   = mkDictSelId coercibleSCSelIdName klass--mk_class :: TyCon -> PredType -> Id -> Class-mk_class tycon sc_pred sc_sel_id-  = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]-            [] [] (mkAnd []) tycon--mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class-mk_ctuple_class tycon sc_theta sc_sel_ids-  = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids-            [] [] (mkAnd []) tycon--{- *********************************************************************-*                                                                      *-                Multiplicity Polymorphism-*                                                                      *-********************************************************************* -}--{- Multiplicity polymorphism is implemented very similarly to representation- polymorphism. We write in the multiplicity kind and the One and Many- types which can appear in user programs. These are defined properly in GHC.Types.--data Multiplicity = One | Many--}--multiplicityTyConName :: Name-multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")-                          multiplicityTyConKey multiplicityTyCon--oneDataConName, manyDataConName :: Name-oneDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon-manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon--multiplicityTy :: Type-multiplicityTy = mkTyConTy multiplicityTyCon--multiplicityTyCon :: TyCon-multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []-                            [oneDataCon, manyDataCon]--oneDataCon, manyDataCon :: DataCon-oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon-manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon--oneDataConTy, manyDataConTy :: Type-oneDataConTy = mkTyConTy oneDataConTyCon-manyDataConTy = mkTyConTy manyDataConTyCon--oneDataConTyCon, manyDataConTyCon :: TyCon-oneDataConTyCon = promoteDataCon oneDataCon-manyDataConTyCon = promoteDataCon manyDataCon--multMulTyConName :: Name-multMulTyConName =-    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon--multMulTyCon :: TyCon-multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing-                         (BuiltInSynFamTyCon trivialBuiltInFamily)-                         Nothing-                         NotInjective-  where-    binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy]----------------------------- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).---              TYPE rep1 -> TYPE rep2 -> Type--- type (->) = FUN 'Many-unrestrictedFunTyCon :: TyCon-unrestrictedFunTyCon-  = buildSynTyCon unrestrictedFunTyConName [] arrowKind []-                  (TyCoRep.TyConApp fUNTyCon [manyDataConTy])-  where-    arrowKind = mkTyConKind binders liftedTypeKind-    -- See also funTyCon-    binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)-              , Bndr runtimeRep2TyVar (NamedTCB Inferred) ]-              ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty-                                            , mkTYPEapp runtimeRep2Ty ]--unrestrictedFunTyConName :: Name-unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->")-                                              unrestrictedFunTyConKey unrestrictedFunTyCon---{- *********************************************************************-*                                                                      *-      Type synonyms (all declared in ghc-prim:GHC.Types)--         type CONSTRAINT   :: RuntimeRep -> Type -- primitive; cONSTRAINTKind-         type Constraint   = CONSTRAINT LiftedRep  :: Type    -- constraintKind--         type TYPE         :: RuntimeRep -> Type  -- primitive; tYPEKind-         type Type         = TYPE LiftedRep   :: Type         -- liftedTypeKind-         type UnliftedType = TYPE UnliftedRep :: Type         -- unliftedTypeKind--         type LiftedRep    = BoxedRep Lifted   :: RuntimeRep  -- liftedRepTy-         type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep  -- unliftedRepTy--*                                                                      *-********************************************************************* -}---- For these synonyms, see--- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and--- Note [Using synonyms to compress types] in GHC.Core.Type--{- Note [Naked FunTy]-~~~~~~~~~~~~~~~~~~~~~-GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument-flag and arg/res types.  But when constructing the kinds of tYPETyCon and-cONSTRAINTTyCon we don't want to make these checks because-     TYPE :: RuntimeRep -> Type-i.e. TYPE :: RuntimeRep -> TYPE LiftedRep--so the check will loop infinitely.  Hence the use of a naked FunTy-constructor in tTYPETyCon and cONSTRAINTTyCon.--}---------------------------- type Constraint = CONSTRAINT LiftedRep-constraintKindTyCon :: TyCon-constraintKindTyCon-  = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy]--constraintKindTyConName :: Name-constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")-                                             constraintKindTyConKey constraintKindTyCon--constraintKind :: Kind-constraintKind = mkTyConTy constraintKindTyCon--------------------------- type Type = TYPE LiftedRep-liftedTypeKindTyCon :: TyCon-liftedTypeKindTyCon-  = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]--liftedTypeKindTyConName :: Name-liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")-                                             liftedTypeKindTyConKey liftedTypeKindTyCon--liftedTypeKind, typeToTypeKind :: Type-liftedTypeKind = mkTyConTy liftedTypeKindTyCon-typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind--------------------------- type UnliftedType = TYPE ('BoxedRep 'Unlifted)-unliftedTypeKindTyCon :: TyCon-unliftedTypeKindTyCon-  = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy]--unliftedTypeKindTyConName :: Name-unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType")-                                                unliftedTypeKindTyConKey unliftedTypeKindTyCon--unliftedTypeKind :: Type-unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon---{- *********************************************************************-*                                                                      *-      data Levity = Lifted | Unlifted-*                                                                      *-********************************************************************* -}--levityTyConName, liftedDataConName, unliftedDataConName :: Name-levityTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Levity")   levityTyConKey     levityTyCon-liftedDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted")   liftedDataConKey   liftedDataCon-unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon--levityTyCon :: TyCon-levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]--levityTy :: Type-levityTy = mkTyConTy levityTyCon--liftedDataCon, unliftedDataCon :: DataCon-liftedDataCon = pcSpecialDataCon liftedDataConName-    [] levityTyCon (Levity Lifted)-unliftedDataCon = pcSpecialDataCon unliftedDataConName-    [] levityTyCon (Levity Unlifted)--liftedDataConTyCon :: TyCon-liftedDataConTyCon = promoteDataCon liftedDataCon--unliftedDataConTyCon :: TyCon-unliftedDataConTyCon = promoteDataCon unliftedDataCon--liftedDataConTy :: Type-liftedDataConTy = mkTyConTy liftedDataConTyCon--unliftedDataConTy :: Type-unliftedDataConTy = mkTyConTy unliftedDataConTyCon---{- *********************************************************************-*                                                                      *-    See Note [Wiring in RuntimeRep]-        data RuntimeRep = VecRep VecCount VecElem-                        | TupleRep [RuntimeRep]-                        | SumRep [RuntimeRep]-                        | BoxedRep Levity-                        | IntRep | Int8Rep | ...etc...-*                                                                      *-********************************************************************* -}--{- Note [Wiring in RuntimeRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,-making it a pain to wire in. To ease the pain somewhat, we use lists of-the different bits, like Uniques, Names, DataCons. These lists must be-kept in sync with each other. The rule is this: use the order as declared-in GHC.Types. All places where such lists exist should contain a reference-to this Note, so a search for this Note's name should find all the lists.--See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.--}--runtimeRepTyCon :: TyCon-runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []-    -- Here we list all the data constructors-    -- of the RuntimeRep data type-    (vecRepDataCon : tupleRepDataCon :-     sumRepDataCon : boxedRepDataCon :-     runtimeRepSimpleDataCons)--runtimeRepTy :: Type-runtimeRepTy = mkTyConTy runtimeRepTyCon--runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name-runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon--vecRepDataConName   = mk_runtime_rep_dc_name (fsLit "VecRep")   vecRepDataConKey   vecRepDataCon-tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon-sumRepDataConName   = mk_runtime_rep_dc_name (fsLit "SumRep")   sumRepDataConKey   sumRepDataCon-boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon--mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name-mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc--boxedRepDataCon :: DataCon-boxedRepDataCon = pcSpecialDataCon boxedRepDataConName-  [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)-  where-    -- See Note [Getting from RuntimeRep to PrimRep] in RepType-    prim_rep_fun [lev]-      = case tyConPromDataConInfo (tyConAppTyCon lev) of-          Levity Lifted   -> [LiftedRep]-          Levity Unlifted -> [UnliftedRep]-          _ -> pprPanic "boxedRepDataCon" (ppr lev)-    prim_rep_fun args-      = pprPanic "boxedRepDataCon" (ppr args)---boxedRepDataConTyCon :: TyCon-boxedRepDataConTyCon = promoteDataCon boxedRepDataCon--tupleRepDataCon :: DataCon-tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]-                                   runtimeRepTyCon (RuntimeRep prim_rep_fun)-  where-    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType-    prim_rep_fun [rr_ty_list]-      = concatMap (runtimeRepPrimRep doc) rr_tys-      where-        rr_tys = extractPromotedList rr_ty_list-        doc    = text "tupleRepDataCon" <+> ppr rr_tys-    prim_rep_fun args-      = pprPanic "tupleRepDataCon" (ppr args)--tupleRepDataConTyCon :: TyCon-tupleRepDataConTyCon = promoteDataCon tupleRepDataCon--sumRepDataCon :: DataCon-sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]-                                 runtimeRepTyCon (RuntimeRep prim_rep_fun)-  where-    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType-    prim_rep_fun [rr_ty_list]-      = map slotPrimRep (toList (ubxSumRepType prim_repss))-      where-        rr_tys     = extractPromotedList rr_ty_list-        doc        = text "sumRepDataCon" <+> ppr rr_tys-        prim_repss = map (runtimeRepPrimRep doc) rr_tys-    prim_rep_fun args-      = pprPanic "sumRepDataCon" (ppr args)--sumRepDataConTyCon :: TyCon-sumRepDataConTyCon = promoteDataCon sumRepDataCon---- See Note [Wiring in RuntimeRep]--- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType-runtimeRepSimpleDataCons :: [DataCon]-runtimeRepSimpleDataCons-  = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys-            [ (fsLit "IntRep",    IntRep)-            , (fsLit "Int8Rep",   Int8Rep)-            , (fsLit "Int16Rep",  Int16Rep)-            , (fsLit "Int32Rep",  Int32Rep)-            , (fsLit "Int64Rep",  Int64Rep)-            , (fsLit "WordRep",   WordRep)-            , (fsLit "Word8Rep",  Word8Rep)-            , (fsLit "Word16Rep", Word16Rep)-            , (fsLit "Word32Rep", Word32Rep)-            , (fsLit "Word64Rep", Word64Rep)-            , (fsLit "AddrRep",   AddrRep)-            , (fsLit "FloatRep",  FloatRep)-            , (fsLit "DoubleRep", DoubleRep) ]-  where-    mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon-    mk_runtime_rep_dc uniq (fs, primrep)-      = data_con-      where-        data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))-        dc_name  = mk_runtime_rep_dc_name fs uniq data_con---- See Note [Wiring in RuntimeRep]-intRepDataConTy,-  int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,-  wordRepDataConTy,-  word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,-  addrRepDataConTy,-  floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType-[intRepDataConTy,-   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,-   wordRepDataConTy,-   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,-   addrRepDataConTy,-   floatRepDataConTy, doubleRepDataConTy-   ]-  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons--------------------------- | @type ZeroBitRep = 'Tuple '[]-zeroBitRepTyCon :: TyCon-zeroBitRepTyCon-  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]--zeroBitRepTyConName :: Name-zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")-                                          zeroBitRepTyConKey  zeroBitRepTyCon--zeroBitRepTy :: RuntimeRepType-zeroBitRepTy = mkTyConTy zeroBitRepTyCon--------------------------- @type ZeroBitType = TYPE ZeroBitRep-zeroBitTypeTyCon :: TyCon-zeroBitTypeTyCon-  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]--zeroBitTypeTyConName :: Name-zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")-                                          zeroBitTypeTyConKey zeroBitTypeTyCon--zeroBitTypeKind :: Type-zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon--------------------------- | @type LiftedRep = 'BoxedRep 'Lifted@-liftedRepTyCon :: TyCon-liftedRepTyCon-  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]--liftedRepTyConName :: Name-liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")-                                        liftedRepTyConKey liftedRepTyCon--liftedRepTy :: RuntimeRepType-liftedRepTy = mkTyConTy liftedRepTyCon--------------------------- | @type UnliftedRep = 'BoxedRep 'Unlifted@-unliftedRepTyCon :: TyCon-unliftedRepTyCon-  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]--unliftedRepTyConName :: Name-unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep")-                                          unliftedRepTyConKey unliftedRepTyCon--unliftedRepTy :: RuntimeRepType-unliftedRepTy = mkTyConTy unliftedRepTyCon---{- *********************************************************************-*                                                                      *-         VecCount, VecElem-*                                                                      *-********************************************************************* -}--vecCountTyConName :: Name-vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon--vecElemTyConName :: Name-vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon--vecRepDataCon :: DataCon-vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon-                                                   , mkTyConTy vecElemTyCon ]-                                 runtimeRepTyCon-                                 (RuntimeRep prim_rep_fun)-  where-    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType-    prim_rep_fun [count, elem]-      | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)-      , VecElem  e <- tyConPromDataConInfo (tyConAppTyCon elem)-      = [VecRep n e]-    prim_rep_fun args-      = pprPanic "vecRepDataCon" (ppr args)--vecRepDataConTyCon :: TyCon-vecRepDataConTyCon = promoteDataCon vecRepDataCon--vecCountTyCon :: TyCon-vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons---- See Note [Wiring in RuntimeRep]-vecCountDataCons :: [DataCon]-vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys-  where-    mk_vec_count_dc logN key = con-      where-        n = 2^(logN :: Int)-        name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con-        con = pcSpecialDataCon name [] vecCountTyCon (VecCount n)---- See Note [Wiring in RuntimeRep]-vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,-  vec64DataConTy :: Type-[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,-  vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons--vecElemTyCon :: TyCon-vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons---- See Note [Wiring in RuntimeRep]-vecElemDataCons :: [DataCon]-vecElemDataCons = zipWith3 mk_vec_elem_dc-  [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep"-  , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep"-  , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]-  [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep-  , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep-  , FloatElemRep, DoubleElemRep ]-    vecElemDataConKeys-  where-    mk_vec_elem_dc nameFs elemRep key = con-      where-        name = mk_runtime_rep_dc_name nameFs key con-        con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep)---- See Note [Wiring in RuntimeRep]-int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,-  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,-  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,-  doubleElemRepDataConTy :: Type-[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,-  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,-  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,-  doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)-                                vecElemDataCons--{- *********************************************************************-*                                                                      *-     The boxed primitive types: Char, Int, etc-*                                                                      *-********************************************************************* -}--charTy :: Type-charTy = mkTyConTy charTyCon--charTyCon :: TyCon-charTyCon   = pcTyCon charTyConName-                   (Just (CType NoSourceText Nothing-                                  (NoSourceText,fsLit "HsChar")))-                   [] [charDataCon]-charDataCon :: DataCon-charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon--stringTy :: Type-stringTy = mkTyConTy stringTyCon--stringTyCon :: TyCon--- We have this wired-in so that Haskell literal strings--- get type String (in hsLitType), which in turn influences--- inferred types and error messages-stringTyCon = buildSynTyCon stringTyConName-                            [] liftedTypeKind []-                            (mkListTy charTy)--intTy :: Type-intTy = mkTyConTy intTyCon--intTyCon :: TyCon-intTyCon = pcTyCon intTyConName-               (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))-                 [] [intDataCon]-intDataCon :: DataCon-intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon--wordTy :: Type-wordTy = mkTyConTy wordTyCon--wordTyCon :: TyCon-wordTyCon = pcTyCon wordTyConName-            (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))-               [] [wordDataCon]-wordDataCon :: DataCon-wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon--word8Ty :: Type-word8Ty = mkTyConTy word8TyCon--word8TyCon :: TyCon-word8TyCon = pcTyCon word8TyConName-                     (Just (CType NoSourceText Nothing-                            (NoSourceText, fsLit "HsWord8"))) []-                     [word8DataCon]-word8DataCon :: DataCon-word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon--floatTy :: Type-floatTy = mkTyConTy floatTyCon--floatTyCon :: TyCon-floatTyCon   = pcTyCon floatTyConName-                      (Just (CType NoSourceText Nothing-                             (NoSourceText, fsLit "HsFloat"))) []-                      [floatDataCon]-floatDataCon :: DataCon-floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon--doubleTy :: Type-doubleTy = mkTyConTy doubleTyCon--doubleTyCon :: TyCon-doubleTyCon = pcTyCon doubleTyConName-                      (Just (CType NoSourceText Nothing-                             (NoSourceText,fsLit "HsDouble"))) []-                      [doubleDataCon]--doubleDataCon :: DataCon-doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon--{- *********************************************************************-*                                                                      *-              Boxing data constructors-*                                                                      *-********************************************************************* -}--{- Note [Boxing constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep-that "box" unlifted values into a (boxed, lifted) value of kind Type. For example--  type Int8Box :: TYPE Int8Rep -> Type-  data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a-    -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a--Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`.  We can also-package up a (lifted) Constraint as a value of kind Type.--There are a fixed number of RuntimeReps, so we only need a fixed number-of boxing types.  (For TupleRep we need to box recursively; not yet done,-see #22336.)--This is used:--* In desugaring, when we need to package up a bunch of values into a tuple,-  for example when desugaring arrows.  See Note [Big tuples] in GHC.Core.Make.--* In let-floating when we want to float an unlifted sub-expression.-  See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels--In this module we make wired-in data type declarations for all of-these boxing functions.  The goal is to define boxingDataCon_maybe.--Wrinkles-(W1) The runtime system has special treatment (e.g. commoning up during GC)-     for Int and Char values. See  Note [CHARLIKE and INTLIKE closures] and-     Note [Precomputed static closures] in the RTS.--     So we treat Int# and Char# specially, in specialBoxingDataCon_maybe--}--data BoxingInfo b-  = BI_NoBoxNeeded   -- The type has kind Type, so there is nothing to do--  | BI_NoBoxAvailable  -- The type does not have kind Type, but sadly we-                       -- don't have a boxing data constructor either--  | BI_Box             -- The type does not have kind Type, and we do have a-                       -- boxing data constructor; here it is-      { bi_data_con   :: DataCon-      , bi_inst_con   :: Expr b-      , bi_boxed_type :: Type }-    -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int }-    --        recall: data Int = I# Int#-    ---    --      BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty-    --             , bi_boxed_type = Int8Box ty }A-    --        recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a--boxingDataCon :: Type -> BoxingInfo b--- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that---   will box it, and the type of the boxed thing, which /does/ now have kind Type.--- See Note [Boxing constructors]-boxingDataCon ty-  | tcIsLiftedTypeKind kind-  = BI_NoBoxNeeded    -- Fast path for Type--  | Just box_con <- specialBoxingDataCon_maybe ty-  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con []-           , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) }--  | Just box_con <- lookupTypeMap boxingDataConMap kind-  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty]-           , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] }--  | otherwise-  = BI_NoBoxAvailable--  where-    kind = typeKind ty--specialBoxingDataCon_maybe :: Type -> Maybe DataCon--- ^ See Note [Boxing constructors] wrinkle (W1)-specialBoxingDataCon_maybe ty-  = case splitTyConApp_maybe ty of-      Just (tc, _) | tc `hasKey` intPrimTyConKey  -> Just intDataCon-                   | tc `hasKey` charPrimTyConKey -> Just charDataCon-      _ -> Nothing--boxingDataConMap :: TypeMap DataCon--- See Note [Boxing constructors]-boxingDataConMap = foldl add emptyTypeMap boxingDataCons-  where-    add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con--boxingDataCons :: [(Kind, DataCon)]--- The Kind is the kind of types for which the DataCon is the right boxing-boxingDataCons = zipWith mkBoxingDataCon-  (map mkBoxingTyConUnique [1..])-  [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox")-  , (mkTYPEapp intRepDataConTy,  fsLit "IntBox",  fsLit "MkIntBox")--  , (mkTYPEapp floatRepDataConTy,  fsLit "FloatBox",  fsLit "MkFloatBox")-  , (mkTYPEapp doubleRepDataConTy,  fsLit "DoubleBox",  fsLit "MkDoubleBox")--  , (mkTYPEapp int8RepDataConTy,  fsLit "Int8Box",  fsLit "MkInt8Box")-  , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box")-  , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box")-  , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box")--  , (mkTYPEapp word8RepDataConTy,  fsLit "Word8Box",   fsLit "MkWord8Box")-  , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box",  fsLit "MkWord16Box")-  , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box",  fsLit "MkWord32Box")-  , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box",  fsLit "MkWord64Box")--  , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox")-  , (constraintKind,   fsLit "DictBox", fsLit "MkDictBox") ]--mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon)-mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc)-  = (kind, dc)-  where-    uniq_dc = boxingDataConUnique uniq_tc--    (tv:_) = mkTemplateTyVars (repeat kind)-    tc = pcTyCon tc_name Nothing [tv] [dc]-    tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc--    dc | isConstraintKind kind-       = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc-       | otherwise-       = pcDataCon           dc_name [tv] [mkTyVarTy tv] tc-    dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc--{--************************************************************************-*                                                                      *-              The Bool type-*                                                                      *-************************************************************************--An ordinary enumeration type, but deeply wired in.  There are no-magical operations on @Bool@ (just the regular Prelude code).--{\em BEGIN IDLE SPECULATION BY SIMON}--This is not the only way to encode @Bool@.  A more obvious coding makes-@Bool@ just a boxed up version of @Bool#@, like this:-\begin{verbatim}-type Bool# = Int#-data Bool = MkBool Bool#-\end{verbatim}--Unfortunately, this doesn't correspond to what the Report says @Bool@-looks like!  Furthermore, we get slightly less efficient code (I-think) with this coding. @gtInt@ would look like this:--\begin{verbatim}-gtInt :: Int -> Int -> Bool-gtInt x y = case x of I# x# ->-            case y of I# y# ->-            case (gtIntPrim x# y#) of-                b# -> MkBool b#-\end{verbatim}--Notice that the result of the @gtIntPrim@ comparison has to be turned-into an integer (here called @b#@), and returned in a @MkBool@ box.--The @if@ expression would compile to this:-\begin{verbatim}-case (gtInt x y) of-  MkBool b# -> case b# of { 1# -> e1; 0# -> e2 }-\end{verbatim}--I think this code is a little less efficient than the previous code,-but I'm not certain.  At all events, corresponding with the Report is-important.  The interesting thing is that the language is expressive-enough to describe more than one alternative; and that a type doesn't-necessarily need to be a straightforwardly boxed version of its-primitive counterpart.--{\em END IDLE SPECULATION BY SIMON}--}--boolTy :: Type-boolTy = mkTyConTy boolTyCon--boolTyCon :: TyCon-boolTyCon = pcTyCon boolTyConName-                    (Just (CType NoSourceText Nothing-                           (NoSourceText, fsLit "HsBool")))-                    [] [falseDataCon, trueDataCon]--falseDataCon, trueDataCon :: DataCon-falseDataCon = pcDataCon falseDataConName [] [] boolTyCon-trueDataCon  = pcDataCon trueDataConName  [] [] boolTyCon--falseDataConId, trueDataConId :: Id-falseDataConId = dataConWorkId falseDataCon-trueDataConId  = dataConWorkId trueDataCon--orderingTyCon :: TyCon-orderingTyCon = pcTyCon orderingTyConName Nothing-                        [] [ordLTDataCon, ordEQDataCon, ordGTDataCon]--ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon-ordLTDataCon = pcDataCon ordLTDataConName  [] [] orderingTyCon-ordEQDataCon = pcDataCon ordEQDataConName  [] [] orderingTyCon-ordGTDataCon = pcDataCon ordGTDataConName  [] [] orderingTyCon--ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id-ordLTDataConId = dataConWorkId ordLTDataCon-ordEQDataConId = dataConWorkId ordEQDataCon-ordGTDataConId = dataConWorkId ordGTDataCon--{--************************************************************************-*                                                                      *-            The List type-   Special syntax, deeply wired in,-   but otherwise an ordinary algebraic data type-*                                                                      *-************************************************************************--       data [] a = [] | a : (List a)--}--mkListTy :: Type -> Type-mkListTy ty = mkTyConApp listTyCon [ty]--listTyCon :: TyCon-listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon]---- See also Note [Empty lists] in GHC.Hs.Expr.-nilDataCon :: DataCon-nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon--consDataCon :: DataCon-consDataCon = pcDataConWithFixity True {- Declared infix -}-               consDataConName-               alpha_tyvar [] alpha_tyvar []-               (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])-               listTyCon---- Interesting: polymorphic recursion would help here.--- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy--- gets the over-specific type (Type -> Type)---- Wired-in type Maybe--maybeTyCon :: TyCon-maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar-                     [nothingDataCon, justDataCon]--nothingDataCon :: DataCon-nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon--justDataCon :: DataCon-justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon--mkPromotedMaybeTy :: Kind -> Maybe Type -> Type-mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]-mkPromotedMaybeTy k Nothing  = mkTyConApp promotedNothingDataCon [k]--mkMaybeTy :: Type -> Kind-mkMaybeTy t = mkTyConApp maybeTyCon [t]--isPromotedMaybeTy :: Type -> Maybe (Maybe Type)-isPromotedMaybeTy t-  | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x-  | Just (tc,[_])   <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing-  | otherwise = Nothing---{--** *********************************************************************-*                                                                      *-            The tuple types-*                                                                      *-************************************************************************--The tuple types are definitely magic, because they form an infinite-family.--\begin{itemize}-\item-They have a special family of type constructors, of type @TyCon@-These contain the tycon arity, but don't require a Unique.--\item-They have a special family of constructors, of type-@Id@. Again these contain their arity but don't need a Unique.--\item-There should be a magic way of generating the info tables and-entry code for all tuples.--But at the moment we just compile a Haskell source-file\srcloc{lib/prelude/...} containing declarations like:-\begin{verbatim}-data Tuple0             = Tup0-data Tuple2  a b        = Tup2  a b-data Tuple3  a b c      = Tup3  a b c-data Tuple4  a b c d    = Tup4  a b c d-...-\end{verbatim}-The print-names associated with the magic @Id@s for tuple constructors-``just happen'' to be the same as those generated by these-declarations.--\item-The instance environment should have a magic way to know-that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and-so on. \ToDo{Not implemented yet.}--\item-There should also be a way to generate the appropriate code for each-of these instances, but (like the info tables and entry code) it is-done by enumeration\srcloc{lib/prelude/InTup?.hs}.-\end{itemize}--}---- | Make a tuple type. The list of types should /not/ include any--- RuntimeRep specifications. Boxed 1-tuples are flattened.--- See Note [One-tuples]-mkTupleTy :: Boxity -> [Type] -> Type--- Special case for *boxed* 1-tuples, which are represented by the type itself-mkTupleTy Boxed   [ty] = ty-mkTupleTy boxity  tys  = mkTupleTy1 boxity tys---- | Make a tuple type. The list of types should /not/ include any--- RuntimeRep specifications. Boxed 1-tuples are *not* flattened.--- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn]--- in "GHC.Core.Make"-mkTupleTy1 :: Boxity -> [Type] -> Type-mkTupleTy1 Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys-mkTupleTy1 Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))-                                     (map getRuntimeRep tys ++ tys)---- | Build the type of a small tuple that holds the specified type of thing--- Flattens 1-tuples. See Note [One-tuples].-mkBoxedTupleTy :: [Type] -> Type-mkBoxedTupleTy tys = mkTupleTy Boxed tys--unitTy :: Type-unitTy = mkTupleTy Boxed []---- Make a constraint tuple, flattening a 1-tuple as usual--- If we get a constraint tuple that is bigger than the pre-built---   ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't---   have an info table in the RTS, so we can't use it at runtime.  But---   this is used only in filling in extra-constraint wildcards, so it---   never is used at runtime anyway---   See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures]-mkConstraintTupleTy :: [Type] -> Type-mkConstraintTupleTy [ty] = ty-mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys---{- *********************************************************************-*                                                                      *-            The sum types-*                                                                      *-************************************************************************--}--mkSumTy :: [Type] -> Type-mkSumTy tys = mkTyConApp (sumTyCon (length tys))-                         (map getRuntimeRep tys ++ tys)---- Promoted Booleans--promotedFalseDataCon, promotedTrueDataCon :: TyCon-promotedTrueDataCon   = promoteDataCon trueDataCon-promotedFalseDataCon  = promoteDataCon falseDataCon---- Promoted Maybe-promotedNothingDataCon, promotedJustDataCon :: TyCon-promotedNothingDataCon = promoteDataCon nothingDataCon-promotedJustDataCon    = promoteDataCon justDataCon---- Promoted Ordering--promotedLTDataCon-  , promotedEQDataCon-  , promotedGTDataCon-  :: TyCon-promotedLTDataCon     = promoteDataCon ordLTDataCon-promotedEQDataCon     = promoteDataCon ordEQDataCon-promotedGTDataCon     = promoteDataCon ordGTDataCon---- Promoted List-promotedConsDataCon, promotedNilDataCon :: TyCon-promotedConsDataCon   = promoteDataCon consDataCon-promotedNilDataCon    = promoteDataCon nilDataCon---- | Make a *promoted* list.-mkPromotedListTy :: Kind   -- ^ of the elements of the list-                 -> [Type] -- ^ elements-                 -> Type-mkPromotedListTy k tys-  = foldr cons nil tys-  where-    cons :: Type  -- element-         -> Type  -- list-         -> Type-    cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]--    nil :: Type-    nil = mkTyConApp promotedNilDataCon [k]---- | Extract the elements of a promoted list. Panics if the type is not a--- promoted list-extractPromotedList :: Type    -- ^ The promoted list-                    -> [Type]-extractPromotedList tys = go tys-  where-    go list_ty-      | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty-      = assert (tc `hasKey` consDataConKey) $-        t : go ts--      | Just (tc, [_k]) <- splitTyConApp_maybe list_ty-      = assert (tc `hasKey` nilDataConKey)-        []--      | otherwise-      = pprPanic "extractPromotedList" (ppr tys)-------------------------------------------- ghc-bignum------------------------------------------integerTyConName-   , integerISDataConName-   , integerIPDataConName-   , integerINDataConName-   :: Name-integerTyConName-   = mkWiredInTyConName-      UserSyntax-      gHC_NUM_INTEGER-      (fsLit "Integer")-      integerTyConKey-      integerTyCon-integerISDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_INTEGER-      (fsLit "IS")-      integerISDataConKey-      integerISDataCon-integerIPDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_INTEGER-      (fsLit "IP")-      integerIPDataConKey-      integerIPDataCon-integerINDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_INTEGER-      (fsLit "IN")-      integerINDataConKey-      integerINDataCon--integerTy :: Type-integerTy = mkTyConTy integerTyCon--integerTyCon :: TyCon-integerTyCon = pcTyCon integerTyConName Nothing []-                  [integerISDataCon, integerIPDataCon, integerINDataCon]--integerISDataCon :: DataCon-integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon--integerIPDataCon :: DataCon-integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon--integerINDataCon :: DataCon-integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon--naturalTyConName-   , naturalNSDataConName-   , naturalNBDataConName-   :: Name-naturalTyConName-   = mkWiredInTyConName-      UserSyntax-      gHC_NUM_NATURAL-      (fsLit "Natural")-      naturalTyConKey-      naturalTyCon-naturalNSDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_NATURAL-      (fsLit "NS")-      naturalNSDataConKey-      naturalNSDataCon-naturalNBDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_NATURAL-      (fsLit "NB")-      naturalNBDataConKey-      naturalNBDataCon--naturalTy :: Type-naturalTy = mkTyConTy naturalTyCon--naturalTyCon :: TyCon-naturalTyCon = pcTyCon naturalTyConName Nothing []-                  [naturalNSDataCon, naturalNBDataCon]--naturalNSDataCon :: DataCon-naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon--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+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module is about types that can be defined in Haskell, but which+--   must be wired into the compiler nonetheless.  C.f module "GHC.Builtin.Types.Prim"+module GHC.Builtin.Types (+        -- * Helper functions defined here+        mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the+                            -- built-in functions for evaluation.++        mkWiredInIdName,    -- used in GHC.Types.Id.Make++        -- * All wired in things+        wiredInTyCons, isBuiltInOcc, isBuiltInOcc_maybe,+        isTupleTyOrigName_maybe, isSumTyOrigName_maybe,+        isInfiniteFamilyOrigName_maybe,++        -- * Bool+        boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,+        trueDataCon,  trueDataConId,  true_RDR,+        falseDataCon, falseDataConId, false_RDR,+        promotedFalseDataCon, promotedTrueDataCon,++        -- * Ordering+        orderingTyCon,+        ordLTDataCon, ordLTDataConId,+        ordEQDataCon, ordEQDataConId,+        ordGTDataCon, ordGTDataConId,+        promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,++        -- * Boxing primitive types+        boxingDataCon, BoxingInfo(..),++        -- * Char+        charTyCon, charDataCon, charTyCon_RDR,+        charTy, stringTy, charTyConName, stringTyCon_RDR,++        -- * Double+        doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,++        -- * Float+        floatTyCon, floatDataCon, floatTy, floatTyConName,++        -- * Int+        intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,+        intTy,++        -- * Word+        wordTyCon, wordDataCon, wordTyConName, wordTy,++        -- * Word8+        word8TyCon, word8DataCon, word8Ty,++        -- * List+        listTyCon, listTyCon_RDR, listTyConName, listTyConKey,+        nilDataCon, nilDataConName, nilDataConKey,+        consDataCon_RDR, consDataCon, consDataConName,+        promotedNilDataCon, promotedConsDataCon,+        mkListTy, mkPromotedListTy, extractPromotedList,++        -- * Maybe+        maybeTyCon, maybeTyConName,+        nothingDataCon, nothingDataConName, promotedNothingDataCon,+        justDataCon, justDataConName, promotedJustDataCon,+        mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,++        -- * Tuples+        mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,+        tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,+        promotedTupleDataCon,+        unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,+        soloTyCon,+        soloDataConName,+        pairTyCon, mkPromotedPairTy, isPromotedPairType,+        unboxedUnitTy,+        unboxedUnitTyCon, unboxedUnitDataCon,+        unboxedSoloTyCon, unboxedSoloTyConName, unboxedSoloDataConName,+        unboxedTupleKind, unboxedSumKind,+        mkConstraintTupleTy,++        -- ** Constraint tuples+        cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,+        cTupleDataCon, cTupleDataConName, cTupleDataConNames,+        cTupleSelId, cTupleSelIdName,++        -- * Any+        anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon,++        -- * Recovery TyCon+        makeRecoveryTyCon,++        -- * Sums+        mkSumTy, sumTyCon, sumDataCon,+        unboxedSumTyConName, unboxedSumDataConName,++        -- * Kinds+        typeSymbolKindCon, typeSymbolKind,+        isLiftedTypeKindTyConName,+        typeToTypeKind,+        liftedRepTyCon, unliftedRepTyCon,+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind,+        constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind,+        constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,+        constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,+        liftedRepTyConName, unliftedRepTyConName,++        -- * Equality predicates+        heqTyCon, heqTyConName, heqClass, heqDataCon,+        eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,+        coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,++        -- * RuntimeRep and friends+        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,++        boxedRepDataConTyCon,+        runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,++        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,++        -- * Levity+        levityTyCon, levityTy,+        liftedDataConTyCon, unliftedDataConTyCon,+        liftedDataConTy,    unliftedDataConTy,++        intRepDataConTy,+        int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+        wordRepDataConTy,+        word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+        addrRepDataConTy,+        floatRepDataConTy, doubleRepDataConTy,++        vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+        vec64DataConTy,++        int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+        int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+        word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,++        doubleElemRepDataConTy,++        -- * Multiplicity and friends+        multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy,+        multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy,+        oneDataConTyCon, manyDataConTyCon,+        multMulTyCon,++        unrestrictedFunTyCon, unrestrictedFunTyConName,++        -- * Bignum+        integerTy, integerTyCon, integerTyConName,+        integerISDataCon, integerISDataConName,+        integerIPDataCon, integerIPDataConName,+        integerINDataCon, integerINDataConName,+        naturalTy, naturalTyCon, naturalTyConName,+        naturalNSDataCon, naturalNSDataConName,+        naturalNBDataCon, naturalNBDataConName,++         pretendNameIsInScope,+    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )++-- friends:+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Builtin.Uniques++-- others:+import GHC.Core( Expr(Type), mkConApp )+import GHC.Core.Coercion.Axiom+import GHC.Core.Type+import GHC.Types.Id+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Class     ( Class, mkClass )+import GHC.Core.Map.Type  ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )+import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) )++import GHC.Types.TyThing+import GHC.Types.SourceText+import GHC.Types.Var ( VarBndr (Bndr), tyVarName )+import GHC.Types.RepType+import GHC.Types.Name.Reader+import GHC.Types.Name as Name+import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv )+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique.Set++import {-# SOURCE #-} GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum )+import {-# SOURCE #-} GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars, noConcreteTyVars )++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 )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Short.Internal as SBS (unsafeIndex)++import Data.Foldable+import Data.List        ( intersperse )+import Numeric          ( showInt )++import Data.Word (Word8)+import Control.Applicative ((<|>))++alpha_tyvar :: [TyVar]+alpha_tyvar = [alphaTyVar]++alpha_ty :: [Type]+alpha_ty = [alphaTy]++{-+Note [Wired-in Types and Type Constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This module include a lot of wired-in types and type constructors. Here,+these are presented in a tabular format to make it easier to find the+wired-in type identifier corresponding to a known Haskell type. Data+constructors are nested under their corresponding types with two spaces+of indentation.++Identifier              Type    Haskell name          Notes+----------------------------------------------------------------------------+liftedTypeKindTyCon     TyCon   GHC.Types.Type        Synonym for: TYPE LiftedRep+unliftedTypeKindTyCon   TyCon   GHC.Types.Type        Synonym for: TYPE UnliftedRep+liftedRepTyCon          TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Lifted+unliftedRepTyCon        TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Unlifted+levityTyCon             TyCon   GHC.Types.Levity      Data type+  liftedDataConTyCon    TyCon   GHC.Types.Lifted      Data constructor+  unliftedDataConTyCon  TyCon   GHC.Types.Unlifted    Data constructor+vecCountTyCon           TyCon   GHC.Types.VecCount    Data type+  vec2DataConTy         Type    GHC.Types.Vec2        Data constructor+  vec4DataConTy         Type    GHC.Types.Vec4        Data constructor+  vec8DataConTy         Type    GHC.Types.Vec8        Data constructor+  vec16DataConTy        Type    GHC.Types.Vec16       Data constructor+  vec32DataConTy        Type    GHC.Types.Vec32       Data constructor+  vec64DataConTy        Type    GHC.Types.Vec64       Data constructor+runtimeRepTyCon         TyCon   GHC.Types.RuntimeRep  Data type+  boxedRepDataConTyCon  TyCon   GHC.Types.BoxedRep    Data constructor+  intRepDataConTy       Type    GHC.Types.IntRep      Data constructor+  doubleRepDataConTy    Type    GHC.Types.DoubleRep   Data constructor+  floatRepDataConTy     Type    GHC.Types.FloatRep    Data constructor+boolTyCon               TyCon   GHC.Types.Bool        Data type+  trueDataCon           DataCon GHC.Types.True        Data constructor+  falseDataCon          DataCon GHC.Types.False       Data constructor+  promotedTrueDataCon   TyCon   GHC.Types.True        Data constructor+  promotedFalseDataCon  TyCon   GHC.Types.False       Data constructor++************************************************************************+*                                                                      *+\subsection{Wired in type constructors}+*                                                                      *+************************************************************************++If you change which things are wired in, make sure you change their+names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc++-}+++-- 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 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+             ++ [ anyTyCon+                , zonkAnyTyCon+                , boolTyCon+                , charTyCon+                , stringTyCon+                , doubleTyCon+                , floatTyCon+                , intTyCon+                , wordTyCon+                , listTyCon+                , orderingTyCon+                , maybeTyCon+                , heqTyCon+                , eqTyCon+                , coercibleTyCon+                , typeSymbolKindCon+                , runtimeRepTyCon+                , levityTyCon+                , vecCountTyCon+                , vecElemTyCon+                , constraintKindTyCon+                , liftedTypeKindTyCon+                , unliftedTypeKindTyCon+                , unrestrictedFunTyCon+                , multiplicityTyCon+                , naturalTyCon+                , integerTyCon+                , liftedRepTyCon+                , unliftedRepTyCon+                , zeroBitRepTyCon+                , zeroBitTypeTyCon+                ]++mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name+mkWiredInTyConName built_in modu fs unique tycon+  = mkWiredInName modu (mkTcOccFS fs) unique+                  (ATyCon tycon)        -- Relevant TyCon+                  built_in++mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name+mkWiredInDataConName built_in modu fs unique datacon+  = mkWiredInName modu (mkDataOccFS fs) unique+                  (AConLike (RealDataCon datacon))    -- Relevant DataCon+                  built_in++mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name+mkWiredInIdName mod fs uniq id+ = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+eqTyConName, eqDataConName, eqSCSelIdName :: Name+eqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~")   eqTyConKey   eqTyCon+eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon+eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId++eqTyCon_RDR :: RdrName+eqTyCon_RDR = nameRdrName eqTyConName++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+heqTyConName, heqDataConName, heqSCSelIdName :: Name+heqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~~")   heqTyConKey      heqTyCon+heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon+heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId++-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs+coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name+coercibleTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Coercible")  coercibleTyConKey   coercibleTyCon+coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon+coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId++charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name+charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char")   charTyConKey charTyCon+charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#")     charDataConKey charDataCon+stringTyConName   = mkWiredInTyConName   UserSyntax gHC_INTERNAL_BASE  (fsLit "String") stringTyConKey stringTyCon+intTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int")    intTyConKey   intTyCon+intDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#")     intDataConKey  intDataCon++boolTyConName, falseDataConName, trueDataConName :: Name+boolTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon+falseDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon+trueDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True")  trueDataConKey  trueDataCon++listTyConName, nilDataConName, consDataConName :: Name+listTyConName     = mkWiredInTyConName   UserSyntax    gHC_TYPES (fsLit "List") listTyConKey listTyCon+nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon+consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon++maybeTyConName, nothingDataConName, justDataConName :: Name+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_INTERNAL_MAYBE (fsLit "Maybe")+                                          maybeTyConKey maybeTyCon+nothingDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Nothing")+                                          nothingDataConKey nothingDataCon+justDataConName    = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Just")+                                          justDataConKey justDataCon++wordTyConName, wordDataConName, word8DataConName :: Name+wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon+wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon+word8DataConName   = mkWiredInDataConName UserSyntax gHC_INTERNAL_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon++floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name+floatTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Float")  floatTyConKey    floatTyCon+floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#")     floatDataConKey  floatDataCon+doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey   doubleTyCon+doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")     doubleDataConKey doubleDataCon++-- Any++{-+Note [Any types]+~~~~~~~~~~~~~~~~+The type constructors `Any` and `ZonkAny` are closed type families declared thus:++    type family Any     :: forall k.        k where { }+    type family ZonkAny :: forall k. Nat -> k where { }++They are used when we want a type of a particular kind, but we don't really care+what that type is.  The leading example is this: `ZonkAny` is used to instantiate+un-constrained type variables after type checking. For example, consider the+term (length [] :: Int), where++  length :: forall a. [a] -> Int+  []     :: forall a. [a]++We must type-apply `length` and `[]`, but to what type? It doesn't matter!+The typechecker will end up with++  length @alpha ([] @alpha)++where `alpha` is an un-constrained unification variable.  The "zonking" process zaps+that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is+arbitrary (see wrinkle (Any5) below).  This is done in `GHC.Tc.Zonk.Type.commitFlexi`.+So we end up with++  length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3))++`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see+wrinkle (Any4).++Wrinkles:++(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may+   need to use `ZonkAny` to fill in a type variable of some kind other than *+   (see #959 for examples).++(Any2) They are /closed/ type families, with no instances.  For example, suppose that+   with  alpha :: '(k1, k2)  we add a given coercion+             g :: alpha ~ (Fst alpha, Snd alpha)+   and we zonked alpha = ZonkAny @(k1,k2) n.  Then, if `ZonkAny` was a /data/ type,+   we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one+   side and '(,) on the other. See also #9097 and #9636.++   See #25244 for a suggestion that we instead use an /open/ type family for which+   you cannot provide instances.  Probably the difference is not very important.++(Any3) They do not claim to be /data/ types, and that's important for+   the code generator, because the code gen may /enter/ a data value+   but never enters a function value.++(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/+   types (#24817).  Consider++     data SBool a where { STrue :: SBool True; SFalse :: SBool False }++     foo :: forall a b. (SBool a, SBool b)++     bar :: Bool+     bar = case foo @alpha @beta of+             (STrue, SFalse) -> True   -- This branch is not inaccessible!+             _               -> False++   Now, what are `alpha` and `beta`? If we zonk both of them to the same type+   `Any @Type`, the pattern-match checker will (wrongly) report that the first+   branch is inaccessible.  So we zonk them to two /different/ types:+       alpha :=  ZonkAny @Type 4   and   beta :=  ZonkAny @Type k 5+   (The actual numbers are arbitrary; they just need to differ.)++   The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and+   `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to+   make up a fresh type.++   If this example seems unconvincing (e.g. in this case foo must be bottom)+   see #24817 for larger but more compelling examples.++(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we+    don't have a name environment (e.g. see Rules.matchRule for one example)++(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that+    it is available to users.  For this reason it's treated like any other+    wired-in type:+      - has a fixed unique, anyTyConKey,+      - lives in the global name cache+    Currently `ZonkAny` is not available to users; but it could easily be.++(Any7) Properties of `Any`:+  * When `Any` is instantiated at a lifted type it is inhabited by at least one value,+    namely bottom.++  * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`.++  * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`.++  * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when+    the kinds of both the type and `Any` match.++  * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over+    `unsafeCoerce#` as they prevent accidentally coercing between types with kinds+    that don't match.++    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.+-}+++anyTyConName :: Name+anyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon++anyTyCon :: TyCon+-- See Note [Any types]+anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]+    res_kind = mkTyVarTy (binderVar kv)++anyTy :: Type+anyTy = mkTyConTy anyTyCon++anyTypeOfKind :: Kind -> Type+anyTypeOfKind kind = mkTyConApp anyTyCon [kind]++zonkAnyTyConName :: Name+zonkAnyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon++zonkAnyTyCon :: TyCon+-- ZonkAnyTyCon :: forall k. Nat -> k+-- See Note [Any types]+zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName+                         [ mkNamedTyConBinder Specified kv+                         , mkAnonTyConBinder nat_kv ]+                         (mkTyVarTy kv)+                         Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy]++-- | Make a fake, recovery 'TyCon' from an existing one.+-- Used when recovering from errors in type declarations+makeRecoveryTyCon :: TyCon -> TyCon+makeRecoveryTyCon tc+  = mkTcTyCon (tyConName tc)+              bndrs res_kind+              noTcTyConScopedTyVars+              True             -- Fully generalised+              flavour          -- Keep old flavour+  where+    flavour = tyConFlavour tc+    [kv] = mkTemplateKindVars [liftedTypeKind]+    (bndrs, res_kind)+       = case flavour of+           PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv)+           _ -> (tyConBinders tc, tyConResKind tc)+        -- For data types we have already validated their kind, so it+        -- makes sense to keep it. For promoted data constructors we haven't,+        -- so we recover with kind (forall k. k).  Otherwise consider+        --     data T a where { MkT :: Show a => T a }+        -- If T is for some reason invalid, we don't want to fall over+        -- at (promoted) use-sites of MkT.++-- Kinds+typeSymbolKindConName :: Name+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon+++boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName+boolTyCon_RDR   = nameRdrName boolTyConName+false_RDR       = nameRdrName falseDataConName+true_RDR        = nameRdrName trueDataConName+intTyCon_RDR    = nameRdrName intTyConName+charTyCon_RDR   = nameRdrName charTyConName+stringTyCon_RDR = nameRdrName stringTyConName+intDataCon_RDR  = nameRdrName intDataConName+listTyCon_RDR   = nameRdrName listTyConName+consDataCon_RDR = nameRdrName consDataConName++{-+************************************************************************+*                                                                      *+\subsection{mkWiredInTyCon}+*                                                                      *+************************************************************************+-}++-- This function assumes that the types it creates have all parameters at+-- Representational role, and that there is no kind polymorphism.+pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon+pcTyCon name cType tyvars cons+  = mkAlgTyCon name+                (mkAnonTyConBinders tyvars)+                liftedTypeKind+                (map (const Representational) tyvars)+                cType+                []              -- No stupid theta+                (mkDataTyConRhs cons)+                (VanillaAlgTyCon (mkPrelTyConRepName name))+                False           -- Not in GADT syntax++pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon+pcDataCon n univs tys+  = pcRepPolyDataCon n univs noConcreteTyVars tys++pcRepPolyDataCon :: Name -> [TyVar] -> ConcreteTyVars+                 -> [Type] -> TyCon -> DataCon+pcRepPolyDataCon n univs conc_tvs tys+  = pcDataConWithFixity False n+      univs+      []    -- no ex_tvs+      conc_tvs+      univs -- the univs are precisely the user-written tyvars+      []    -- No theta+      (map linear tys)++pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon+-- Used for data constructors whose arguments are all constraints.+-- Notably constraint tuples, Eq# etc.+pcDataConConstraint n univs theta+  = pcDataConWithFixity False n+      univs+      []           -- No ex_tvs+      noConcreteTyVars+      univs        -- The univs are precisely the user-written tyvars+      theta        -- All constraint arguments+      []           -- No value arguments++-- Used for RuntimeRep and friends; things with PromDataConInfo+pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon+pcSpecialDataCon dc_name arg_tys tycon rri+  = pcDataConWithFixity' False dc_name+                         (dataConWorkerUnique (nameUnique dc_name)) rri+                         [] [] noConcreteTyVars [] [] (map linear arg_tys) tycon++pcDataConWithFixity :: Bool      -- ^ declared infix?+                    -> Name      -- ^ datacon name+                    -> [TyVar]   -- ^ univ tyvars+                    -> [TyCoVar] -- ^ ex tycovars+                    -> ConcreteTyVars+                                 -- ^ concrete tyvars+                    -> [TyCoVar] -- ^ user-written tycovars+                    -> ThetaType+                    -> [Scaled Type]    -- ^ args+                    -> TyCon+                    -> DataCon+pcDataConWithFixity infx n = pcDataConWithFixity' infx n+                                 (dataConWorkerUnique (nameUnique n)) NoPromInfo+-- The Name's unique is the first of two free uniques;+-- the first is used for the datacon itself,+-- the second is used for the "worker name"+--+-- To support this the mkPreludeDataConUnique function "allocates"+-- one DataCon unique per pair of Ints.++pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo+                     -> [TyVar] -> [TyCoVar]+                     -> ConcreteTyVars+                     -> [TyCoVar]+                     -> ThetaType -> [Scaled Type] -> TyCon -> DataCon+-- The Name should be in the DataName name space; it's the name+-- of the DataCon itself.+--+-- IMPORTANT NOTE:+--    if you try to wire-in a /GADT/ data constructor you will+--    find it hard (we did).  You will need wrapper and worker+--    Names, a DataConBoxer, DataConRep, EqSpec, etc.+--    Try hard not to wire-in GADT data types. You will live+--    to regret doing so (we do).++pcDataConWithFixity' declared_infix dc_name wrk_key rri+                     tyvars ex_tyvars conc_tyvars user_tyvars theta arg_tys tycon+  = data_con+  where+    tag_map = mkTyConTagMap tycon+    -- This constructs the constructor Name to ConTag map once per+    -- constructor, which is quadratic. It's OK here, because it's+    -- only called for wired in data types that don't have a lot of+    -- constructors. It's also likely that GHC will lift tag_map, since+    -- we call pcDataConWithFixity' with static TyCons in the same module.+    -- 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 Specified user_tyvars)+                []      -- No equality spec+                theta+                arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))+                rri+                tycon+                (lookupNameEnv_NF tag_map dc_name)+                []      -- No stupid theta+                (mkDataConWorkId wrk_name data_con)+                NoDataConRep    -- Wired-in types are too simple to need wrappers++    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict++    wrk_name = mkDataConWorkerName data_con wrk_key++    prom_info = mkPrelTyConRepName dc_name++mkDataConWorkerName :: DataCon -> Unique -> Name+mkDataConWorkerName data_con wrk_key =+    mkWiredInName modu wrk_occ wrk_key+                  (AnId (dataConWorkId data_con)) UserSyntax+  where+    modu     = assert (isExternalName dc_name) $+               nameModule dc_name+    dc_name = dataConName data_con+    dc_occ  = nameOccName dc_name+    wrk_occ = mkDataConWorkerOcc dc_occ+++{-+************************************************************************+*                                                                      *+              Symbol+*                                                                      *+************************************************************************+-}++typeSymbolKindCon :: TyCon+-- data Symbol+typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []++typeSymbolKind :: Kind+typeSymbolKind = mkTyConTy typeSymbolKindCon+++{-+************************************************************************+*                                                                      *+                Stuff for dealing with tuples+*                                                                      *+************************************************************************++Note [How tuples work]+~~~~~~~~~~~~~~~~~~~~~~+* There are three families of tuple TyCons and corresponding+  DataCons, expressed by the type BasicTypes.TupleSort:+    data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple++* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon++* BoxedTuples+    - A wired-in type+    - Data type declarations in GHC.Tuple+    - The data constructors really have an info table++* UnboxedTuples+    - A wired-in type+    - Data type declarations in GHC.Types+      but no actual declaration and no info table++* ConstraintTuples+    - A wired-in type.+    - Declared as classes in GHC.Classes, e.g.+         class (c1,c2) => CTuple2 c1 c2+    - Given constraints: the superclasses automatically become available+    - Wanted constraints: there is a built-in instance+         instance (c1,c2) => CTuple2 c1 c2+      See GHC.Tc.Instance.Class.matchCTuple+    - Currently just go up to 64; beyond that+      you have to use manual nesting+    - Unlike BoxedTuples and UnboxedTuples, which only wire+      in type constructors and data constructors, ConstraintTuples also wire in+      superclass selector functions. For instance, $p1CTuple2 and $p2CTuple2 are+      the selectors for the binary constraint tuple.+    - The parenthesis syntax for grouping constraints in contexts is not treated+      as a constraint tuple. The parser starts with a tuple type, then a+      postprocessing action extracts the individual constraints as a list and+      stores them in the context field of types like HsQualTy.++* In quite a lot of places things are restricted just to+  BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish+  E.g. tupleTyCon has a Boxity argument++* When looking up an OccName in the original-name cache+  (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+  deserialization we lookup the Name associated with the unique with the logic+  in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details.++See also Note [Known-key names] in GHC.Builtin.Names.++Note [One-tuples]+~~~~~~~~~~~~~~~~~+GHC supports both boxed and unboxed one-tuples:+ - Unboxed one-tuples are sometimes useful when returning a+   single value after CPR analysis+ - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when+   there is just one binder+Basically it keeps everything uniform.++However the /naming/ of the type/data constructors for one-tuples is a+bit odd:+  3-tuples:  Tuple3   (,,)#+  2-tuples:  Tuple2   (,)#+  1-tuples:  ??+  0-tuples:  Unit     ()#++Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#'+for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:+  data Unit = ()+  data Solo a = MkSolo a+  data Tuple2 a b = (a,b)++There is no way to write a boxed one-tuple in Haskell using tuple syntax.+They can, however, be written using other methods:++1. They can be written directly by importing them from GHC.Tuple.+2. They can be generated by way of Template Haskell or in `deriving` code.++There is nothing special about one-tuples in Core; in particular, they have no+custom pretty-printing, just using `Solo`.++See also Note [Flattening one-tuples] in GHC.Core.Make and+Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.++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.++In GHC, there are two use cases for `isBuiltInOcc_maybe`:++1. Making TH's `mkName` work with built-in syntax,+   e.g. $(conT (mkName "[]")) is the same as []++2. Detecting bulit-in syntax in `infix` declarations,+   e.g. users can't write `infixl 6 :` (#15233)++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`.+-}++-- | 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.+--+-- 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]++-- 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 =++  -- Tuples, boxed and unboxed+  isTupleTyOrigName_maybe mod occ+  <|> isTupleDataOrigName_maybe mod occ++  -- Constraint tuples+  <|> isCTupleOrigName_maybe mod occ++  -- Unboxed sums+  <|> isSumTyOrigName_maybe mod occ+  <|> isSumDataOrigName_maybe mod occ++-- 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++-- 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+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_tup_syntax _ = Nothing++-- 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++-- 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++-- (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++-- (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+    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+      | isTcClsNameSpace ns, Just (boxity@Unboxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing++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)  -- CUnit+      | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)  -- CSolo++      | Just num <- sbs_CTuple sbs, num >= 2+      = Just $ cTupleTyConName num++      | otherwise = Nothing++isCTupleOrigName_maybe _ _ = Nothing++-- 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>+--+-- 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+    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]+~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, tuples in Haskell have a maximum arity of 64.+To parse strings of length 1 and 2 more efficiently, we+can utilize an ad-hoc solution that matches their characters.+This results in a speedup of up to 40 times compared to using+`readMaybe @Int` on my machine.+-}++mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax)+mkTupleOcc ns b ar = (mkOccName ns str, built_in)+  where (str, built_in) = mkTupleStr' ns b ar++mkCTupleOcc :: NameSpace -> Arity -> OccName+mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)++mkTupleStr :: Boxity -> NameSpace -> Arity -> String+mkTupleStr b ns ar = str+  where (str, _) = mkTupleStr' ns b ar++mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax)+mkTupleStr' ns Boxed 0+  | isDataConNameSpace ns = ("()", BuiltInSyntax)+  | otherwise             = ("Unit", UserSyntax)+mkTupleStr' ns Boxed 1+  | isDataConNameSpace ns = ("MkSolo", UserSyntax)  -- See Note [One-tuples]+  | otherwise             = ("Solo",   UserSyntax)+mkTupleStr' ns Boxed ar+  | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ showInt ar "", UserSyntax)+mkTupleStr' ns Unboxed 0+  | isDataConNameSpace ns = ("(##)",  BuiltInSyntax)+  | otherwise             = ("Unit#", UserSyntax)+mkTupleStr' ns Unboxed 1+  | isDataConNameSpace ns = ("MkSolo#", UserSyntax) -- See Note [One-tuples]+  | otherwise             = ("Solo#",   UserSyntax)+mkTupleStr' ns Unboxed ar+  | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ show ar ++ "#", UserSyntax)++mkConstraintTupleStr :: Arity -> String+mkConstraintTupleStr 0 = "CUnit"+mkConstraintTupleStr 1 = "CSolo"+mkConstraintTupleStr ar = "CTuple" ++ show ar++commas :: Arity -> String+commas ar = replicate (ar-1) ','++cTupleTyCon :: Arity -> TyCon+cTupleTyCon i+  | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = fstOf3 (cTupleArr ! i)++cTupleTyConName :: Arity -> Name+cTupleTyConName a = tyConName (cTupleTyCon a)++cTupleTyConNames :: [Name]+cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleTyConKeys :: UniqueSet+cTupleTyConKeys = fromListUniqueSet $ map getUnique cTupleTyConNames++isCTupleTyConName :: Name -> Bool+isCTupleTyConName n+ = assertPpr (isExternalName n) (ppr n) $+   getUnique n `memberUniqueSet` cTupleTyConKeys++cTupleDataCon :: Arity -> DataCon+cTupleDataCon i+  | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = sndOf3 (cTupleArr ! i)++cTupleDataConName :: Arity -> Name+cTupleDataConName i = dataConName (cTupleDataCon i)++cTupleDataConNames :: [Name]+cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleSelId :: ConTag -- Superclass position+            -> Arity  -- Arity+            -> Id+cTupleSelId sc_pos arity+  | sc_pos > arity+  = panic ("cTupleSelId: index out of bounds: superclass position: "+           ++ show sc_pos ++ " > arity " ++ show arity)++  | sc_pos <= 0+  = panic ("cTupleSelId: Superclass positions start from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 1+  = panic ("cTupleSelId: Arity starts from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_CTUPLE_SIZE+  = thdOf3 (mk_ctuple arity) ! (sc_pos - 1)  -- Build one specially++  | otherwise+  = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1)++cTupleSelIdName :: ConTag -- Superclass position+                -> Arity  -- Arity+                -> Name+cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity)++tupleTyCon :: Boxity -> Arity -> TyCon+tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially+tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)+tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)++tupleTyConName :: TupleSort -> Arity -> Name+tupleTyConName ConstraintTuple a = cTupleTyConName a+tupleTyConName BoxedTuple      a = tyConName (tupleTyCon Boxed a)+tupleTyConName UnboxedTuple    a = tyConName (tupleTyCon Unboxed a)++promotedTupleDataCon :: Boxity -> Arity -> TyCon+promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i)++tupleDataCon :: Boxity -> Arity -> DataCon+tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)    -- Build one specially+tupleDataCon Boxed   i = snd (boxedTupleArr   ! i)+tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)++tupleDataConName :: Boxity -> Arity -> Name+tupleDataConName sort i = dataConName (tupleDataCon sort i)++mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type+mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]++isPromotedPairType :: Type -> Maybe (Type, Type)+isPromotedPairType t+  | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t+  , tc == promotedTupleDataCon Boxed 2+  = Just (x, y)+  | otherwise = Nothing++boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)+boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]+unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]++-- | Cached type constructors, data constructors, and superclass selectors for+-- constraint tuples. The outer array is indexed by the arity of the constraint+-- 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]]++-- | 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+-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep+-- [IntRep, LiftedRep])@+unboxedTupleSumKind :: TyCon -> [Type] -> Kind+unboxedTupleSumKind tc rr_tys+  = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])++-- | Specialization of 'unboxedTupleSumKind' for tuples+unboxedTupleKind :: [Type] -> Kind+unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon++mk_tuple :: Boxity -> Int -> (TyCon,DataCon)+mk_tuple Boxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con+                         BoxedTuple flavour++    tc_binders  = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)+    tc_res_kind = liftedTypeKind+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs     = binderVars tc_binders+    dc_arg_tys = mkTyVarTys dc_tvs+    tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon++    boxity  = Boxed+    modu    = gHC_INTERNAL_TUPLE+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_tuple Unboxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con+                         UnboxedTuple flavour++    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2])+    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)+                                        (\ks -> map mkTYPEapp ks)++    tc_res_kind = unboxedTupleKind rr_tys+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs               = binderVars tc_binders+    (rr_tvs, dc_arg_tvs) = splitAt arity dc_tvs+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs+    tuple_con            = pcRepPolyDataCon dc_name dc_tvs conc_tvs dc_arg_tys tycon+    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedTuple pos)+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]++    boxity  = Unboxed+    modu    = gHC_TYPES+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id)+mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr)+  where+    tycon = mkClassTyCon tc_name binders roles+                         rhs klass+                         (mkPrelTyConRepName tc_name)++    klass     = mk_ctuple_class tycon sc_theta sc_sel_ids+    tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon++    binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)+    roles   = replicate arity Nominal+    rhs     = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple}++    modu    = gHC_CLASSES+    tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq+                         (ATyCon tycon) UserSyntax+    dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq+                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_uniq = mkCTupleTyConUnique   arity+    dc_uniq = mkCTupleDataConUnique arity++    tvs            = binderVars binders+    sc_theta       = map mkTyVarTy tvs+    sc_sel_ids     = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]]+    sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids++    mk_sc_sel_id sc_pos =+      let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity+          sc_sel_id_occ  = mkCTupleOcc tcName arity+          sc_sel_id_name = mkWiredInIdName+                             gHC_CLASSES+                             (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ))+                             sc_sel_id_uniq+                             sc_sel_id+          sc_sel_id      = mkDictSelId sc_sel_id_name klass++      in sc_sel_id++unitTyCon :: TyCon+unitTyCon = tupleTyCon Boxed 0++unitTyConName :: Name+unitTyConName = tyConName unitTyCon++unitTyConKey :: Unique+unitTyConKey = getUnique unitTyCon++unitDataCon :: DataCon+unitDataCon   = head (tyConDataCons unitTyCon)++unitDataConId :: Id+unitDataConId = dataConWorkId unitDataCon++soloTyCon :: TyCon+soloTyCon = tupleTyCon Boxed 1++soloTyConName :: Name+soloTyConName = tyConName soloTyCon++soloDataConName :: Name+soloDataConName = tupleDataConName Boxed 1++pairTyCon :: TyCon+pairTyCon = tupleTyCon Boxed 2++unboxedUnitTy :: Type+unboxedUnitTy = mkTyConTy unboxedUnitTyCon++unboxedUnitTyCon :: TyCon+unboxedUnitTyCon = tupleTyCon Unboxed 0++unboxedUnitTyConName :: Name+unboxedUnitTyConName = tyConName unboxedUnitTyCon++unboxedUnitDataCon :: DataCon+unboxedUnitDataCon = tupleDataCon Unboxed 0++unboxedSoloTyCon :: TyCon+unboxedSoloTyCon = tupleTyCon Unboxed 1++unboxedSoloTyConName :: Name+unboxedSoloTyConName = tyConName unboxedSoloTyCon++unboxedSoloDataConName :: Name+unboxedSoloDataConName = tupleDataConName Unboxed 1++{- *********************************************************************+*                                                                      *+      Unboxed sums+*                                                                      *+********************************************************************* -}++-- | OccName for n-ary unboxed sum type constructor.+mkSumTyConOcc :: Arity -> OccName+mkSumTyConOcc n = mkOccName tcName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = "Sum" ++ show n ++ "#"++-- | OccName for i-th alternative of n-ary unboxed sum data constructor.+mkSumDataConOcc :: ConTag -> Arity -> OccName+mkSumDataConOcc alt n = mkOccName dataName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"+    bars i = intersperse ' ' $ replicate i '|'++-- | Type constructor for n-ary unboxed sum.+sumTyCon :: Arity -> TyCon+sumTyCon arity+  | arity > mAX_SUM_SIZE+  = fst (mk_sum arity)  -- Build one specially++  | arity < 2+  = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")++  | 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+           -> DataCon+sumDataCon alt arity+  | alt > arity+  = panic ("sumDataCon: index out of bounds: alt: "+           ++ show alt ++ " > arity " ++ show arity)++  | alt <= 0+  = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 2+  = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_SUM_SIZE+  = snd (mk_sum arity) ! (alt - 1)  -- Build one specially++  | 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.+unboxedSumArr :: Array Int (TyCon, Array Int DataCon)+unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]++-- | Specialization of 'unboxedTupleSumKind' for sums+unboxedSumKind :: [Type] -> Kind+unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon++-- | Create type constructor and data constructors for n-ary unboxed sum.+mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)+mk_sum arity = (tycon, sum_cons)+  where+    tycon   = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons)+                         UnboxedSumTyCon++    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)+                                        (\ks -> map mkTYPEapp ks)++    tyvars = binderVars tc_binders++    tc_res_kind = unboxedSumKind rr_tys++    (rr_tvs, dc_arg_tvs) = splitAt arity tyvars+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs++    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedSum (Just pos))+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]++    tc_name = mkWiredInName gHC_TYPES (mkSumTyConOcc arity) tc_uniq+                            (ATyCon tycon) UserSyntax++    sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]]+    sum_con i =+      let dc = pcRepPolyDataCon dc_name+                  tyvars -- univ tyvars+                  conc_tvs+                  [dc_arg_tys !! i] -- arg types+                  tycon++          dc_name = mkWiredInName gHC_TYPES+                                  (mkSumDataConOcc i arity)+                                  (dc_uniq i)+                                  (AConLike (RealDataCon dc))+                                  BuiltInSyntax+      in dc++    tc_uniq   = mkSumTyConUnique   arity+    dc_uniq i = mkSumDataConUnique i arity++{-+************************************************************************+*                                                                      *+              Equality types and classes+*                                                                      *+********************************************************************* -}++-- See Note [The equality types story] in GHC.Builtin.Types.Prim+-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)+--+-- It's tempting to put functional dependencies on (~~), but it's not+-- necessary because the functional-dependency coverage check looks+-- through superclasses, and (~#) is handled in that check.++eqTyCon,   heqTyCon,   coercibleTyCon   :: TyCon+eqClass,   heqClass,   coercibleClass   :: Class+eqDataCon, heqDataCon, coercibleDataCon :: DataCon+eqSCSelId, heqSCSelId, coercibleSCSelId :: Id++(eqTyCon, eqClass, eqDataCon, eqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon eqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName eqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint eqDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    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])+    sc_sel_id   = mkDictSelId eqSCSelIdName klass++(heqTyCon, heqClass, heqDataCon, heqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon heqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName heqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint heqDataConName tvs [sc_pred] tycon++    -- Kind: forall k1 k2. k1 -> k2 -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id+    roles     = [Nominal, Nominal, Nominal, Nominal]+    rhs       = mkDataTyConRhs [datacon]++    tvs       = binderVars binders+    sc_pred   = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)+    sc_sel_id = mkDictSelId heqSCSelIdName klass++(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon coercibleTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName coercibleTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])+    roles     = [Nominal, Representational, Representational]+    rhs       = mkDataTyConRhs [datacon]++    tvs@[k,a,b] = binderVars binders+    sc_pred     = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])+    sc_sel_id   = mkDictSelId coercibleSCSelIdName klass++mk_class :: TyCon -> PredType -> Id -> Class+mk_class tycon sc_pred sc_sel_id+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]+            [] [] (mkAnd []) tycon++mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class+mk_ctuple_class tycon sc_theta sc_sel_ids+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids+            [] [] (mkAnd []) tycon++{- *********************************************************************+*                                                                      *+                Multiplicity Polymorphism+*                                                                      *+********************************************************************* -}++{- Multiplicity polymorphism is implemented very similarly to representation+ polymorphism. We write in the multiplicity kind and the One and Many+ types which can appear in user programs. These are defined properly in GHC.Types.++data Multiplicity = One | Many+-}++multiplicityTyConName :: Name+multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")+                          multiplicityTyConKey multiplicityTyCon++oneDataConName, manyDataConName :: Name+oneDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon+manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon++multiplicityTy :: Type+multiplicityTy = mkTyConTy multiplicityTyCon++multiplicityTyCon :: TyCon+multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []+                            [oneDataCon, manyDataCon]++oneDataCon, manyDataCon :: DataCon+oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon+manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon++oneDataConTy, manyDataConTy :: Type+oneDataConTy = mkTyConTy oneDataConTyCon+manyDataConTy = mkTyConTy manyDataConTyCon++oneDataConTyCon, manyDataConTyCon :: TyCon+oneDataConTyCon = promoteDataCon oneDataCon+manyDataConTyCon = promoteDataCon manyDataCon++multMulTyConName :: Name+multMulTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon++multMulTyCon :: TyCon+multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing+                         (BuiltInSynFamTyCon trivialBuiltInFamily)+                         Nothing+                         NotInjective+  where+    binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy]++------------------------+-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).+--              TYPE rep1 -> TYPE rep2 -> Type+-- type (->) = FUN 'Many+unrestrictedFunTyCon :: TyCon+unrestrictedFunTyCon+  = buildSynTyCon unrestrictedFunTyConName [] arrowKind []+                  (TyCoRep.TyConApp fUNTyCon [manyDataConTy])+  where+    arrowKind = mkTyConKind binders liftedTypeKind+    -- See also funTyCon+    binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)+              , Bndr runtimeRep2TyVar (NamedTCB Inferred) ]+              ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty+                                            , mkTYPEapp runtimeRep2Ty ]++unrestrictedFunTyConName :: Name+unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->")+                                              unrestrictedFunTyConKey unrestrictedFunTyCon+++{- *********************************************************************+*                                                                      *+      Type synonyms (all declared in ghc-prim:GHC.Types)++         type CONSTRAINT   :: RuntimeRep -> Type -- primitive; cONSTRAINTKind+         type Constraint   = CONSTRAINT LiftedRep  :: Type    -- constraintKind++         type TYPE         :: RuntimeRep -> Type  -- primitive; tYPEKind+         type Type         = TYPE LiftedRep   :: Type         -- liftedTypeKind+         type UnliftedType = TYPE UnliftedRep :: Type         -- unliftedTypeKind++         type LiftedRep    = BoxedRep Lifted   :: RuntimeRep  -- liftedRepTy+         type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep  -- unliftedRepTy++*                                                                      *+********************************************************************* -}++-- For these synonyms, see+-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and+-- Note [Using synonyms to compress types] in GHC.Core.Type++{- Note [Naked FunTy]+~~~~~~~~~~~~~~~~~~~~~+GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument+flag and arg/res types.  But when constructing the kinds of tYPETyCon and+cONSTRAINTTyCon we don't want to make these checks because+     TYPE :: RuntimeRep -> Type+i.e. TYPE :: RuntimeRep -> TYPE LiftedRep++so the check will loop infinitely.  Hence the use of a naked FunTy+constructor in tTYPETyCon and cONSTRAINTTyCon.+-}+++----------------------+-- type Constraint = CONSTRAINT LiftedRep+constraintKindTyCon :: TyCon+constraintKindTyCon+  = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy]++constraintKindTyConName :: Name+constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")+                                             constraintKindTyConKey constraintKindTyCon++constraintKind :: Kind+constraintKind = mkTyConTy constraintKindTyCon++----------------------+-- type Type = TYPE LiftedRep+liftedTypeKindTyCon :: TyCon+liftedTypeKindTyCon+  = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]++liftedTypeKindTyConName :: Name+liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")+                                             liftedTypeKindTyConKey liftedTypeKindTyCon++liftedTypeKind, typeToTypeKind :: Type+liftedTypeKind = mkTyConTy liftedTypeKindTyCon+typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind++----------------------+-- type UnliftedType = TYPE ('BoxedRep 'Unlifted)+unliftedTypeKindTyCon :: TyCon+unliftedTypeKindTyCon+  = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy]++unliftedTypeKindTyConName :: Name+unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType")+                                                unliftedTypeKindTyConKey unliftedTypeKindTyCon++unliftedTypeKind :: Type+unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon+++{- *********************************************************************+*                                                                      *+      data Levity = Lifted | Unlifted+*                                                                      *+********************************************************************* -}++levityTyConName, liftedDataConName, unliftedDataConName :: Name+levityTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Levity")   levityTyConKey     levityTyCon+liftedDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted")   liftedDataConKey   liftedDataCon+unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon++levityTyCon :: TyCon+levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]++levityTy :: Type+levityTy = mkTyConTy levityTyCon++liftedDataCon, unliftedDataCon :: DataCon+liftedDataCon = pcSpecialDataCon liftedDataConName+    [] levityTyCon (Levity Lifted)+unliftedDataCon = pcSpecialDataCon unliftedDataConName+    [] levityTyCon (Levity Unlifted)++liftedDataConTyCon :: TyCon+liftedDataConTyCon = promoteDataCon liftedDataCon++unliftedDataConTyCon :: TyCon+unliftedDataConTyCon = promoteDataCon unliftedDataCon++liftedDataConTy :: Type+liftedDataConTy = mkTyConTy liftedDataConTyCon++unliftedDataConTy :: Type+unliftedDataConTy = mkTyConTy unliftedDataConTyCon+++{- *********************************************************************+*                                                                      *+    See Note [Wiring in RuntimeRep]+        data RuntimeRep = VecRep VecCount VecElem+                        | TupleRep [RuntimeRep]+                        | SumRep [RuntimeRep]+                        | BoxedRep Levity+                        | IntRep | Int8Rep | ...etc...+*                                                                      *+********************************************************************* -}++{- Note [Wiring in RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,+making it a pain to wire in. To ease the pain somewhat, we use lists of+the different bits, like Uniques, Names, DataCons. These lists must be+kept in sync with each other. The rule is this: use the order as declared+in GHC.Types. All places where such lists exist should contain a reference+to this Note, so a search for this Note's name should find all the lists.++See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.+-}++runtimeRepTyCon :: TyCon+runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []+    -- Here we list all the data constructors+    -- of the RuntimeRep data type+    (vecRepDataCon : tupleRepDataCon :+     sumRepDataCon : boxedRepDataCon :+     runtimeRepSimpleDataCons)++runtimeRepTy :: Type+runtimeRepTy = mkTyConTy runtimeRepTyCon++runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon++vecRepDataConName   = mk_runtime_rep_dc_name (fsLit "VecRep")   vecRepDataConKey   vecRepDataCon+tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon+sumRepDataConName   = mk_runtime_rep_dc_name (fsLit "SumRep")   sumRepDataConKey   sumRepDataCon+boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon++mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name+mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc++boxedRepDataCon :: DataCon+boxedRepDataCon = pcSpecialDataCon boxedRepDataConName+  [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in RepType+    prim_rep_fun [lev]+      = case tyConAppTyCon_maybe lev of+          Just tc -> case tyConPromDataConInfo tc of+            Levity l -> [BoxedRep (Just l)]+            _        -> [BoxedRep Nothing]+          Nothing    -> [BoxedRep Nothing]+    prim_rep_fun args+      = pprPanic "boxedRepDataCon" (ppr args)+++boxedRepDataConTyCon :: TyCon+boxedRepDataConTyCon = promoteDataCon boxedRepDataCon++tupleRepDataCon :: DataCon+tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]+                                   runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [rr_ty_list]+      = concatMap (runtimeRepPrimRep doc) rr_tys+      where+        rr_tys = extractPromotedList rr_ty_list+        doc    = text "tupleRepDataCon" <+> ppr rr_tys+    prim_rep_fun args+      = pprPanic "tupleRepDataCon" (ppr args)++tupleRepDataConTyCon :: TyCon+tupleRepDataConTyCon = promoteDataCon tupleRepDataCon++sumRepDataCon :: DataCon+sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]+                                 runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [rr_ty_list]+      = map slotPrimRep (toList (ubxSumRepType prim_repss))+      where+        rr_tys     = extractPromotedList rr_ty_list+        doc        = text "sumRepDataCon" <+> ppr rr_tys+        prim_repss = map (runtimeRepPrimRep doc) rr_tys+    prim_rep_fun args+      = pprPanic "sumRepDataCon" (ppr args)++sumRepDataConTyCon :: TyCon+sumRepDataConTyCon = promoteDataCon sumRepDataCon++-- See Note [Wiring in RuntimeRep]+-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+runtimeRepSimpleDataCons :: [DataCon]+runtimeRepSimpleDataCons+  = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys+            [ (fsLit "IntRep",    IntRep)+            , (fsLit "Int8Rep",   Int8Rep)+            , (fsLit "Int16Rep",  Int16Rep)+            , (fsLit "Int32Rep",  Int32Rep)+            , (fsLit "Int64Rep",  Int64Rep)+            , (fsLit "WordRep",   WordRep)+            , (fsLit "Word8Rep",  Word8Rep)+            , (fsLit "Word16Rep", Word16Rep)+            , (fsLit "Word32Rep", Word32Rep)+            , (fsLit "Word64Rep", Word64Rep)+            , (fsLit "AddrRep",   AddrRep)+            , (fsLit "FloatRep",  FloatRep)+            , (fsLit "DoubleRep", DoubleRep) ]+  where+    mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon+    mk_runtime_rep_dc uniq (fs, primrep)+      = data_con+      where+        data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))+        dc_name  = mk_runtime_rep_dc_name fs uniq data_con++-- See Note [Wiring in RuntimeRep]+intRepDataConTy,+  int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+  wordRepDataConTy,+  word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+  addrRepDataConTy,+  floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType+[intRepDataConTy,+   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+   wordRepDataConTy,+   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+   addrRepDataConTy,+   floatRepDataConTy, doubleRepDataConTy+   ]+  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons++----------------------+-- | @type ZeroBitRep = 'Tuple '[]+zeroBitRepTyCon :: TyCon+zeroBitRepTyCon+  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]++zeroBitRepTyConName :: Name+zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")+                                          zeroBitRepTyConKey  zeroBitRepTyCon++zeroBitRepTy :: RuntimeRepType+zeroBitRepTy = mkTyConTy zeroBitRepTyCon++----------------------+-- @type ZeroBitType = TYPE ZeroBitRep+zeroBitTypeTyCon :: TyCon+zeroBitTypeTyCon+  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]++zeroBitTypeTyConName :: Name+zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")+                                          zeroBitTypeTyConKey zeroBitTypeTyCon++zeroBitTypeKind :: Type+zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon++----------------------+-- | @type LiftedRep = 'BoxedRep 'Lifted@+liftedRepTyCon :: TyCon+liftedRepTyCon+  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]++liftedRepTyConName :: Name+liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")+                                        liftedRepTyConKey liftedRepTyCon++liftedRepTy :: RuntimeRepType+liftedRepTy = mkTyConTy liftedRepTyCon++----------------------+-- | @type UnliftedRep = 'BoxedRep 'Unlifted@+unliftedRepTyCon :: TyCon+unliftedRepTyCon+  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]++unliftedRepTyConName :: Name+unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep")+                                          unliftedRepTyConKey unliftedRepTyCon++unliftedRepTy :: RuntimeRepType+unliftedRepTy = mkTyConTy unliftedRepTyCon+++{- *********************************************************************+*                                                                      *+         VecCount, VecElem+*                                                                      *+********************************************************************* -}++vecCountTyConName :: Name+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon++vecElemTyConName :: Name+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon++vecRepDataCon :: DataCon+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon+                                                   , mkTyConTy vecElemTyCon ]+                                 runtimeRepTyCon+                                 (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [count, elem]+      | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)+      , VecElem  e <- tyConPromDataConInfo (tyConAppTyCon elem)+      = [VecRep n e]+    prim_rep_fun args+      = pprPanic "vecRepDataCon" (ppr args)++vecRepDataConTyCon :: TyCon+vecRepDataConTyCon = promoteDataCon vecRepDataCon++vecCountTyCon :: TyCon+vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons++-- See Note [Wiring in RuntimeRep]+vecCountDataCons :: [DataCon]+vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys+  where+    mk_vec_count_dc logN key = con+      where+        n = 2^(logN :: Int)+        name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con+        con = pcSpecialDataCon name [] vecCountTyCon (VecCount n)++-- See Note [Wiring in RuntimeRep]+vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy :: Type+[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons++vecElemTyCon :: TyCon+vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons++-- See Note [Wiring in RuntimeRep]+vecElemDataCons :: [DataCon]+vecElemDataCons = zipWith3 mk_vec_elem_dc+  [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep"+  , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep"+  , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]+  [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep+  , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep+  , FloatElemRep, DoubleElemRep ]+    vecElemDataConKeys+  where+    mk_vec_elem_dc nameFs elemRep key = con+      where+        name = mk_runtime_rep_dc_name nameFs key con+        con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep)++-- See Note [Wiring in RuntimeRep]+int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy :: Type+[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)+                                vecElemDataCons++{- *********************************************************************+*                                                                      *+     The boxed primitive types: Char, Int, etc+*                                                                      *+********************************************************************* -}++charTy :: Type+charTy = mkTyConTy charTyCon++charTyCon :: TyCon+charTyCon   = pcTyCon charTyConName+                   (Just (CType NoSourceText Nothing+                                  (NoSourceText,fsLit "HsChar")))+                   [] [charDataCon]+charDataCon :: DataCon+charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon++stringTy :: Type+stringTy = mkTyConTy stringTyCon++stringTyCon :: TyCon+-- We have this wired-in so that Haskell literal strings+-- get type String (in hsLitType), which in turn influences+-- inferred types and error messages+stringTyCon = buildSynTyCon stringTyConName+                            [] liftedTypeKind []+                            (mkListTy charTy)++intTy :: Type+intTy = mkTyConTy intTyCon++intTyCon :: TyCon+intTyCon = pcTyCon intTyConName+               (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))+                 [] [intDataCon]+intDataCon :: DataCon+intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon++wordTy :: Type+wordTy = mkTyConTy wordTyCon++wordTyCon :: TyCon+wordTyCon = pcTyCon wordTyConName+            (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))+               [] [wordDataCon]+wordDataCon :: DataCon+wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon++word8Ty :: Type+word8Ty = mkTyConTy word8TyCon++word8TyCon :: TyCon+word8TyCon = pcTyCon word8TyConName+                     (Just (CType NoSourceText Nothing+                            (NoSourceText, fsLit "HsWord8"))) []+                     [word8DataCon]+word8DataCon :: DataCon+word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon++floatTy :: Type+floatTy = mkTyConTy floatTyCon++floatTyCon :: TyCon+floatTyCon   = pcTyCon floatTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText, fsLit "HsFloat"))) []+                      [floatDataCon]+floatDataCon :: DataCon+floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon++doubleTy :: Type+doubleTy = mkTyConTy doubleTyCon++doubleTyCon :: TyCon+doubleTyCon = pcTyCon doubleTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText,fsLit "HsDouble"))) []+                      [doubleDataCon]++doubleDataCon :: DataCon+doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon++{- *********************************************************************+*                                                                      *+              Boxing data constructors+*                                                                      *+********************************************************************* -}++{- Note [Boxing constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep+that "box" unlifted values into a (boxed, lifted) value of kind Type. For example++  type Int8Box :: TYPE Int8Rep -> Type+  data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a+    -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a++Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`.  We can also+package up a (lifted) Constraint as a value of kind Type.++There are a fixed number of RuntimeReps, so we only need a fixed number+of boxing types.  (For TupleRep we need to box recursively; not yet done,+see #22336.)++This is used:++* In desugaring, when we need to package up a bunch of values into a tuple,+  for example when desugaring arrows.  See Note [Big tuples] in GHC.Core.Make.++* In let-floating when we want to float an unlifted sub-expression.+  See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels++In this module we make wired-in data type declarations for all of+these boxing functions.  The goal is to define boxingDataCon_maybe.++Wrinkles+(W1) The runtime system has special treatment (e.g. commoning up during GC)+     for Int and Char values. See  Note [CHARLIKE and INTLIKE closures] and+     Note [Precomputed static closures] in the RTS.++     So we treat Int# and Char# specially, in specialBoxingDataCon_maybe+-}++data BoxingInfo b+  = BI_NoBoxNeeded   -- The type has kind Type, so there is nothing to do++  | BI_NoBoxAvailable  -- The type does not have kind Type, but sadly we+                       -- don't have a boxing data constructor either++  | BI_Box             -- The type does not have kind Type, and we do have a+                       -- boxing data constructor; here it is+      { bi_data_con   :: DataCon+      , bi_inst_con   :: Expr b+      , bi_boxed_type :: Type }+    -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int }+    --        recall: data Int = I# Int#+    --+    --      BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty+    --             , bi_boxed_type = Int8Box ty }+    --        recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a++boxingDataCon :: Type -> BoxingInfo b+-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that+--   will box it, and the type of the boxed thing, which /does/ now have kind Type.+-- See Note [Boxing constructors]+boxingDataCon ty+  | tcIsLiftedTypeKind kind+  = BI_NoBoxNeeded    -- Fast path for Type++  | Just box_con <- specialBoxingDataCon_maybe ty+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con []+           , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) }++  | Just box_con <- lookupTypeMap boxingDataConMap kind+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty]+           , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] }++  | otherwise+  = BI_NoBoxAvailable++  where+    kind = typeKind ty++specialBoxingDataCon_maybe :: Type -> Maybe DataCon+-- ^ See Note [Boxing constructors] wrinkle (W1)+specialBoxingDataCon_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, _) | tc `hasKey` intPrimTyConKey  -> Just intDataCon+                   | tc `hasKey` charPrimTyConKey -> Just charDataCon+      _ -> Nothing++boxingDataConMap :: TypeMap DataCon+-- See Note [Boxing constructors]+boxingDataConMap = foldl add emptyTypeMap boxingDataCons+  where+    add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con++boxingDataCons :: [(Kind, DataCon)]+-- The Kind is the kind of types for which the DataCon is the right boxing+boxingDataCons = zipWith mkBoxingDataCon+  (map mkBoxingTyConUnique [1..])+  [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox")+  , (mkTYPEapp intRepDataConTy,  fsLit "IntBox",  fsLit "MkIntBox")++  , (mkTYPEapp floatRepDataConTy,  fsLit "FloatBox",  fsLit "MkFloatBox")+  , (mkTYPEapp doubleRepDataConTy,  fsLit "DoubleBox",  fsLit "MkDoubleBox")++  , (mkTYPEapp int8RepDataConTy,  fsLit "Int8Box",  fsLit "MkInt8Box")+  , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box")+  , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box")+  , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box")++  , (mkTYPEapp word8RepDataConTy,  fsLit "Word8Box",   fsLit "MkWord8Box")+  , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box",  fsLit "MkWord16Box")+  , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box",  fsLit "MkWord32Box")+  , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box",  fsLit "MkWord64Box")++  , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox")+  , (constraintKind,   fsLit "DictBox", fsLit "MkDictBox") ]++mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon)+mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc)+  = (kind, dc)+  where+    uniq_dc = boxingDataConUnique uniq_tc++    (tv:_) = mkTemplateTyVars (repeat kind)+    tc = pcTyCon tc_name Nothing [tv] [dc]+    tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc++    dc | isConstraintKind kind+       = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc+       | otherwise+       = pcDataCon           dc_name [tv] [mkTyVarTy tv] tc+    dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc++{-+************************************************************************+*                                                                      *+              The Bool type+*                                                                      *+************************************************************************++An ordinary enumeration type, but deeply wired in.  There are no+magical operations on @Bool@ (just the regular Prelude code).++{\em BEGIN IDLE SPECULATION BY SIMON}++This is not the only way to encode @Bool@.  A more obvious coding makes+@Bool@ just a boxed up version of @Bool#@, like this:+\begin{verbatim}+type Bool# = Int#+data Bool = MkBool Bool#+\end{verbatim}++Unfortunately, this doesn't correspond to what the Report says @Bool@+looks like!  Furthermore, we get slightly less efficient code (I+think) with this coding. @gtInt@ would look like this:++\begin{verbatim}+gtInt :: Int -> Int -> Bool+gtInt x y = case x of I# x# ->+            case y of I# y# ->+            case (gtIntPrim x# y#) of+                b# -> MkBool b#+\end{verbatim}++Notice that the result of the @gtIntPrim@ comparison has to be turned+into an integer (here called @b#@), and returned in a @MkBool@ box.++The @if@ expression would compile to this:+\begin{verbatim}+case (gtInt x y) of+  MkBool b# -> case b# of { 1# -> e1; 0# -> e2 }+\end{verbatim}++I think this code is a little less efficient than the previous code,+but I'm not certain.  At all events, corresponding with the Report is+important.  The interesting thing is that the language is expressive+enough to describe more than one alternative; and that a type doesn't+necessarily need to be a straightforwardly boxed version of its+primitive counterpart.++{\em END IDLE SPECULATION BY SIMON}+-}++boolTy :: Type+boolTy = mkTyConTy boolTyCon++boolTyCon :: TyCon+boolTyCon = pcTyCon boolTyConName+                    (Just (CType NoSourceText Nothing+                           (NoSourceText, fsLit "HsBool")))+                    [] [falseDataCon, trueDataCon]++falseDataCon, trueDataCon :: DataCon+falseDataCon = pcDataCon falseDataConName [] [] boolTyCon+trueDataCon  = pcDataCon trueDataConName  [] [] boolTyCon++falseDataConId, trueDataConId :: Id+falseDataConId = dataConWorkId falseDataCon+trueDataConId  = dataConWorkId trueDataCon++orderingTyCon :: TyCon+orderingTyCon = pcTyCon orderingTyConName Nothing+                        [] [ordLTDataCon, ordEQDataCon, ordGTDataCon]++ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon+ordLTDataCon = pcDataCon ordLTDataConName  [] [] orderingTyCon+ordEQDataCon = pcDataCon ordEQDataConName  [] [] orderingTyCon+ordGTDataCon = pcDataCon ordGTDataConName  [] [] orderingTyCon++ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id+ordLTDataConId = dataConWorkId ordLTDataCon+ordEQDataConId = dataConWorkId ordEQDataCon+ordGTDataConId = dataConWorkId ordGTDataCon++{-+************************************************************************+*                                                                      *+            The List type+   Special syntax, deeply wired in,+   but otherwise an ordinary algebraic data type+*                                                                      *+************************************************************************++       data [] a = [] | a : (List a)+-}++mkListTy :: Type -> Type+mkListTy ty = mkTyConApp listTyCon [ty]++listTyCon :: TyCon+listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon]++-- See also Note [Empty lists] in GHC.Hs.Expr.+nilDataCon :: DataCon+nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon++consDataCon :: DataCon+consDataCon = pcDataConWithFixity True {- Declared infix -}+               consDataConName+               alpha_tyvar [] noConcreteTyVars alpha_tyvar []+               (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])+               listTyCon++-- Interesting: polymorphic recursion would help here.+-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy+-- gets the over-specific type (Type -> Type)++-- Wired-in type Maybe++maybeTyCon :: TyCon+maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar+                     [nothingDataCon, justDataCon]++nothingDataCon :: DataCon+nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon++justDataCon :: DataCon+justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon++mkPromotedMaybeTy :: Kind -> Maybe Type -> Type+mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]+mkPromotedMaybeTy k Nothing  = mkTyConApp promotedNothingDataCon [k]++mkMaybeTy :: Type -> Kind+mkMaybeTy t = mkTyConApp maybeTyCon [t]++isPromotedMaybeTy :: Type -> Maybe (Maybe Type)+isPromotedMaybeTy t+  | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x+  | Just (tc,[_])   <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing+  | otherwise = Nothing+++{-+** *********************************************************************+*                                                                      *+            The tuple types+*                                                                      *+************************************************************************++The tuple types are definitely magic, because they form an infinite+family.++\begin{itemize}+\item+They have a special family of type constructors, of type @TyCon@+These contain the tycon arity, but don't require a Unique.++\item+They have a special family of constructors, of type+@Id@. Again these contain their arity but don't need a Unique.++\item+There should be a magic way of generating the info tables and+entry code for all tuples.++But at the moment we just compile a Haskell source+file\srcloc{lib/prelude/...} containing declarations like:+\begin{verbatim}+data Tuple0             = Tup0+data Tuple2  a b        = Tup2  a b+data Tuple3  a b c      = Tup3  a b c+data Tuple4  a b c d    = Tup4  a b c d+...+\end{verbatim}+The print-names associated with the magic @Id@s for tuple constructors+``just happen'' to be the same as those generated by these+declarations.++\item+The instance environment should have a magic way to know+that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and+so on. \ToDo{Not implemented yet.}++\item+There should also be a way to generate the appropriate code for each+of these instances, but (like the info tables and entry code) it is+done by enumeration\srcloc{lib/prelude/InTup?.hs}.+\end{itemize}+-}++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications. Boxed 1-tuples are flattened.+-- See Note [One-tuples]+mkTupleTy :: Boxity -> [Type] -> Type+-- Special case for *boxed* 1-tuples, which are represented by the type itself+mkTupleTy Boxed   [ty] = ty+mkTupleTy boxity  tys  = mkTupleTy1 boxity tys++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened.+-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn]+-- in "GHC.Core.Make"+mkTupleTy1 :: Boxity -> [Type] -> Type+mkTupleTy1 Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys+mkTupleTy1 Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))+                                     (map getRuntimeRep tys ++ tys)++-- | Build the type of a small tuple that holds the specified type of thing+-- Flattens 1-tuples. See Note [One-tuples].+mkBoxedTupleTy :: [Type] -> Type+mkBoxedTupleTy tys = mkTupleTy Boxed tys++unitTy :: Type+unitTy = mkTupleTy Boxed []++-- Make a constraint tuple, flattening a 1-tuple as usual+-- If we get a constraint tuple that is bigger than the pre-built+--   ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't+--   have an info table in the RTS, so we can't use it at runtime.  But+--   this is used only in filling in extra-constraint wildcards, so it+--   never is used at runtime anyway+--   See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures]+mkConstraintTupleTy :: [Type] -> Type+mkConstraintTupleTy [ty] = ty+mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys+++{- *********************************************************************+*                                                                      *+            The sum types+*                                                                      *+************************************************************************+-}++mkSumTy :: [Type] -> Type+mkSumTy tys = mkTyConApp (sumTyCon (length tys))+                         (map getRuntimeRep tys ++ tys)++-- Promoted Booleans++promotedFalseDataCon, promotedTrueDataCon :: TyCon+promotedTrueDataCon   = promoteDataCon trueDataCon+promotedFalseDataCon  = promoteDataCon falseDataCon++-- Promoted Maybe+promotedNothingDataCon, promotedJustDataCon :: TyCon+promotedNothingDataCon = promoteDataCon nothingDataCon+promotedJustDataCon    = promoteDataCon justDataCon++-- Promoted Ordering++promotedLTDataCon+  , promotedEQDataCon+  , promotedGTDataCon+  :: TyCon+promotedLTDataCon     = promoteDataCon ordLTDataCon+promotedEQDataCon     = promoteDataCon ordEQDataCon+promotedGTDataCon     = promoteDataCon ordGTDataCon++-- Promoted List+promotedConsDataCon, promotedNilDataCon :: TyCon+promotedConsDataCon   = promoteDataCon consDataCon+promotedNilDataCon    = promoteDataCon nilDataCon++-- | Make a *promoted* list.+mkPromotedListTy :: Kind   -- ^ of the elements of the list+                 -> [Type] -- ^ elements+                 -> Type+mkPromotedListTy k tys+  = foldr cons nil tys+  where+    cons :: Type  -- element+         -> Type  -- list+         -> Type+    cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]++    nil :: Type+    nil = mkTyConApp promotedNilDataCon [k]++-- | Extract the elements of a promoted list. Panics if the type is not a+-- promoted list+extractPromotedList :: Type    -- ^ The promoted list+                    -> [Type]+extractPromotedList tys = go tys+  where+    go list_ty+      | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty+      = assert (tc `hasKey` consDataConKey) $+        t : go ts++      | Just (tc, [_k]) <- splitTyConApp_maybe list_ty+      = assert (tc `hasKey` nilDataConKey)+        []++      | otherwise+      = pprPanic "extractPromotedList" (ppr tys)++---------------------------------------+-- ghc-bignum+---------------------------------------++integerTyConName+   , integerISDataConName+   , integerIPDataConName+   , integerINDataConName+   :: Name+integerTyConName+   = mkWiredInTyConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "Integer")+      integerTyConKey+      integerTyCon+integerISDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IS")+      integerISDataConKey+      integerISDataCon+integerIPDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IP")+      integerIPDataConKey+      integerIPDataCon+integerINDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IN")+      integerINDataConKey+      integerINDataCon++integerTy :: Type+integerTy = mkTyConTy integerTyCon++integerTyCon :: TyCon+integerTyCon = pcTyCon integerTyConName Nothing []+                  [integerISDataCon, integerIPDataCon, integerINDataCon]++integerISDataCon :: DataCon+integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon++integerIPDataCon :: DataCon+integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon++integerINDataCon :: DataCon+integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon++naturalTyConName+   , naturalNSDataConName+   , naturalNBDataConName+   :: Name+naturalTyConName+   = mkWiredInTyConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "Natural")+      naturalTyConKey+      naturalTyCon+naturalNSDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "NS")+      naturalNSDataConKey+      naturalNSDataCon+naturalNBDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "NB")+      naturalNBDataConKey+      naturalNBDataCon++naturalTy :: Type+naturalTy = mkTyConTy naturalTyCon++naturalTyCon :: TyCon+naturalTyCon = pcTyCon naturalTyConName Nothing []+                  [naturalNSDataCon, naturalNBDataCon]++naturalNSDataCon :: DataCon+naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon++naturalNBDataCon :: DataCon+naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon+++{-+************************************************************************+*                                                                      *+   Semi-builtin names+*                                                                      *+************************************************************************++Note [pretendNameIsInScope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we filter out instances that mention types whose names are+not in scope. However, in the situations listed below, we make an exception+for some commonly used names, such as Data.Kind.Type, which may not actually+be in scope but should be treated as though they were in scope.+This includes built-in names, as well as a few extra names such as+'Type', 'TYPE', 'BoxedRep', etc.++Situations in which we apply this special logic:++  - GHCi's :info command, see GHC.Runtime.Eval.getInfo.+    This fixes #1581.++  - When reporting instance overlap errors. Not doing so could mean+    that we would omit instances for typeclasses like++      type Cls :: k -> Constraint+      class Cls a++    because BoxedRep/Lifted were not in scope.+    See GHC.Tc.Errors.potentialInstancesErrMsg.+    This fixes one of the issues reported in #20465.+-}++-- | Should this name be considered in-scope, even though it technically isn't?+--+-- This ensures that we don't filter out information because, e.g.,+-- Data.Kind.Type isn't imported.+--+-- See Note [pretendNameIsInScope].+pretendNameIsInScope :: Name -> Bool+pretendNameIsInScope n+  = isBuiltInSyntax n+  || isTupleTyConName n+  || isSumTyConName n+  || isCTupleTyConName n+  || any (n `hasKey`)+    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey+    , liftedDataConKey, unliftedDataConKey+    , tYPETyConKey+    , cONSTRAINTTyConKey+    , runtimeRepTyConKey, boxedRepDataConKey+    , eqTyConKey+    , listTyConKey+    , oneDataConKey+    , manyDataConKey+    , fUNTyConKey, unrestrictedFunTyConKey ]
compiler/GHC/Builtin/Types.hs-boot view
@@ -15,6 +15,7 @@ coercibleTyCon, heqTyCon :: TyCon  unitTy :: Type+unitTyCon :: TyCon  liftedTypeKindTyConName :: Name constraintKindTyConName :: Name
+ compiler/GHC/Builtin/Types/Literals.hs view
@@ -0,0 +1,1176 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}   -- See calls to mkTemplateTyVars++module GHC.Builtin.Types.Literals+  ( tryInteractInertFam, tryInteractTopFam, tryMatchFam++  , typeNatTyCons+  , typeNatCoAxiomRules+  , BuiltInSynFamily(..)++    -- If you define a new built-in type family, make sure to export its TyCon+    -- from here as well.+    -- See Note [Adding built-in type families]+  , typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatSubTyCon+  , typeNatDivTyCon+  , typeNatModTyCon+  , typeNatLogTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  , typeCharCmpTyCon+  , typeConsSymbolTyCon+  , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon+  ) where++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.Unify      ( tcMatchTys )+import GHC.Data.Pair+import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon, tyConArity+                         , Injectivity(..), isBuiltInSynFamTyCon_maybe )+import GHC.Core.Coercion.Axiom+import GHC.Core.TyCo.Compare   ( tcEqType )+import GHC.Types.Name          ( Name, BuiltInSyntax(..) )+import GHC.Types.Unique.FM+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders, mkTemplateTyVars )+import GHC.Builtin.Names+                  ( gHC_INTERNAL_TYPELITS+                  , gHC_INTERNAL_TYPELITS_INTERNAL+                  , gHC_INTERNAL_TYPENATS+                  , gHC_INTERNAL_TYPENATS_INTERNAL+                  , typeNatAddTyFamNameKey+                  , typeNatMulTyFamNameKey+                  , typeNatExpTyFamNameKey+                  , typeNatSubTyFamNameKey+                  , typeNatDivTyFamNameKey+                  , typeNatModTyFamNameKey+                  , typeNatLogTyFamNameKey+                  , typeNatCmpTyFamNameKey+                  , typeSymbolCmpTyFamNameKey+                  , typeSymbolAppendFamNameKey+                  , typeCharCmpTyFamNameKey+                  , typeConsSymbolTyFamNameKey+                  , typeUnconsSymbolTyFamNameKey+                  , typeCharToNatTyFamNameKey+                  , typeNatToCharTyFamNameKey+                  )+import GHC.Data.FastString+import GHC.Utils.Panic+import GHC.Utils.Outputable++import Control.Monad ( guard )+import Data.List  ( isPrefixOf, isSuffixOf )+import Data.Maybe ( listToMaybe )+import qualified Data.Char as Char++{-+Note [Type-level literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~+There are currently three forms of type-level literals: natural numbers, symbols, and+characters.++Type-level literals are supported by CoAxiomRules (conditional axioms), which+power the built-in type families (see Note [Adding built-in type families]).+Currently, all built-in type families are for the express purpose of supporting+type-level literals.++See also the Wiki page:++    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats++Note [Adding built-in type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a few steps to adding a built-in type family:++* Adding a unique for the type family TyCon++  These go in GHC.Builtin.Names. It will likely be of the form+  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that+  has not been chosen before in GHC.Builtin.Names. There are several examples already+  in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey.++* Adding the type family TyCon itself++  This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define+  these -- see, for instance, typeNatAddTyCon.++  Once your TyCon has been defined, be sure to:++  - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.)+  - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals.++* Define the type family somewhere++  Finally, you will need to define the type family somewhere, likely in @base@.+  Currently, all of the built-in type families are defined in GHC.TypeLits or+  GHC.TypeNats, so those are likely candidates.++  Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals,+  you should give an open type family definition with no instances, like so:++    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat++  Changing the argument and result kinds as appropriate.++* Update the relevant test cases++  The GHC test suite will likely need to be updated after you add your built-in+  type family. For instance:++  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added+    a test there, the expected output of T9181 will need to change.+  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit+    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have+    runtime unit tests. Consider adding further unit tests to those if your+    built-in type family deals with Nats or Symbols, respectively.++Note [Inlining axiom constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have a number of constructor functions with types like+   mkUnaryConstFoldAxiom :: TyCon -> String+                         -> (Type -> Maybe a)+                         -> (a -> Maybe Type)+                         -> BuiltInFamRewrite++For very type-family-heavy code, these higher order argument are inefficient;+e.g. the fourth argument might always return (Just ty) in the above. Inlining+them is a bit brutal, but not bad, makes a few-percent difference in, say+perf test T13386.++These functions aren't exported, so the effect is very local.++-}++-------------------------------------------------------------------------------+--     Key utility functions+-------------------------------------------------------------------------------++tryInteractTopFam :: BuiltInSynFamily -> TyCon -> [Type] -> Type+                  -> [(CoAxiomRule, TypeEqn)]+-- The returned CoAxiomRule is always unary+tryInteractTopFam fam fam_tc tys r+  = [(bifinj_axr bif, eqn_out) | bif  <- sfInteract fam+                               , Just eqn_out <- [bifinj_proves bif eqn_in] ]+  where+    eqn_in :: TypeEqn+    eqn_in = Pair (mkTyConApp fam_tc tys) r++tryInteractInertFam :: BuiltInSynFamily -> TyCon+                    -> [Type] -> [Type] -- F tys1 ~ F tys2+                    -> [(CoAxiomRule, TypeEqn)]+tryInteractInertFam builtin_fam fam_tc tys1 tys2+  = [(bifinj_axr bif, eqn_out) | bif <- sfInteract builtin_fam+                               , Just eqn_out <- [bifinj_proves bif eqn_in] ]+  where+    eqn_in = Pair (mkTyConApp fam_tc tys1) (mkTyConApp fam_tc tys2)++tryMatchFam :: BuiltInSynFamily -> [Type]+            -> Maybe (CoAxiomRule, [Type], Type)+-- Does this reduce on the given arguments?+-- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)+-- That is: mkAxiomCo (BuiltInFamRew ax) (map mkNomReflCo ts)+--              :: F tys ~r rhs,+tryMatchFam builtin_fam arg_tys+  = listToMaybe $   -- Pick first rule to match+    [ (bifrw_axr rw_ax, inst_tys, res_ty)+    | rw_ax <- sfMatchFam builtin_fam+    , Just (inst_tys,res_ty) <- [bifrw_match rw_ax arg_tys] ]++-------------------------------------------------------------------------------+--          Constructing BuiltInFamInjectivity, BuiltInFamRewrite+-------------------------------------------------------------------------------++mkUnaryConstFoldAxiom :: TyCon -> String+                      -> (Type -> Maybe a)+                      -> (a -> Maybe Type)+                      -> BuiltInFamRewrite+-- For the definitional axioms, like  (3+4 --> 7)+{-# INLINE mkUnaryConstFoldAxiom #-}  -- See Note [Inlining axiom constructors]+mkUnaryConstFoldAxiom fam_tc str isReqTy f+  = bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = 1+      , bifrw_match  = \ts -> do { [t1] <- return ts+                                 ; t1' <- isReqTy t1+                                 ; res <- f t1'+                                 ; return ([t1], res) }+      , bifrw_proves = \cs -> do { [Pair s1 s2] <- return cs+                                 ; s2' <- isReqTy s2+                                 ; z   <- f s2'+                                 ; return (mkTyConApp fam_tc [s1] === z) }+      }++mkBinConstFoldAxiom :: TyCon -> String+                    -> (Type -> Maybe a)+                    -> (Type -> Maybe b)+                    -> (a -> b -> Maybe Type)+                    -> BuiltInFamRewrite+-- For the definitional axioms, like  (3+4 --> 7)+{-# INLINE mkBinConstFoldAxiom #-}  -- See Note [Inlining axiom constructors]+mkBinConstFoldAxiom fam_tc str isReqTy1 isReqTy2 f+  = bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = 2+      , bifrw_match  = \ts -> do { [t1,t2] <- return ts+                                 ; t1' <- isReqTy1 t1+                                 ; t2' <- isReqTy2 t2+                                 ; res <- f t1' t2'+                                 ; return ([t1,t2], res) }+      , bifrw_proves = \cs -> do { [Pair s1 s2, Pair t1 t2] <- return cs+                                 ; s2' <- isReqTy1 s2+                                 ; t2' <- isReqTy2 t2+                                 ; z   <- f s2' t2'+                                 ; return (mkTyConApp fam_tc [s1,t1] === z) }+      }++mkRewriteAxiom :: TyCon -> String+               -> [TyVar] -> [Type]  -- LHS of axiom+               -> Type               -- RHS of axiom+               -> BuiltInFamRewrite+-- Not higher order, no benefit in inlining+-- See Note [Inlining axiom constructors]+mkRewriteAxiom fam_tc str tpl_tvs lhs_tys rhs_ty+  = assertPpr (tyConArity fam_tc == length lhs_tys) (text str <+> ppr lhs_tys) $+    bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = bif_arity+      , bifrw_match  = match_fn+      , bifrw_proves = inst_fn }++    bif_arity = length tpl_tvs++    match_fn :: [Type] -> Maybe ([Type],Type)+    match_fn arg_tys+      = assertPpr (tyConArity fam_tc == length arg_tys) (text str <+> ppr arg_tys) $+        case tcMatchTys lhs_tys arg_tys of+          Nothing    -> Nothing+          Just subst -> Just (substTyVars subst tpl_tvs, substTy subst rhs_ty)++    inst_fn :: [TypeEqn] -> Maybe TypeEqn+    inst_fn inst_eqns+      = assertPpr (length inst_eqns == bif_arity) (text str $$ ppr inst_eqns) $+        Just (mkTyConApp fam_tc (substTys (zipTCvSubst tpl_tvs tys1) lhs_tys)+              ===+              substTy (zipTCvSubst tpl_tvs tys2) rhs_ty)+      where+        (tys1, tys2) = unzipPairs inst_eqns++mkTopUnaryFamDeduction :: String -> TyCon+                     -> (Type -> Type -> Maybe TypeEqn)+                     -> BuiltInFamInjectivity+-- Deduction from (F s ~ r) where `F` is a unary type function+{-# INLINE mkTopUnaryFamDeduction #-}  -- See Note [Inlining axiom constructors]+mkTopUnaryFamDeduction str fam_tc f+  = bif+  where+    bif = BIF_Interact+      { bifinj_name   = fsLit str+      , bifinj_axr    = BuiltInFamInj bif+      , bifinj_proves = \(Pair lhs rhs)+                        -> do { (tc, [a]) <- splitTyConApp_maybe lhs+                              ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc)+                              ; f a rhs } }++mkTopBinFamDeduction :: String -> TyCon+                     -> (Type -> Type -> Type -> Maybe TypeEqn)+                     -> BuiltInFamInjectivity+-- Deduction from (F s t  ~ r) where `F` is a binary type function+{-# INLINE mkTopBinFamDeduction #-}  -- See Note [Inlining axiom constructors]+mkTopBinFamDeduction str fam_tc f+  = bif+  where+    bif = BIF_Interact+      { bifinj_name   = fsLit str+      , bifinj_axr    = BuiltInFamInj bif+      , bifinj_proves = \(Pair lhs rhs) ->+                        do { (tc, [a,b]) <- splitTyConApp_maybe lhs+                           ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc)+                           ; f a b rhs } }++mkUnaryBIF :: String -> TyCon -> BuiltInFamInjectivity+-- Not higher order, no benefit in inlining+-- See Note [Inlining axiom constructors]+mkUnaryBIF str fam_tc+  = bif+  where+    bif = BIF_Interact { bifinj_name   = fsLit str+                       , bifinj_axr    = BuiltInFamInj bif+                       , bifinj_proves = proves }+    proves (Pair lhs rhs)+      = do { (tc2, [x2]) <- splitTyConApp_maybe rhs+           ; guard (tc2 == fam_tc)+           ; (tc1, [x1]) <- splitTyConApp_maybe lhs+           ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc)+           ; return (Pair x1 x2) }++mkBinBIF :: String -> TyCon+         -> WhichArg -> WhichArg+         -> (Type -> Bool)         -- The guard on the equal args, if any+         -> BuiltInFamInjectivity+{-# INLINE mkBinBIF #-}  -- See Note [Inlining axiom constructors]+mkBinBIF str fam_tc eq1 eq2 check_me+  = bif+  where+    bif = BIF_Interact { bifinj_name   = fsLit str+                       , bifinj_axr    = BuiltInFamInj bif+                       , bifinj_proves = proves }+    proves (Pair lhs rhs)+      = do { (tc2, [x2,y2]) <- splitTyConApp_maybe rhs+           ; guard (tc2 == fam_tc)+           ; (tc1, [x1,y1]) <- splitTyConApp_maybe lhs+           ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc)+           ; case (eq1, eq2) of+               (ArgX,ArgX) -> do_it x1 x2 y1 y2+               (ArgX,ArgY) -> do_it x1 y2 x2 y1+               (ArgY,ArgX) -> do_it y1 x2 y2 x1+               (ArgY,ArgY) -> do_it y1 y2 x1 x2 }++    do_it a1 a2 b1 b2 = do { same a1 a2; guard (check_me a1); return (Pair b1 b2) }++noGuard :: Type -> Bool+noGuard _ = True++numGuard :: (Integer -> Bool) -> Type -> Bool+numGuard pred ty = case isNumLitTy ty of+                      Just n  -> pred n+                      Nothing -> False++data WhichArg = ArgX | ArgY+++-------------------------------------------------------------------------------+--     Built-in type constructors for functions on type-level nats+-------------------------------------------------------------------------------++-- The list of built-in type family TyCons that GHC uses.+-- If you define a built-in type family, make sure to add it to this list.+-- See Note [Adding built-in type families]+typeNatTyCons :: [TyCon]+typeNatTyCons =+  [ typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatSubTyCon+  , typeNatDivTyCon+  , typeNatModTyCon+  , typeNatLogTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  , typeCharCmpTyCon+  , typeConsSymbolTyCon+  , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon+  ]+++-- The list of built-in type family axioms that GHC uses.+-- If you define new axioms, make sure to include them in this list.+-- See Note [Adding built-in type families]+typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule+typeNatCoAxiomRules+  = listToUFM $+    [ pr | tc <- typeNatTyCons+         , Just ops <- [isBuiltInSynFamTyCon_maybe tc]+         , pr <- [ (bifinj_name bif, bifinj_axr bif) | bif <- sfInteract ops ]+              ++ [ (bifrw_name bif,  bifrw_axr bif)  | bif <- sfMatchFam ops ] ]++-------------------------------------------------------------------------------+--                   Addition (+)+-------------------------------------------------------------------------------++typeNatAddTyCon :: TyCon+typeNatAddTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam  = axAddRewrites+    , sfInteract  = axAddInjectivity+    }+  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+")+              typeNatAddTyFamNameKey typeNatAddTyCon+++sn,tn :: TyVar  -- Of kind Natural+(sn: tn: _) = mkTemplateTyVars (repeat typeSymbolKind)++axAddRewrites :: [BuiltInFamRewrite]+axAddRewrites+  = [ mkRewriteAxiom   tc "Add0L" [tn] [num 0, var tn] (var tn)   -- 0 + t --> t+    , mkRewriteAxiom   tc "Add0R" [sn] [var sn, num 0] (var sn)   -- s + 0 --> s+    , mkBinConstFoldAxiom tc "AddDef" isNumLitTy isNumLitTy $     -- 3 + 4 --> 7+      \x y -> Just $ num (x + y) ]+  where+    tc = typeNatAddTyCon++axAddInjectivity :: [BuiltInFamInjectivity]+axAddInjectivity+  = [ -- (s + t ~ 0) => (s ~ 0)+      mkTopBinFamDeduction "AddT-0L" tc $ \ a _b r ->+      do { _ <- known r (== 0); return (Pair a (num 0)) }++    , -- (s + t ~ 0) => (t ~ 0)+      mkTopBinFamDeduction "AddT-0R" tc $ \ _a b r ->+      do { _ <- known r (== 0); return (Pair b (num 0)) }++    , -- (5 + t ~ 8) => (t ~ 3)+      mkTopBinFamDeduction "AddT-KKL" tc $ \ a b r ->+      do { na <- isNumLitTy a; nr <- known r (>= na); return (Pair b (num (nr-na))) }++    , -- (s + 5 ~ 8) => (s ~ 3)+      mkTopBinFamDeduction "AddT-KKR" tc $ \ a b r ->+      do { nb <- isNumLitTy b; nr <- known r (>= nb); return (Pair a (num (nr-nb))) }++    , mkBinBIF "AddI-xx" tc ArgX ArgX noGuard  -- x1+y1~x2+y2 {x1=x2}=> (y1 ~ y2)+    , mkBinBIF "AddI-xy" tc ArgX ArgY noGuard  -- x1+y1~x2+y2 {x1=y2}=> (x2 ~ y1)+    , mkBinBIF "AddI-yx" tc ArgY ArgX noGuard  -- x1+y1~x2+y2 {y1=x2}=> (x1 ~ y2)+    , mkBinBIF "AddI-yy" tc ArgY ArgY noGuard  -- x1+y1~x2+y2 {y1=y2}=> (x1 ~ x2)+    ]+  where+    tc = typeNatAddTyCon++-------------------------------------------------------------------------------+--                   Subtraction (-)+-------------------------------------------------------------------------------++typeNatSubTyCon :: TyCon+typeNatSubTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam = axSubRewrites+    , sfInteract = axSubInjectivity+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-")+            typeNatSubTyFamNameKey typeNatSubTyCon++axSubRewrites :: [BuiltInFamRewrite]+axSubRewrites+  = [ mkRewriteAxiom   tc "Sub0R" [sn] [var sn, num 0] (var sn)   -- s - 0 --> s+    , mkBinConstFoldAxiom tc "SubDef" isNumLitTy isNumLitTy $     -- 4 - 3 --> 1  if x>=y+      \x y -> fmap num (minus x y) ]+  where+    tc = typeNatSubTyCon++axSubInjectivity :: [BuiltInFamInjectivity]+axSubInjectivity+  = [ -- (a - b ~ 5) => (5 + b ~ a)+      mkTopBinFamDeduction "SubT" tc $ \ a b r ->+      do { _ <- isNumLitTy r; return (Pair (r .+. b) a) }++    , mkBinBIF "SubI-xx" tc ArgX ArgX noGuard -- (x-y1 ~ x-y2) => (y1 ~ y2)+    , mkBinBIF "SubI-yy" tc ArgY ArgY noGuard -- (x1-y ~ x2-y) => (x1 ~ x2)+    ]+  where+    tc = typeNatSubTyCon++{-+Note [Weakened interaction rule for subtraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A simpler interaction here might be:++  `s - t ~ r` --> `t + r ~ s`++This would enable us to reuse all the code for addition.+Unfortunately, this works a little too well at the moment.+Consider the following example:++    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)++This (correctly) spots that the constraint cannot be solved.++However, this may be a problem if the constraint did not+need to be solved in the first place!  Consider the following example:++f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5+f = id++Currently, GHC is strict while evaluating functions, so this does not+work, because even though the `If` should evaluate to `5 - 0`, we+also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,+which fails.++So, for the time being, we only add an improvement when the RHS is a constant,+which happens to work OK for the moment, although clearly we need to do+something more general.+-}+++-------------------------------------------------------------------------------+--                   Multiplication (*)+-------------------------------------------------------------------------------++typeNatMulTyCon :: TyCon+typeNatMulTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axMulRewrites+                   , sfInteract = axMulInjectivity  }+  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*")+              typeNatMulTyFamNameKey typeNatMulTyCon++axMulRewrites :: [BuiltInFamRewrite]+axMulRewrites+  = [ mkRewriteAxiom   tc "Mul0L" [tn] [num 0, var tn] (num 0)   -- 0 * t --> 0+    , mkRewriteAxiom   tc "Mul0R" [sn] [var sn, num 0] (num 0)   -- s * 0 --> 0+    , mkRewriteAxiom   tc "Mul1L" [tn] [num 1, var tn] (var tn)  -- 1 * t --> t+    , mkRewriteAxiom   tc "Mul1R" [sn] [var sn, num 1] (var sn)  -- s * 1 --> s+    , mkBinConstFoldAxiom tc "MulDef" isNumLitTy isNumLitTy $    -- 3 + 4 --> 12+      \x y -> Just $ num (x * y) ]+  where+    tc = typeNatMulTyCon++axMulInjectivity :: [BuiltInFamInjectivity]+axMulInjectivity+  = [ -- (s * t ~ 1)  => (s ~ 1)+      mkTopBinFamDeduction "MulT1" tc $ \ s _t r ->+      do { _ <- known r (== 1); return (Pair s r) }++    , -- (s * t ~ 1)  => (t ~ 1)+      mkTopBinFamDeduction "MulT2" tc $ \ _s t r ->+      do { _ <- known r (== 1); return (Pair t r) }++    , -- (3 * t ~ 15) => (t ~ 5)+      mkTopBinFamDeduction "MulT3" tc $ \ s t r ->+      do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- divide nr ns; return (Pair t (num y)) }++    , -- (s * 3 ~ 15) => (s ~ 5)+      mkTopBinFamDeduction "MulT4" tc $ \ s t r ->+      do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- divide nr nt; return (Pair s (num y)) }++    , mkBinBIF "MulI-xx" tc ArgX ArgX (numGuard (/= 0))    -- (x*y1 ~ x*y2) {x/=0}=> (y1 ~ y2)+    , mkBinBIF "MulI-yy" tc ArgY ArgY (numGuard (/= 0))    -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2)+    ]+  where+    tc = typeNatMulTyCon+++-------------------------------------------------------------------------------+--                   Division: Div and Mod+-------------------------------------------------------------------------------++typeNatDivTyCon :: TyCon+typeNatDivTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axDivRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div")+            typeNatDivTyFamNameKey typeNatDivTyCon++typeNatModTyCon :: TyCon+typeNatModTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axModRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod")+            typeNatModTyFamNameKey typeNatModTyCon++axDivRewrites :: [BuiltInFamRewrite]+axDivRewrites+  = [ mkRewriteAxiom   tc "Div1" [sn] [var sn, num 1] (var sn)   -- s `div` 1 --> s+    , mkBinConstFoldAxiom tc "DivDef" isNumLitTy isNumLitTy $    -- 8 `div` 4 --> 2+      \x y -> do { guard (y /= 0); return (num (div x y)) } ]+  where+    tc = typeNatDivTyCon++axModRewrites :: [BuiltInFamRewrite]+axModRewrites+  = [ mkRewriteAxiom   tc "Mod1" [sn] [var sn, num 1] (num 0)   -- s `mod` 1 --> 0+    , mkBinConstFoldAxiom tc "ModDef" isNumLitTy isNumLitTy $   -- 8 `mod` 3 --> 2+      \x y -> do { guard (y /= 0); return (num (mod x y)) } ]+  where+    tc = typeNatModTyCon++-------------------------------------------------------------------------------+--                   Exponentiation: Exp+-------------------------------------------------------------------------------++typeNatExpTyCon :: TyCon  -- Exponentiation+typeNatExpTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axExpRewrites+                   , sfInteract = axExpInjectivity }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^")+                typeNatExpTyFamNameKey typeNatExpTyCon++axExpRewrites :: [BuiltInFamRewrite]+axExpRewrites+  = [ mkRewriteAxiom   tc "Exp0R" [sn] [var sn, num 0] (num 1)   -- s ^ 0 --> 1+    , mkRewriteAxiom   tc "Exp1L" [tn] [num 1, var tn] (num 1)   -- 1 ^ t --> 1+    , mkRewriteAxiom   tc "Exp1R" [sn] [var sn, num 1] (var sn)  -- s ^ 1 --> s+    , mkBinConstFoldAxiom tc "ExpDef" isNumLitTy isNumLitTy $    -- 2 ^ 3 --> 8+      \x y -> Just (num (x ^ y)) ]+  where+    tc = typeNatExpTyCon++axExpInjectivity :: [BuiltInFamInjectivity]+axExpInjectivity+  = [ -- (s ^ t ~ 0) => (s ~ 0)+      mkTopBinFamDeduction "ExpT1" tc $ \ s _t r ->+      do { 0 <- isNumLitTy r; return (Pair s r) }++    , -- (2 ^ t ~ 8) => (t ~ 3)+      mkTopBinFamDeduction "ExpT2" tc $ \ s t r ->+      do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- logExact nr ns; return (Pair t (num y)) }++    , -- (s ^ 2 ~ 9) => (s ~ 3)+      mkTopBinFamDeduction "ExpT3" tc $ \ s t r ->+      do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- rootExact nr nt; return (Pair s (num y)) }++    , mkBinBIF "ExpI-xx" tc ArgX ArgX (numGuard (> 1))    -- (x^y1 ~ x^y2) {x>1}=> (y1 ~ y2)+    , mkBinBIF "ExpI-yy" tc ArgY ArgY (numGuard (/= 0))   -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2)+    ]+  where+    tc = typeNatExpTyCon++-------------------------------------------------------------------------------+--                   Logarithm: Log2+-------------------------------------------------------------------------------++typeNatLogTyCon :: TyCon+typeNatLogTyCon = mkTypeNatFunTyCon1 name+  BuiltInSynFamily { sfMatchFam = axLogRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2")+            typeNatLogTyFamNameKey typeNatLogTyCon++axLogRewrites :: [BuiltInFamRewrite]+axLogRewrites+  = [ mkUnaryConstFoldAxiom tc "LogDef" isNumLitTy $       -- log 8 --> 3+      \x -> do { (a,_) <- genLog x 2; return (num a) } ]+  where+    tc = typeNatLogTyCon++-------------------------------------------------------------------------------+--               Comparision of Nats: CmpNat+-------------------------------------------------------------------------------++typeNatCmpTyCon :: TyCon+typeNatCmpTyCon+  = mkFamilyTyCon name+      (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+      orderingKind+      Nothing+      (BuiltInSynFamTyCon ops)+      Nothing+      NotInjective++  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS_INTERNAL (fsLit "CmpNat")+                  typeNatCmpTyFamNameKey typeNatCmpTyCon+    ops = BuiltInSynFamily { sfMatchFam = axCmpNatRewrites+                           , sfInteract = axCmpNatInjectivity }++axCmpNatRewrites :: [BuiltInFamRewrite]+axCmpNatRewrites+  = [ mkRewriteAxiom   tc "CmpNatRefl" [sn] [var sn, var sn] (ordering EQ)    -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpNatDef" isNumLitTy isNumLitTy $              -- 2 `cmp` 3 --> LT+      \x y -> Just (ordering (compare x y)) ]+  where+    tc = typeNatCmpTyCon++axCmpNatInjectivity :: [BuiltInFamInjectivity]+axCmpNatInjectivity+  = [ -- s `cmp` t ~ EQ   ==>   s ~ t+      mkTopBinFamDeduction "CmpNatT3" typeNatCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]++-------------------------------------------------------------------------------+--              Comparsion of Symbols: CmpSymbol+-------------------------------------------------------------------------------++typeSymbolCmpTyCon :: TyCon+typeSymbolCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [typeSymbolKind, typeSymbolKind])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpSymbol")+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon+  ops = BuiltInSynFamily { sfMatchFam = axSymbolCmpRewrites+                         , sfInteract = axSymbolCmpInjectivity }++ss,ts :: TyVar  -- Of kind Symbol+(ss: ts: _) = mkTemplateTyVars (repeat typeSymbolKind)++axSymbolCmpRewrites :: [BuiltInFamRewrite]+axSymbolCmpRewrites+  = [ mkRewriteAxiom   tc "CmpSymbolRefl" [ss] [var ss, var ss] (ordering EQ) -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpSymbolDef" isStrLitTy isStrLitTy $           -- "a" `cmp` "b" --> LT+      \x y -> Just (ordering (lexicalCompareFS x y)) ]+  where+    tc = typeSymbolCmpTyCon++axSymbolCmpInjectivity :: [BuiltInFamInjectivity]+axSymbolCmpInjectivity+  = [ mkTopBinFamDeduction "CmpSymbolT" typeSymbolCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]+++-------------------------------------------------------------------------------+--            AppendSymbol+-------------------------------------------------------------------------------++typeSymbolAppendTyCon :: TyCon+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axAppendRewrites+                   , sfInteract = axAppendInjectivity }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol")+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon++axAppendRewrites :: [BuiltInFamRewrite]+axAppendRewrites+  = [ mkRewriteAxiom   tc "Concat0R" [ts] [nullStrLitTy, var ts] (var ts) -- "" ++ t --> t+    , mkRewriteAxiom   tc "Concat0L" [ss] [var ss, nullStrLitTy] (var ss) -- s ++ "" --> s+    , mkBinConstFoldAxiom tc "AppendSymbolDef" isStrLitTy isStrLitTy $    -- "a" ++ "b" --> "ab"+      \x y -> Just (mkStrLitTy (appendFS x y)) ]+  where+    tc = typeSymbolAppendTyCon++axAppendInjectivity :: [BuiltInFamInjectivity]+axAppendInjectivity+ = [ -- (AppendSymbol a b ~ "") => (a ~ "")+     mkTopBinFamDeduction "AppendSymbolT1" tc $ \ a _b r ->+     do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair a nullStrLitTy) }++   , -- (AppendSymbol a b ~ "") => (b ~ "")+     mkTopBinFamDeduction "AppendSymbolT2" tc $ \ _a b r ->+     do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair b nullStrLitTy) }++   , -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")+     mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r ->+     do { as <- isStrLitTyS a; rs <- isStrLitTyS r; guard (as `isPrefixOf` rs)+        ; return (Pair b (mkStrLitTyS (drop (length as) rs))) }++   , -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")+     mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r ->+     do { bs <- isStrLitTyS b; rs <- isStrLitTyS r; guard (bs `isSuffixOf` rs)+        ; return (Pair a (mkStrLitTyS (take (length rs - length bs) rs))) }++    , mkBinBIF "AppI-xx" tc ArgX ArgX noGuard  -- (x++y1 ~ x++y2) => (y1 ~ y2)+    , mkBinBIF "AppI-yy" tc ArgY ArgY noGuard  -- (x1++y ~ x2++y) => (x1 ~ x2)+    ]+  where+    tc = typeSymbolAppendTyCon++-------------------------------------------------------------------------------+--            ConsSymbol+-------------------------------------------------------------------------------++typeConsSymbolTyCon :: TyCon+typeConsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True, True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "ConsSymbol")+                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon+  ops = BuiltInSynFamily  { sfMatchFam = axConsRewrites+                          , sfInteract = axConsInjectivity }++axConsRewrites :: [BuiltInFamRewrite]+axConsRewrites+  = [ mkBinConstFoldAxiom tc "ConsSymbolDef" isCharLitTy isStrLitTy $    -- 'a' : "bc" --> "abc"+      \x y -> Just $ mkStrLitTy (consFS x y) ]+  where+    tc = typeConsSymbolTyCon++axConsInjectivity :: [BuiltInFamInjectivity]+axConsInjectivity+  = [ -- ConsSymbol a b ~ "blah" => (a ~ 'b')+      mkTopBinFamDeduction "ConsSymbolT1" tc $ \ a _b r ->+      do { rs <- isStrLitTy r; (x,_) <- unconsFS rs; return (Pair a (mkCharLitTy x)) }++    , -- ConsSymbol a b ~ "blah" => (b ~ "lah")+      mkTopBinFamDeduction "ConsSymbolT2" tc $ \ _a b r ->+      do { rs <- isStrLitTy r; (_,xs) <- unconsFS rs; return (Pair b (mkStrLitTy xs)) }+++    , mkBinBIF "ConsI-xx" tc ArgX ArgX noGuard  -- (x:y1 ~ x:y2) => (y1 ~ y2)+    , mkBinBIF "ConsI-yy" tc ArgY ArgY noGuard  -- (x1:y ~ x2:y) => (x1 ~ x2)+    ]+  where+    tc = typeConsSymbolTyCon++-------------------------------------------------------------------------------+--            UnconsSymbol+-------------------------------------------------------------------------------++typeUnconsSymbolTyCon :: TyCon+typeUnconsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeSymbolKind ])+    (mkMaybeTy charSymbolPairKind)+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "UnconsSymbol")+                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon+  ops = BuiltInSynFamily { sfMatchFam = axUnconsRewrites+                         , sfInteract = axUnconsInjectivity }++computeUncons :: FastString -> Type+computeUncons str+  = mkPromotedMaybeTy charSymbolPairKind (fmap reify (unconsFS str))+  where+    reify :: (Char, FastString) -> Type+    reify (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)++axUnconsRewrites :: [BuiltInFamRewrite]+axUnconsRewrites+  = [ mkUnaryConstFoldAxiom tc "ConsSymbolDef" isStrLitTy $    -- 'a' : "bc" --> "abc"+      \x -> Just $ computeUncons x ]+  where+    tc = typeUnconsSymbolTyCon++axUnconsInjectivity :: [BuiltInFamInjectivity]+axUnconsInjectivity+  = [ -- (UnconsSymbol b ~ Nothing) => (b ~ "")+      mkTopUnaryFamDeduction "UnconsSymbolT1" tc $ \b r ->+      do { Nothing  <- isPromotedMaybeTy r; return (Pair b nullStrLitTy) }++    , -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")+      mkTopUnaryFamDeduction "UnconsSymbolT2" tc $ \b r ->+      do { Just pr <- isPromotedMaybeTy r+         ; (c,s) <- isPromotedPairType pr+         ; chr <- isCharLitTy c+         ; str <- isStrLitTy s+         ; return (Pair b (mkStrLitTy (consFS chr str))) }++    , mkUnaryBIF "UnconsI1" tc  -- (UnconsSymbol x1 ~ z, UnconsSymbol x2 ~ z) => (x1 ~ x2)+    ]+  where+    tc = typeUnconsSymbolTyCon++-------------------------------------------------------------------------------+--            CharToNat+-------------------------------------------------------------------------------++typeCharToNatTyCon :: TyCon+typeCharToNatTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "CharToNat")+                  typeCharToNatTyFamNameKey typeCharToNatTyCon+  ops = BuiltInSynFamily { sfMatchFam = axCharToNatRewrites+                         , sfInteract = axCharToNatInjectivity }++axCharToNatRewrites :: [BuiltInFamRewrite]+axCharToNatRewrites+  = [ mkUnaryConstFoldAxiom tc "CharToNatDef" isCharLitTy $    -- CharToNat 'a' --> 97+      \x -> Just $ num (charToInteger x) ]+  where+    tc = typeCharToNatTyCon++axCharToNatInjectivity :: [BuiltInFamInjectivity]+axCharToNatInjectivity+  = [ -- (CharToNat c ~ 122) => (c ~ 'z')+      mkTopUnaryFamDeduction "CharToNatT1" typeCharToNatTyCon $ \c r ->+      do { nr <- isNumLitTy r; chr <- integerToChar nr; return (Pair c (mkCharLitTy chr)) } ]++-------------------------------------------------------------------------------+--            NatToChar+-------------------------------------------------------------------------------++typeNatToCharTyCon :: TyCon+typeNatToCharTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ naturalTy ])+    charTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "NatToChar")+                  typeNatToCharTyFamNameKey typeNatToCharTyCon+  ops = BuiltInSynFamily { sfMatchFam = axNatToCharRewrites+                         , sfInteract = axNatToCharInjectivity }++axNatToCharRewrites :: [BuiltInFamRewrite]+axNatToCharRewrites+  = [ mkUnaryConstFoldAxiom tc "NatToCharDef" isNumLitTy $    -- NatToChar 97 --> 'a'+      \n -> fmap mkCharLitTy (integerToChar n) ]+  where+    tc = typeNatToCharTyCon++axNatToCharInjectivity :: [BuiltInFamInjectivity]+axNatToCharInjectivity+  = [ -- (NatToChar n ~ 'z') => (n ~ 122)+      mkTopUnaryFamDeduction "CharToNatT1" typeNatToCharTyCon $ \n r ->+      do { c <- isCharLitTy r; return (Pair n (mkNumLitTy (charToInteger c))) } ]+++-----------------------------------------------------------------------------+--                       CmpChar+-----------------------------------------------------------------------------++typeCharCmpTyCon :: TyCon+typeCharCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, charTy ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpChar")+                  typeCharCmpTyFamNameKey typeCharCmpTyCon+  ops = BuiltInSynFamily { sfMatchFam = axCharCmpRewrites+                         , sfInteract = axCharCmpInjectivity }++sc :: TyVar  -- Of kind Char+(sc: _) = mkTemplateTyVars (repeat charTy)++axCharCmpRewrites :: [BuiltInFamRewrite]+axCharCmpRewrites+  = [ mkRewriteAxiom   tc "CmpCharRefl" [sc] [var sc, var sc] (ordering EQ) -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpCharDef" isCharLitTy isCharLitTy $         -- 'a' `cmp` 'b' --> LT+      \chr1 chr2 -> Just $ ordering $ compare chr1 chr2 ]+  where+    tc = typeCharCmpTyCon++axCharCmpInjectivity :: [BuiltInFamInjectivity]+axCharCmpInjectivity+  = [  -- (CmpChar s t ~ EQ) => s ~ t+      mkTopBinFamDeduction "CmpCharT" typeCharCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]+++{-------------------------------------------------------------------------------+Various utilities for making axioms and types+-------------------------------------------------------------------------------}++(===) :: Type -> Type -> Pair Type+x === y = Pair x y++num :: Integer -> Type+num = mkNumLitTy++var :: TyVar -> Type+var = mkTyVarTy++(.+.) :: Type -> Type -> Type+s .+. t = mkTyConApp typeNatAddTyCon [s,t]++{-+(.-.) :: Type -> Type -> Type+s .-. t = mkTyConApp typeNatSubTyCon [s,t]++(.*.) :: Type -> Type -> Type+s .*. t = mkTyConApp typeNatMulTyCon [s,t]++tDiv :: Type -> Type -> Type+tDiv s t = mkTyConApp typeNatDivTyCon [s,t]++tMod :: Type -> Type -> Type+tMod s t = mkTyConApp typeNatModTyCon [s,t]++(.^.) :: Type -> Type -> Type+s .^. t = mkTyConApp typeNatExpTyCon [s,t]++cmpNat :: Type -> Type -> Type+cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]++cmpSymbol :: Type -> Type -> Type+cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]++appendSymbol :: Type -> Type -> Type+appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]+-}+++nullStrLitTy :: Type  -- The type ""+nullStrLitTy = mkStrLitTy nilFS++isStrLitTyS :: Type -> Maybe String+isStrLitTyS ty = do { fs <- isStrLitTy ty; return (unpackFS fs) }++mkStrLitTyS :: String -> Type+mkStrLitTyS s = mkStrLitTy (mkFastString s)++charSymbolPair :: Type -> Type -> Type+charSymbolPair = mkPromotedPairTy charTy typeSymbolKind++charSymbolPairKind :: Kind+charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind]++orderingKind :: Kind+orderingKind = mkTyConApp orderingTyCon []++ordering :: Ordering -> Type+ordering o =+  case o of+    LT -> mkTyConApp promotedLTDataCon []+    EQ -> mkTyConApp promotedEQDataCon []+    GT -> mkTyConApp promotedGTDataCon []++isOrderingLitTy :: Type -> Maybe Ordering+isOrderingLitTy tc =+  do (tc1,[]) <- splitTyConApp_maybe tc+     case () of+       _ | tc1 == promotedLTDataCon -> return LT+         | tc1 == promotedEQDataCon -> return EQ+         | tc1 == promotedGTDataCon -> return GT+         | otherwise                -> Nothing++-- Make a unary built-in constructor of kind: Nat -> Nat+mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon1 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ naturalTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat+mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol+mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeSymbolFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++same :: Type -> Type -> Maybe ()+same ty1 ty2 = guard (ty1 `tcEqType` ty2)++known :: Type -> (Integer -> Bool) -> Maybe Integer+known x p = do { nx <- isNumLitTy x; guard (p nx); return nx }++charToInteger :: Char -> Integer+charToInteger c = fromIntegral (Char.ord c)++integerToChar :: Integer -> Maybe Char+integerToChar n | inBounds = Just (Char.chr (fromInteger n))+  where inBounds = n >= charToInteger minBound &&+                   n <= charToInteger maxBound+integerToChar _ = Nothing+++{- -----------------------------------------------------------------------------+These inverse functions are used for simplifying propositions using+concrete natural numbers.+----------------------------------------------------------------------------- -}++-- | Subtract two natural numbers.+minus :: Integer -> Integer -> Maybe Integer+minus x y = if x >= y then Just (x - y) else Nothing++-- | Compute the exact logarithm of a natural number.+-- The logarithm base is the second argument.+logExact :: Integer -> Integer -> Maybe Integer+logExact x y = do (z,True) <- genLog x y+                  return z+++-- | Divide two natural numbers.+divide :: Integer -> Integer -> Maybe Integer+divide _ 0  = Nothing+divide x y  = case divMod x y of+                (a,0) -> Just a+                _     -> Nothing++-- | Compute the exact root of a natural number.+-- The second argument specifies which root we are computing.+rootExact :: Integer -> Integer -> Maybe Integer+rootExact x y = do (z,True) <- genRoot x y+                   return z++++{- | Compute the n-th root of a natural number, rounded down to+the closest natural number.  The boolean indicates if the result+is exact (i.e., True means no rounding was done, False means rounded down).+The second argument specifies which root we are computing. -}+genRoot :: Integer -> Integer -> Maybe (Integer, Bool)+genRoot _  0    = Nothing+genRoot x0 1    = Just (x0, True)+genRoot x0 root = Just (search 0 (x0+1))+  where+  search from to = let x = from + div (to - from) 2+                       a = x ^ root+                   in case compare a x0 of+                        EQ              -> (x, True)+                        LT | x /= from  -> search x to+                           | otherwise  -> (from, False)+                        GT | x /= to    -> search from x+                           | otherwise  -> (from, False)++{- | Compute the logarithm of a number in the given base, rounded down to the+closest integer.  The boolean indicates if we the result is exact+(i.e., True means no rounding happened, False means we rounded down).+The logarithm base is the second argument. -}+genLog :: Integer -> Integer -> Maybe (Integer, Bool)+genLog x 0    = if x == 1 then Just (0, True) else Nothing+genLog _ 1    = Nothing+genLog 0 _    = Nothing+genLog x base = Just (exactLoop 0 x)+  where+  exactLoop s i+    | i == 1     = (s,True)+    | i < base   = (s,False)+    | otherwise  =+        let s1 = s + 1+        in s1 `seq` case divMod i base of+                      (j,r)+                        | r == 0    -> exactLoop s1 j+                        | otherwise -> (underLoop s1 j, False)++  underLoop s i+    | i < base  = s+    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)+
compiler/GHC/Builtin/Types/Prim.hs view
@@ -63,7 +63,8 @@         doublePrimTyCon,        doublePrimTy, doublePrimTyConName,          statePrimTyCon,         mkStatePrimTy,-        realWorldTyCon,         realWorldTy, realWorldStatePrimTy,+        realWorldTyCon,         realWorldTy,+        realWorldStatePrimTy,   realWorldMutableByteArrayPrimTy,          proxyPrimTyCon,         mkProxyPrimTy, @@ -76,7 +77,6 @@         mutVarPrimTyCon, mkMutVarPrimTy,          mVarPrimTyCon,                  mkMVarPrimTy,-        ioPortPrimTyCon,                mkIOPortPrimTy,         tVarPrimTyCon,                  mkTVarPrimTy,         stablePtrPrimTyCon,             mkStablePtrPrimTy,         stableNamePrimTyCon,            mkStableNamePrimTy,@@ -277,7 +277,6 @@     , mutableByteArrayPrimTyCon     , smallMutableArrayPrimTyCon     , mVarPrimTyCon-    , ioPortPrimTyCon     , tVarPrimTyCon     , mutVarPrimTyCon     , realWorldTyCon@@ -309,7 +308,7 @@   arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName,   mutableArrayPrimTyConName, mutableByteArrayPrimTyConName,   smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName,-  ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName,+  tVarPrimTyConName, stablePtrPrimTyConName,   stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,   weakPrimTyConName, threadIdPrimTyConName,   eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,@@ -341,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@@ -420,8 +418,8 @@                              -- Result is anon arg kinds [ak1, .., akm]     -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for---   forall (r:RuntimeRep) (a:TYPE r) (b:*). blah--- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *])+--   forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah+-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, Type]) mkTemplateKiTyVars kind_var_kinds mk_arg_kinds   = kv_bndrs ++ tv_bndrs   where@@ -435,8 +433,8 @@                              -- Result is anon arg kinds [ak1, .., akm]     -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for---   forall (r:RuntimeRep) (a:TYPE r) (b:*). blah--- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *])+--   forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah+-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, Type]) mkTemplateKiTyVar kind mk_arg_kinds   = kv_bndr : tv_bndrs   where@@ -758,8 +756,10 @@      are not /apart/: see Note [Type and Constraint are not apart]  (W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and-     aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint.  Ditto noInlineId-     vs noInlieConstraintId in GHC.Types.Id.Make; see Note [inlineId magic].+     aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.+     See Note [Type vs Constraint for error ids] in GHC.Core.Make.+     Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make;+     see Note [inlineId magic].  (W3) We need a TypeOrConstraint flag in LitRubbish. @@ -807,7 +807,7 @@  Wrinkles -(W1) In GHC.Core.RoughMap.roughMtchTyConName we are careful to map+(W1) In GHC.Core.RoughMap.roughMatchTyConName we are careful to map      TYPE and CONSTRAINT to the same rough-map key.  Reason:      If we insert (F @Constraint tys) into a FamInstEnv, and look      up (F @Type tys'), we /must/ ensure that the (C @Constraint tys)@@ -824,7 +824,7 @@      are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty.  (W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart?  In truth yes,-     they are.  But it's easier to say that htey are not apart, by+     they are.  But it's easier to say that they are not apart, by      reporting "maybeApart" (which is always safe), rather than      recurse into the arguments (whose kinds may be utterly different)      to look for apartness inside them.  Again this is in@@ -844,8 +844,8 @@ Note [RuntimeRep polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking, you can't be polymorphic in `RuntimeRep`.  E.g-   f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a]-   f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ...+   f :: forall (rr::RuntimeRep) (a::TYPE rr). a -> [a]+   f = /\(rr::RuntimeRep) (a::rr) \(a::rr). ... This is no good: we could not generate code for 'f', because the calling convention for 'f' varies depending on whether the argument is a a Int, Int#, or Float#.  (You could imagine generating specialised@@ -854,7 +854,7 @@ Certain functions CAN be runtime-rep-polymorphic, because the code generator never has to manipulate a value of type 'a :: TYPE rr'. -* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a+* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a   Code generator never has to manipulate the return value.  * unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair:@@ -1014,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.@@ -1042,8 +1042,8 @@  * It is "naturally coherent". This means that the solver won't hesitate to    solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the    context. (Normally, it waits to learn more, just in case the given-   influences what happens next.) See Note [Naturally coherent classes]-   in GHC.Tc.Solver.Interact.+   influences what happens next.) See Note [Solving equality classes]+   in GHC.Tc.Solver.Dict   * It always terminates. That is, in the UndecidableInstances checks, we    don't worry if a (~~) constraint is too big, as we know that solving@@ -1052,7 +1052,7 @@ On the other hand, this behaves just like any class w.r.t. eager superclass unpacking in the solver. So a lifted equality given quickly becomes an unlifted equality given. This is good, because the solver knows all about unlifted-equalities. There is some special-casing in GHC.Tc.Solver.Interact.matchClassInst to+equalities. There is some special-casing in GHC.Tc.Solver.Dict.matchClassInst to pretend that there is an instance of this class, as we can't write the instance in Haskell. @@ -1176,7 +1176,9 @@ realWorldTy          = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy        -- State# RealWorld-+realWorldMutableByteArrayPrimTy :: Type+realWorldMutableByteArrayPrimTy+  = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld  mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]@@ -1274,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
@@ -14,15 +14,19 @@       -- * Getting the 'Unique's of 'Name's       -- ** Anonymous sums     , mkSumTyConUnique, mkSumDataConUnique+    , isSumTyConUnique        -- ** Tuples       -- *** Vanilla     , mkTupleTyConUnique     , mkTupleDataConUnique+    , isTupleTyConUnique+    , isTupleDataConLikeUnique       -- *** Constraint     , mkCTupleTyConUnique     , mkCTupleDataConUnique     , mkCTupleSelIdUnique+    , isCTupleTyConUnique        -- ** Making built-in uniques     , mkAlphaTyVarUnique@@ -30,10 +34,12 @@     , mkPreludeMiscIdUnique, mkPreludeDataConUnique     , mkPreludeTyConUnique, mkPreludeClassUnique -    , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique     , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique     , mkCostCentreUnique +    , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique+    , mkFldNSUnique, isFldNSUnique+     , mkBuiltinUnique     , mkPseudoUniqueE @@ -63,7 +69,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain (assert)  import Data.Maybe import GHC.Utils.Word64 (word64ToInt)@@ -118,6 +123,15 @@               -- alternative     mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc) +-- | Inverse of 'mkSumTyConUnique'+isSumTyConUnique :: Unique -> Maybe Arity+isSumTyConUnique u =+  case (tag, n .&. 0xfc) of+    ('z', 0xfc) -> Just (word64ToInt n `shiftR` 8)+    _ -> Nothing+  where+    (tag, n) = unpkUnique u+ mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkSumDataConUnique alt arity   | alt >= arity@@ -222,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@@ -270,6 +295,30 @@ mkTupleTyConUnique Boxed           a  = mkUniqueInt '4' (2*a) mkTupleTyConUnique Unboxed         a  = mkUniqueInt '5' (2*a) +-- | Inverse of 'mkTupleTyConUnique'+isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity)+isTupleTyConUnique u =+  case (tag, i) of+    ('4', 0) -> Just (Boxed,   arity)+    ('5', 0) -> Just (Unboxed, arity)+    _        -> Nothing+  where+    (tag,   n) = unpkUnique u+    (arity', i) = quotRem n 2+    arity = word64ToInt arity'++-- | Inverse of 'mkTupleTyDataUnique' that also matches the worker and promoted tycon.+isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity)+isTupleDataConLikeUnique u =+  case tag of+    '7' -> Just (Boxed,   arity)+    '8' -> Just (Unboxed, arity)+    _ -> Nothing+  where+    (tag,   n) = unpkUnique u+    (arity', _) = quotRem n 3+    arity = word64ToInt arity'+ getTupleTyConName :: Boxity -> Int -> Name getTupleTyConName boxity n =     case n `divMod` 2 of@@ -370,13 +419,18 @@ mkCostCentreUnique :: Int -> Unique mkCostCentreUnique = mkUniqueInt 'C' +varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique+varNSUnique    = mkUnique 'i' 0+dataNSUnique   = mkUnique 'd' 0+tvNSUnique     = mkUnique 'v' 0+tcNSUnique     = mkUnique 'c' 0 -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique--- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence-mkVarOccUnique  fs = mkUniqueInt 'i' (uniqueOfFS fs)-mkDataOccUnique fs = mkUniqueInt 'd' (uniqueOfFS fs)-mkTvOccUnique   fs = mkUniqueInt 'v' (uniqueOfFS fs)-mkTcOccUnique   fs = mkUniqueInt 'c' (uniqueOfFS fs)+mkFldNSUnique :: FastString -> Unique+mkFldNSUnique fs = mkUniqueInt 'f' (uniqueOfFS fs)++isFldNSUnique :: Unique -> Bool+isFldNSUnique uniq = case unpkUnique uniq of+  (tag, _) -> tag == 'f'  initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0
compiler/GHC/Builtin/Uniques.hs-boot view
@@ -4,7 +4,6 @@ import GHC.Types.Unique import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic-import GHC.Data.FastString  -- Needed by GHC.Builtin.Types knownUniqueName :: Unique -> Maybe Name@@ -27,7 +26,6 @@ mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique  mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique-mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique  initExitJoinUnique :: Unique
+ 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,6 +1,9 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE UnliftedNewtypes           #-} -- --  (c) The University of Glasgow 2002-2006 --@@ -8,71 +11,91 @@ -- | Bytecode assembler types module GHC.ByteCode.Types   ( CompiledByteCode(..), seqCompiledByteCode+  , BCOByteArray(..), mkBCOByteArray   , FFIInfo(..)   , RegBitmap(..)   , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo-  , ByteOff(..), WordOff(..)+  , ByteOff(..), WordOff(..), HalfWord(..)   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)   , AddrEnv, AddrPtr(..)-  , CgBreakInfo(..)-  , ModBreaks (..), BreakIndex, emptyModBreaks-  , CCostCentre+  , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag++  -- * Mod Breaks+  , ModBreaks (..), BreakpointId(..), BreakTickIndex++  -- * Internal Mod Breaks+  , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks+  -- ** Internal breakpoint identifier+  , InternalBreakpointId(..), BreakInfoIndex   ) where  import GHC.Prelude  import GHC.Data.FastString-import GHC.Data.SizedSeq+import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps-import GHC.Types.SrcLoc-import GHCi.BreakArray+import GHC.Types.SptEntry+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.Array.Base  ( UArray(..) ) 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  data CompiledByteCode = CompiledByteCode-  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings-  , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls-  , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated-  , bc_strs   :: AddrEnv        -- malloc'd top-level strings-  , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not-                                 -- creating breakpoints, for some reason)+  { bc_bcos   :: FlatBag UnlinkedBCO+    -- ^ Bunch of interpretable bindings++  , bc_itbls  :: [(Name, ConInfoTable)]+    -- ^ Mapping from DataCons to their info tables++  , bc_strs   :: [(Name, ByteString)]+    -- ^ top-level strings (heap allocated)++  , 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 bc_bcos+  ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos  -- Not a real NFData instance, because ModBreaks contains some things -- we can't rnf 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)@@ -80,6 +103,12 @@ newtype WordOff = WordOff Int     deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) +-- A type for values that are half the size of a word on the target+-- platform where the interpreter runs (which may be a different+-- wordsize than the compiler).+newtype HalfWord = HalfWord Word+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)+ newtype RegBitmap = RegBitmap { unRegBitmap :: Word32 }     deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Bits, FiniteBits, Outputable) @@ -142,14 +171,88 @@ 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,         unlinkedBCOArity  :: {-# UNPACK #-} !Int,-        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns-        unlinkedBCOBitmap :: !(UArray Int Word64),      -- bitmap-        unlinkedBCOLits   :: !(SizedSeq BCONPtr),       -- non-ptrs-        unlinkedBCOPtrs   :: !(SizedSeq BCOPtr)         -- ptrs+        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns+        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap+        unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs+        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs    }  instance NFData UnlinkedBCO where@@ -161,7 +264,8 @@   = BCOPtrName   !Name   | BCOPtrPrimOp !PrimOp   | BCOPtrBCO    !UnlinkedBCO-  | BCOPtrBreakArray  -- a pointer to this module's BreakArray+  | BCOPtrBreakArray !Module+    -- ^ Converted to the actual 'BreakArray' remote pointer at link-time  instance NFData BCOPtr where   rnf (BCOPtrBCO bco) = rnf bco@@ -174,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, Word16)]-   , 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 (sizeSS lits), text "lits",-             ppr (sizeSS 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-   }+             ppr (sizeFlatBag lits), text "lits",+             ppr (sizeFlatBag ptrs), text "ptrs" ] -{--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.hs view
@@ -12,22 +12,28 @@  module GHC.Cmm (      -- * Cmm top-level datatypes+     DCmmGroup,      CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,-     CmmDecl, CmmDeclSRTs, GenCmmDecl(..),-     CmmDataDecl, cmmDataDeclCmmDecl,-     CmmGraph, GenCmmGraph(..),+     CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..),+     CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph,+     CmmGraph, GenCmmGraph, GenGenCmmGraph(..),      toBlockMap, revPostorder, toBlockList,      CmmBlock, RawCmmDecl,      Section(..), SectionType(..),      GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),      SectionProtection(..), sectionProtection, +     DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph,+      -- ** Blocks containing lists      GenBasicBlock(..), blockId,      ListGraph(..), pprBBlock,       -- * Info Tables-     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,+     GenCmmTopInfo(..)+     , DCmmTopInfo+     , CmmTopInfo+     , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD,      ClosureTypeInfo(..),      ProfilingInfo(..), ConstrDescription, @@ -50,7 +56,6 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm.Expr import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable@@ -75,6 +80,8 @@ type CmmProgram = [CmmGroup]  type GenCmmGroup d h g = [GenCmmDecl d h g]+-- | Cmm group after STG generation+type DCmmGroup    = GenCmmGroup CmmStatics    DCmmTopInfo              DCmmGraph -- | Cmm group before SRT generation type CmmGroup     = GenCmmGroup CmmStatics    CmmTopInfo               CmmGraph -- | Cmm group with SRTs@@ -101,7 +108,7 @@   = CmmProc     -- A procedure      h                 -- Extra header such as the info table      CLabel            -- Entry label-     [GlobalReg]       -- Registers live on entry. Note that the set of live+     [GlobalRegUse]    -- Registers live on entry. Note that the set of live                        -- registers will be correct in generated C-- code, but                        -- not in hand-written C-- code. However,                        -- splitAtProcPoints calculates correct liveness@@ -118,6 +125,7 @@       => OutputableP Platform (GenCmmDecl d info i) where     pdoc = pprTop +type DCmmDecl    = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph type CmmDataDecl = GenCmmDataDecl CmmStatics@@ -140,7 +148,11 @@ -----------------------------------------------------------------------------  type CmmGraph = GenCmmGraph CmmNode-data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+type DCmmGraph = GenGenCmmGraph DWrap CmmNode++type GenCmmGraph n = GenGenCmmGraph LabelMap n++data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C } type CmmBlock = Block CmmNode C C  instance OutputableP Platform CmmGraph where@@ -172,9 +184,17 @@  -- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains -- the extra info (beyond the executable code) that belongs to that CmmDecl.-data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable-                            , stack_info :: CmmStackInfo }+data GenCmmTopInfo f = TopInfo { info_tbls  :: f CmmInfoTable+                               , stack_info :: CmmStackInfo } +newtype DWrap a = DWrap [(BlockId, a)]++unDeterm :: DWrap a -> [(BlockId, a)]+unDeterm (DWrap f) = f++type DCmmTopInfo = GenCmmTopInfo DWrap+type CmmTopInfo  = GenCmmTopInfo LabelMap+ instance OutputableP Platform CmmTopInfo where     pdoc = pprTopInfo @@ -183,7 +203,12 @@   vcat [text "info_tbls: " <> pdoc platform info_tbl,         text "stack_info: " <> ppr stack_info] -topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable+topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable+topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of+                                          DWrap xs -> lookup (g_entry g) xs+topInfoTableD _                     = Nothing++topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable _                     = Nothing @@ -238,6 +263,7 @@   = NoProfilingInfo   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc   deriving (Eq, Ord)+ ----------------------------------------------------------------------------- --              Static Data -----------------------------------------------------------------------------@@ -305,7 +331,7 @@   ppr (CmmString _) = text "CmmString"   ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp --- Static data before SRT generation+-- | Static data before or after SRT generation data GenCmmStatics (rawOnly :: Bool) where     CmmStatics       :: CLabel       -- Label of statics@@ -328,6 +354,61 @@  type CmmStatics    = GenCmmStatics 'False type RawCmmStatics = GenCmmStatics 'True++{-+-----------------------------------------------------------------------------+--              Deterministic Cmm / Info Tables+-----------------------------------------------------------------------------++Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consulting Note [Object determinism] one will learn that in order to produce+deterministic objects just after cmm is produced we perform a renaming pass which+provides fresh uniques for all unique-able things in the input Cmm.++After this point, we use a deterministic unique supply (an incrementing counter)+so any resulting labels which make their way into object code have a deterministic name.++A key assumption to this process is that the input is deterministic modulo the uniques+and the order that bindings appear in the definitions is the same.++CmmGroup uses LabelMap in two places:++* In CmmProc for info tables+* In CmmGraph for the blocks of the graph++LabelMap is not a deterministic structure, so traversing a LabelMap can process+elements in different order (depending on the given uniques).++Therefore before we do the renaming we need to use a deterministic structure, one+which we can traverse in a guaranteed order. A list does the job perfectly.++Once the renaming happens it is converted back into a LabelMap, which is now deterministic+due to the uniques being generated and assigned in a deterministic manner.++We prefer using the renamed LabelMap rather than the list in the rest of the+code generation because it is much more efficient than lists for the needs of+the code generator.+-}++-- Converting out of deterministic Cmm++removeDeterm :: DCmmGroup -> CmmGroup+removeDeterm = map removeDetermDecl++removeDetermDecl :: DCmmDecl -> CmmDecl+removeDetermDecl (CmmProc h e r g) = CmmProc (removeDetermTop h) e r (removeDetermGraph g)+removeDetermDecl (CmmData a b) = CmmData a b++removeDetermTop :: DCmmTopInfo -> CmmTopInfo+removeDetermTop (TopInfo a b) = TopInfo (mapFromList $ unDeterm a) b++removeDetermGraph :: DCmmGraph -> CmmGraph+removeDetermGraph (CmmGraph x y) =+  let y' = case y of+            GMany a (DWrap b) c -> GMany a (mapFromList b) c+  in CmmGraph x y'  -- ----------------------------------------------------------------------------- -- Basic blocks consisting of lists
compiler/GHC/Cmm/BlockId.hs view
@@ -15,7 +15,7 @@ import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Unique-import GHC.Types.Unique.Supply+import qualified GHC.Types.Unique.DSM as DSM  import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) @@ -36,8 +36,12 @@ mkBlockId :: Unique -> BlockId mkBlockId unique = mkHooplLabel $ getKey unique -newBlockId :: MonadUnique m => m BlockId-newBlockId = mkBlockId <$> getUniqueM+-- If the monad unique instance uses a deterministic unique supply, this will+-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm+-- onwards (after deterministic renaming in 'codeGen'), there should only exist+-- deterministic block labels.+newBlockId :: DSM.MonadGetUnique m => m BlockId+newBlockId = mkBlockId <$> DSM.getUniqueM  blockLbl :: BlockId -> CLabel blockLbl label = mkLocalBlockLabel (getUnique label)
compiler/GHC/Cmm/CLabel.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ ----------------------------------------------------------------------------- -- -- Object-file symbols (called CLabel for historical reasons).@@ -6,11 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-- module GHC.Cmm.CLabel (         CLabel, -- abstract type         NeedExternDecl (..),@@ -53,6 +50,7 @@         mkDirty_MUT_VAR_Label,         mkMUT_VAR_CLEAN_infoLabel,         mkNonmovingWriteBarrierEnabledLabel,+        mkOrigThunkInfoLabel,         mkUpdInfoLabel,         mkBHUpdInfoLabel,         mkIndStaticInfoLabel,@@ -104,7 +102,7 @@         needsCDecl,         maybeLocalBlockLabel,         externallyVisibleCLabel,-        isMathFun,+        isLibcFun,         isCFunctionLabel,         isGcPtrLabel,         labelDynamic,@@ -127,6 +125,7 @@         toSlowEntryLbl,         toEntryLbl,         toInfoLbl,+        toProcDelimiterLbl,          -- * Pretty-printing         LabelStyle (..),@@ -137,8 +136,10 @@          -- * Others         dynamicLinkerLabelInfo,-        addLabelSize,-        foreignLabelStdcallInfo+        CStubLabel (..),+        cStubLabel,+        fromCStubLabel,+        mapInternalNonDetUniques     ) where  import GHC.Prelude@@ -153,7 +154,6 @@ import GHC.Types.CostCentre import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set@@ -240,10 +240,6 @@   | ForeignLabel         FastString              -- ^ name of the imported label. -        (Maybe Int)             -- ^ possible '@n' suffix for stdcall functions-                                -- When generating C, the '@n' suffix is omitted, but when-                                -- generating assembler we must add it to the label.-         ForeignLabelSource      -- ^ what package the foreign label is in.          FunctionOrData@@ -346,29 +342,40 @@    deriving (Ord,Eq)  -- This is laborious, but necessary. We can't derive Ord because--- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the--- implementation. See Note [No Ord for Unique]--- This is non-deterministic but we do not currently support deterministic--- code-generation. See Note [Unique Determinism and code generation]+-- Unique has a special Ord instance that cares for object determinism.+-- Note nonDetCmpUnique and stableNameCmp in the implementation:+--  * If -fobject-determinism, the internal uniques will be renamed, thus the+--  comparison will actually be deterministic+--  * Stable name compare guarantees deterministic ordering of Names despite+--  the non-deterministic uniques underlying external names (which aren't+--  renamed on -fobject-determinism).+-- See Note [Unique Determinism and code generation] and Note [Object determinism] instance Ord CLabel where+  compare (IdLabel a1 b1 c1)+          (IdLabel a2 b2 c2)+          | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2+          | isExternalName a1 = GT+          | isExternalName a2 = LT+   compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =+    -- Comparing names here should deterministic because all unique should have+    -- been renamed deterministically, and external names compared above.     compare a1 a2 S.<>     compare b1 b2 S.<>     compare c1 c2   compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =     compare a1 a2 S.<>     compare b1 b2 S.<>-    -- This non-determinism is "safe" in the sense that it only affects object code,-    -- which is currently not covered by GHC's determinism guarantees. See #12935.+    -- This is not non-deterministic because the uniques have been deterministically renamed.+    -- See Note [Object determinism]     uniqCompareFS c1 c2 S.<>     compare d1 d2   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2   compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2-  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =+  compare (ForeignLabel a1 b1 c1) (ForeignLabel a2 b2 c2) =     uniqCompareFS a1 a2 S.<>     compare b1 b2 S.<>-    compare c1 c2 S.<>-    compare d1 d2+    compare c1 c2   compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2   compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =     compare a1 a2 S.<>@@ -470,8 +477,8 @@          RtsLabel{}             -> text "RtsLabel" -         ForeignLabel _name mSuffix src funOrData-             -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData+         ForeignLabel _name src funOrData+             -> text "ForeignLabel" <+> ppr src <+> ppr funOrData           _  -> text "other CLabel" @@ -641,7 +648,7 @@ -- Constructing Cmm Labels mkDirty_MUT_VAR_Label,     mkNonmovingWriteBarrierEnabledLabel,-    mkUpdInfoLabel,+    mkOrigThunkInfoLabel, mkUpdInfoLabel,     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,     mkMAP_DIRTY_infoLabel,@@ -652,9 +659,10 @@     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,     mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,     mkMUT_VAR_CLEAN_infoLabel :: CLabel-mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData+mkOrigThunkInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel                  = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame")         CmmInfo mkBHUpdInfoLabel                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" )     CmmInfo mkIndStaticInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC")        CmmInfo@@ -669,8 +677,8 @@ mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry-mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")  Nothing ForeignLabelInExternalPackage IsFunction-mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") ForeignLabelInExternalPackage IsFunction+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo  mkSRTInfoLabel :: Int -> CLabel@@ -754,21 +762,12 @@ -- | Make a foreign label mkForeignLabel         :: FastString           -- name-        -> Maybe Int            -- size prefix         -> ForeignLabelSource   -- what package it's in         -> FunctionOrData         -> CLabel  mkForeignLabel = ForeignLabel ---- | Update the label size field in a ForeignLabel-addLabelSize :: CLabel -> Int -> CLabel-addLabelSize (ForeignLabel str _ src  fod) sz-    = ForeignLabel str (Just sz) src fod-addLabelSize label _-    = label- -- | Whether label is a top-level string literal isBytesLabel :: CLabel -> Bool isBytesLabel (IdLabel _ _ Bytes) = True@@ -776,7 +775,7 @@  -- | Whether label is a non-haskell label (defined in C code) isForeignLabel :: CLabel -> Bool-isForeignLabel (ForeignLabel _ _ _ _) = True+isForeignLabel (ForeignLabel _ _ _) = True isForeignLabel _lbl = False  -- | Whether label is a static closure label (can come from haskell or cmm)@@ -797,6 +796,7 @@ isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True -- info table defined in cmm (.cmm) isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True+isSomeRODataLabel (CmmLabel _ _ _ CmmRetInfo) = True isSomeRODataLabel _lbl = False  -- | Whether label is points to some kind of info table@@ -818,12 +818,6 @@ isConInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True isConInfoTableLabel _                            = False --- | Get the label size field from a ForeignLabel-foreignLabelStdcallInfo :: CLabel -> Maybe Int-foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info-foreignLabelStdcallInfo _lbl = Nothing-- -- Constructing Large*Labels mkBitmapLabel   :: Unique -> CLabel mkBitmapLabel   uniq            = LargeBitmapLabel uniq@@ -839,7 +833,7 @@                                -- The rendered Haskell type of the closure the table represents                                , infoProvModule :: !Module                                -- Origin module-                               , infoTableProv :: !(Maybe (RealSrcSpan, String)) }+                               , infoTableProv :: !(Maybe (RealSrcSpan, LexicalFastString)) }                                -- Position and information about the info table                                deriving (Eq, Ord) @@ -948,6 +942,16 @@    CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet    _                             -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl) +-- | Generate a CmmProc delimiter label from the actual entry label.+--+-- This delimiter label might be the entry label itself, except when the entry+-- label is a LocalBlockLabel. If we reused the entry label to delimit the proc,+-- we would generate redundant labels (see #22792)+toProcDelimiterLbl :: CLabel -> CLabel+toProcDelimiterLbl lbl = case lbl of+  LocalBlockLabel {} -> mkAsmTempDerivedLabel lbl (fsLit "_entry")+  _                  -> lbl+ toInfoLbl :: Platform -> CLabel -> CLabel toInfoLbl platform lbl = case lbl of    IdLabel n c LocalEntry      -> IdLabel n c LocalInfoTable@@ -1024,7 +1028,7 @@         -- For other labels we inline one into the HC file directly.         | otherwise                     = True -needsCDecl l@(ForeignLabel{})           = not (isMathFun l)+needsCDecl l@(ForeignLabel{})           = not (isLibcFun l) needsCDecl (CC_Label _)                 = True needsCDecl (CCS_Label _)                = True needsCDecl (IPE_Label {})               = True@@ -1051,15 +1055,19 @@   -- | Check whether a label corresponds to a C function that has---      a prototype in a system header somewhere, or is built-in---      to the C compiler. For these labels we avoid generating our---      own C prototypes.-isMathFun :: CLabel -> Bool-isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs-isMathFun _ = False+-- a prototype in a system header somewhere, or is built-in+-- to the C compiler. For these labels we avoid generating our+-- own C prototypes.+isLibcFun :: CLabel -> Bool+isLibcFun (ForeignLabel fs _ _)  = fs `elementOfUniqSet` libc_funs+isLibcFun _ = False -math_funs :: UniqSet FastString-math_funs = mkUniqSet [+libc_funs :: UniqSet FastString+libc_funs = mkUniqSet [+        ---------------------+        -- Math functions+        ---------------------+         -- _ISOC99_SOURCE         (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),         (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),@@ -1220,8 +1228,8 @@ labelType (RtsLabel (RtsSlowFastTickyCtr _))    = DataLabel labelType (LocalBlockLabel _)                   = CodeLabel labelType (SRTLabel _)                          = DataLabel-labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel-labelType (ForeignLabel _ _ _ IsData)           = DataLabel+labelType (ForeignLabel _ _ IsFunction)         = CodeLabel+labelType (ForeignLabel _ _ IsData)             = DataLabel labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)" labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)" labelType (StringLitLabel _)                    = DataLabel@@ -1300,7 +1308,7 @@     LocalBlockLabel _    -> False -   ForeignLabel _ _ source _  ->+   ForeignLabel _ source _  ->        if os == OSMinGW32        then case source of             -- Foreign label is in some un-named foreign package (or DLL).@@ -1427,11 +1435,11 @@  -- | Style of label pretty-printing. ----- When we produce C sources or headers, we have to take into account that C--- compilers transform C labels when they convert them into symbols. For--- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for--- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style--- or Asm style.+-- When we produce C sources or headers, we have to take into account+-- that C compilers transform C labels when they convert them into+-- symbols. For example, they can add prefixes (e.g., "_" on Darwin).+-- So we provide two ways to pretty-print CLabels: C style or Asm+-- style. -- data LabelStyle    = CStyle   -- ^ C label style (used by C and LLVM backends)@@ -1482,10 +1490,17 @@       -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u     AsmTempDerivedLabel l suf-      -> asmTempLabelPrefix platform-         <> case l of AsmTempLabel u    -> pprUniqueAlways u-                      LocalBlockLabel u -> pprUniqueAlways u-                      _other            -> pprCLabelStyle platform sty l+         -- we print a derived label, so we just print the parent label+         -- recursively. However we don't want to print the temp prefix (e.g.+         -- ".L") twice, so we must explicitely handle these cases.+      -> let skipTempPrefix = \case+                AsmTempLabel u            -> pprUniqueAlways u+                AsmTempDerivedLabel l suf -> skipTempPrefix l <> ftext suf+                LocalBlockLabel u         -> pprUniqueAlways u+                lbl                       -> pprAsmLabel platform lbl+         in+         asmTempLabelPrefix platform+         <> skipTempPrefix l          <> ftext suf     DynamicLinkerLabel info lbl@@ -1507,17 +1522,9 @@    StringLitLabel u       -> maybe_underscore $ pprUniqueAlways u <> text "_str" -   ForeignLabel fs (Just sz) _ _-      | AsmStyle <- sty-      , OSMinGW32 <- platformOS platform-      -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.-         -- (The C compiler does this itself).-         maybe_underscore $ ftext fs <> char '@' <> int sz--   ForeignLabel fs _ _ _+   ForeignLabel fs _ _       -> maybe_underscore $ ftext fs -    IdLabel name _cafs flavor -> case sty of       AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor                    where@@ -1692,11 +1699,7 @@             GotSymbolPtr    -> ppLbl <> text "@GOTPCREL"             GotSymbolOffset -> ppLbl         | platformArch platform == ArchAArch64 -> ppLbl-        | otherwise ->-          case dllInfo of-            CodeStub  -> char 'L' <> ppLbl <> text "$stub"-            SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"-            _         -> panic "pprDynamicLinkerAsmLabel"+        | otherwise -> panic "pprDynamicLinkerAsmLabel"        OSAIX ->           case dllInfo of@@ -1723,7 +1726,12 @@       | platformArch platform == ArchAArch64       = ppLbl +      | platformArch platform == ArchRISCV64+      = ppLbl +      | platformArch platform == ArchLoongArch64+      = ppLbl+       | platformArch platform == ArchX86_64       = case dllInfo of           CodeStub        -> ppLbl <> text "@plt"@@ -1881,3 +1889,74 @@      T15155.a_closure `mayRedirectTo` a1_rXq_closure+1 returns True. -}++-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign+-- declarations for the purpose of serializing to interface files.+--+-- See Note [Foreign stubs and TH bytecode linking]+data CStubLabel =+  CStubLabel {+    csl_is_initializer :: Bool,+    csl_module :: Module,+    csl_name :: FastString+  }++instance Outputable CStubLabel where+  ppr CStubLabel {csl_is_initializer, csl_module, csl_name} =+    text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name)+    where+      ini = if csl_is_initializer then "initializer" else "finalizer"++-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an+-- initializer or finalizer.+cStubLabel :: CLabel -> Maybe CStubLabel+cStubLabel = \case+  ModuleLabel csl_module label_kind -> do+    (csl_is_initializer, csl_name) <- case label_kind of+      MLK_Initializer (LexicalFastString s) -> Just (True, s)+      MLK_Finalizer (LexicalFastString s) -> Just (False, s)+      _ -> Nothing+    Just (CStubLabel {csl_is_initializer, csl_module, csl_name})+  _ -> Nothing++-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'.+fromCStubLabel :: CStubLabel -> CLabel+fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) =+  ModuleLabel csl_module (label_kind (LexicalFastString csl_name))+  where+    label_kind =+      if csl_is_initializer+      then MLK_Initializer+      else MLK_Finalizer++-- | A utility for renaming uniques in CLabels to produce deterministic object.+-- Note that not all Uniques are mapped over. Only those that can be safely alpha+-- renamed, e.g. uniques of local symbols, but not of external ones.+-- See Note [Renaming uniques deterministically].+mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel+-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel?+mapInternalNonDetUniques f x = case x of+  IdLabel name cafInfo idLabelInfo+    | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo+    | otherwise -> pure x+  cl@CmmLabel{} -> pure cl+  RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo+  LocalBlockLabel unique -> LocalBlockLabel <$> f unique+  fl@ForeignLabel{} -> pure fl+  AsmTempLabel unique -> AsmTempLabel <$> f unique+  AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs+  StringLitLabel unique -> StringLitLabel <$> f unique+  CC_Label  cc -> pure $ CC_Label cc+  CCS_Label ccs -> pure $ CCS_Label ccs+  IPE_Label ipe@InfoProvEnt{infoTablePtr} ->+    (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr+  ml@ModuleLabel{} -> pure ml+  DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl+  PicBaseLabel -> pure PicBaseLabel+  DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl+  HpcTicksLabel mod -> pure $ HpcTicksLabel mod+  SRTLabel unique -> SRTLabel <$> f unique+  LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique+-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma:+{-# INLINABLE mapInternalNonDetUniques #-}+
− compiler/GHC/Cmm/Dataflow/Collections.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Cmm.Dataflow.Collections-    ( IsSet(..)-    , setInsertList, setDeleteList, setUnions-    , IsMap(..)-    , mapInsertList, mapDeleteList, mapUnions-    , UniqueMap, UniqueSet-    ) where--import GHC.Prelude--import qualified GHC.Data.Word64Map.Strict as M-import qualified GHC.Data.Word64Set as S--import Data.List (foldl1')-import Data.Word (Word64)--class IsSet set where-  type ElemOf set--  setNull :: set -> Bool-  setSize :: set -> Int-  setMember :: ElemOf set -> set -> Bool--  setEmpty :: set-  setSingleton :: ElemOf set -> set-  setInsert :: ElemOf set -> set -> set-  setDelete :: ElemOf set -> set -> set--  setUnion :: set -> set -> set-  setDifference :: set -> set -> set-  setIntersection :: set -> set -> set-  setIsSubsetOf :: set -> set -> Bool-  setFilter :: (ElemOf set -> Bool) -> set -> set--  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b-  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b--  setElems :: set -> [ElemOf set]-  setFromList :: [ElemOf set] -> set---- Helper functions for IsSet class-setInsertList :: IsSet set => [ElemOf set] -> set -> set-setInsertList keys set = foldl' (flip setInsert) set keys--setDeleteList :: IsSet set => [ElemOf set] -> set -> set-setDeleteList keys set = foldl' (flip setDelete) set keys--setUnions :: IsSet set => [set] -> set-setUnions [] = setEmpty-setUnions sets = foldl1' setUnion sets---class IsMap map where-  type KeyOf map--  mapNull :: map a -> Bool-  mapSize :: map a -> Int-  mapMember :: KeyOf map -> map a -> Bool-  mapLookup :: KeyOf map -> map a -> Maybe a-  mapFindWithDefault :: a -> KeyOf map -> map a -> a--  mapEmpty :: map a-  mapSingleton :: KeyOf map -> a -> map a-  mapInsert :: KeyOf map -> a -> map a -> map a-  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a-  mapDelete :: KeyOf map -> map a -> map a-  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a-  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a--  mapUnion :: map a -> map a -> map a-  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a-  mapDifference :: map a -> map a -> map a-  mapIntersection :: map a -> map a -> map a-  mapIsSubmapOf :: Eq a => map a -> map a -> Bool--  mapMap :: (a -> b) -> map a -> map b-  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b-  mapFoldl :: (b -> a -> b) -> b -> map a -> b-  mapFoldr :: (a -> b -> b) -> b -> map a -> b-  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b-  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m-  mapFilter :: (a -> Bool) -> map a -> map a-  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a---  mapElems :: map a -> [a]-  mapKeys :: map a -> [KeyOf map]-  mapToList :: map a -> [(KeyOf map, a)]-  mapFromList :: [(KeyOf map, a)] -> map a-  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a---- Helper functions for IsMap class-mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a-mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs--mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a-mapDeleteList keys map = foldl' (flip mapDelete) map keys--mapUnions :: IsMap map => [map a] -> map a-mapUnions [] = mapEmpty-mapUnions maps = foldl1' mapUnion maps---------------------------------------------------------------------------------- Basic instances--------------------------------------------------------------------------------newtype UniqueSet = US S.Word64Set deriving (Eq, Ord, Show, Semigroup, Monoid)--instance IsSet UniqueSet where-  type ElemOf UniqueSet = Word64--  setNull (US s) = S.null s-  setSize (US s) = S.size s-  setMember k (US s) = S.member k s--  setEmpty = US S.empty-  setSingleton k = US (S.singleton k)-  setInsert k (US s) = US (S.insert k s)-  setDelete k (US s) = US (S.delete k s)--  setUnion (US x) (US y) = US (S.union x y)-  setDifference (US x) (US y) = US (S.difference x y)-  setIntersection (US x) (US y) = US (S.intersection x y)-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y-  setFilter f (US s) = US (S.filter f s)--  setFoldl k z (US s) = S.foldl' k z s-  setFoldr k z (US s) = S.foldr k z s--  setElems (US s) = S.elems s-  setFromList ks = US (S.fromList ks)--newtype UniqueMap v = UM (M.Word64Map v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)--instance IsMap UniqueMap where-  type KeyOf UniqueMap = Word64--  mapNull (UM m) = M.null m-  mapSize (UM m) = M.size m-  mapMember k (UM m) = M.member k m-  mapLookup k (UM m) = M.lookup k m-  mapFindWithDefault def k (UM m) = M.findWithDefault def k m--  mapEmpty = UM M.empty-  mapSingleton k v = UM (M.singleton k v)-  mapInsert k v (UM m) = UM (M.insert k v m)-  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)-  mapDelete k (UM m) = UM (M.delete k m)-  mapAlter f k (UM m) = UM (M.alter f k m)-  mapAdjust f k (UM m) = UM (M.adjust f k m)--  mapUnion (UM x) (UM y) = UM (M.union x y)-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)-  mapDifference (UM x) (UM y) = UM (M.difference x y)-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y--  mapMap f (UM m) = UM (M.map f m)-  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)-  mapFoldl k z (UM m) = M.foldl' k z m-  mapFoldr k z (UM m) = M.foldr k z m-  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m-  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m-  {-# INLINEABLE mapFilter #-}-  mapFilter f (UM m) = UM (M.filter f m)-  {-# INLINEABLE mapFilterWithKey #-}-  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)--  mapElems (UM m) = M.elems m-  mapKeys (UM m) = M.keys m-  {-# INLINEABLE mapToList #-}-  mapToList (UM m) = M.toList m-  mapFromList assocs = UM (M.fromList assocs)-  mapFromListWith f assocs = UM (M.fromListWith f assocs)
compiler/GHC/Cmm/Dataflow/Graph.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module GHC.Cmm.Dataflow.Graph     ( Body@@ -26,15 +22,14 @@  import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections  import Data.Kind  -- | A (possibly empty) collection of closed/closed blocks-type Body n = LabelMap (Block n C C)+type Body s n = Body' s Block n  -- | @Body@ abstracted over @block@-type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)+type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C)  ------------------------------- -- | Gives access to the anchor points for@@ -51,13 +46,13 @@   successors (BlockCC _ _ n) = successors n  -emptyBody :: Body' block n+emptyBody :: Body' LabelMap block n emptyBody = mapEmpty -bodyList :: Body' block n -> [(Label,block n C C)]+bodyList :: Body' LabelMap block n -> [(Label,block n C C)] bodyList body = mapToList body -bodyToBlockList :: Body n -> [Block n C C]+bodyToBlockList :: Body LabelMap n -> [Block n C C] bodyToBlockList body = mapElems body  addBlock@@ -77,18 +72,18 @@ -- O/C, C/O, C/C).  A graph open at the entry has a single, -- distinguished, anonymous entry point; if a graph is closed at the -- entry, its entry point(s) are supplied by a context.-type Graph = Graph' Block+type Graph = Graph' LabelMap Block  -- | @Graph'@ is abstracted over the block type, so that we can build -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow -- needs this).-data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where-  GNil  :: Graph' block n O O-  GUnit :: block n O O -> Graph' block n O O+data Graph' s block (n :: Extensibility -> Extensibility -> Type) e x where+  GNil  :: Graph' s block n O O+  GUnit :: block n O O -> Graph' s block n O O   GMany :: MaybeO e (block n O C)-        -> Body' block n+        -> Body' s block n         -> MaybeO x (block n C O)-        -> Graph' block n e x+        -> Graph' s block n e x   -- -----------------------------------------------------------------------------@@ -96,31 +91,32 @@  -- | Maps over all nodes in a graph. mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x-mapGraph f = mapGraphBlocks (mapBlock f)+mapGraph f = mapGraphBlocks mapMap (mapBlock f)  -- | Function 'mapGraphBlocks' enables a change of representation of blocks, -- nodes, or both.  It lifts a polymorphic block transform into a polymorphic -- graph transform.  When the block representation stabilizes, a similar -- function should be provided for blocks.-mapGraphBlocks :: forall block n block' n' e x .-                  (forall e x . block n e x -> block' n' e x)-               -> (Graph' block n e x -> Graph' block' n' e x)+mapGraphBlocks :: forall s block n block' n' e x .+                  (forall a b . (a -> b) -> s a -> s b)+               -> (forall e x . block n e x -> block' n' e x)+               -> (Graph' s block n e x -> Graph' s block' n' e x) -mapGraphBlocks f = map-  where map :: Graph' block n e x -> Graph' block' n' e x+mapGraphBlocks f g = map+  where map :: Graph' s block n e x -> Graph' s block' n' e x         map GNil = GNil-        map (GUnit b) = GUnit (f b)-        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)+        map (GUnit b) = GUnit (g b)+        map (GMany e b x) = GMany (fmap g e) (f g b) (fmap g x)  -- ----------------------------------------------------------------------------- -- Extracting Labels from graphs -labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap block n e x               -> LabelSet labelsDefined GNil      = setEmpty labelsDefined (GUnit{}) = setEmpty labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body-  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet+  where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet         addEntry labels label _ = setInsert label labels         exitLabel :: MaybeO x (block n C O) -> LabelSet         exitLabel NothingO  = setEmpty
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}  module GHC.Cmm.Dataflow.Label     ( Label@@ -11,17 +13,76 @@     , FactBase     , lookupFact     , mkHooplLabel+    -- * Set+    , setEmpty+    , setNull+    , setSize+    , setMember+    , setSingleton+    , setInsert+    , setDelete+    , setUnion+    , setUnions+    , setDifference+    , setIntersection+    , setIsSubsetOf+    , setFilter+    , setFoldl+    , setFoldr+    , setFromList+    , setElems+    -- * Map+    , mapNull+    , mapSize+    , mapMember+    , mapLookup+    , mapFindWithDefault+    , mapEmpty+    , mapSingleton+    , mapInsert+    , mapInsertWith+    , mapDelete+    , mapAlter+    , mapAdjust+    , mapUnion+    , mapUnions+    , mapUnionWithKey+    , mapDifference+    , mapIntersection+    , mapIsSubmapOf+    , mapMap+    , mapMapWithKey+    , mapFoldl+    , mapFoldr+    , mapFoldlWithKey+    , mapFoldMapWithKey+    , mapFilter+    , mapFilterWithKey+    , mapElems+    , mapKeys+    , mapToList+    , mapFromList+    , mapFromListWith+    , mapMapMaybe     ) where  import GHC.Prelude +import GHC.Utils.Misc import GHC.Utils.Outputable --- TODO: This should really just use GHC's Unique and Uniq{Set,FM}-import GHC.Cmm.Dataflow.Collections- import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)++-- The code generator will eventually be using all the labels stored in a+-- LabelSet and LabelMap. For these reasons we use the strict variants of these+-- data structures. We inline selectively to enable the RULES in Word64Map/Set+-- to fire.+import GHC.Data.Word64Set (Word64Set)+import qualified GHC.Data.Word64Set as S+import GHC.Data.Word64Map.Strict (Word64Map)+import qualified GHC.Data.Word64Map.Strict as M import GHC.Data.TrieMap+ import Data.Word (Word64)  @@ -30,7 +91,7 @@ -----------------------------------------------------------------------------  newtype Label = Label { lblToUnique :: Word64 }-  deriving (Eq, Ord)+  deriving newtype (Eq, Ord)  mkHooplLabel :: Word64 -> Label mkHooplLabel = Label@@ -50,79 +111,179 @@ ----------------------------------------------------------------------------- -- LabelSet -newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)+newtype LabelSet = LS Word64Set+  deriving newtype (Eq, Ord, Show, Monoid, Semigroup) -instance IsSet LabelSet where-  type ElemOf LabelSet = Label+setNull :: LabelSet -> Bool+setNull (LS s) = S.null s -  setNull (LS s) = setNull s-  setSize (LS s) = setSize s-  setMember (Label k) (LS s) = setMember k s+setSize :: LabelSet -> Int+setSize (LS s) = S.size s -  setEmpty = LS setEmpty-  setSingleton (Label k) = LS (setSingleton k)-  setInsert (Label k) (LS s) = LS (setInsert k s)-  setDelete (Label k) (LS s) = LS (setDelete k s)+setMember :: Label -> LabelSet -> Bool+setMember (Label k) (LS s) = S.member k s -  setUnion (LS x) (LS y) = LS (setUnion x y)-  setDifference (LS x) (LS y) = LS (setDifference x y)-  setIntersection (LS x) (LS y) = LS (setIntersection x y)-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y-  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)-  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s-  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s+setEmpty :: LabelSet+setEmpty = LS S.empty -  setElems (LS s) = map mkHooplLabel (setElems s)-  setFromList ks = LS (setFromList (map lblToUnique ks))+setSingleton :: Label -> LabelSet+setSingleton (Label k) = LS (S.singleton k) +setInsert :: Label -> LabelSet -> LabelSet+setInsert (Label k) (LS s) = LS (S.insert k s)++setDelete :: Label -> LabelSet -> LabelSet+setDelete (Label k) (LS s) = LS (S.delete k s)++setUnion :: LabelSet -> LabelSet -> LabelSet+setUnion (LS x) (LS y) = LS (S.union x y)++{-# INLINE setUnions #-}+setUnions :: [LabelSet] -> LabelSet+setUnions = foldl1WithDefault' setEmpty setUnion++setDifference :: LabelSet -> LabelSet -> LabelSet+setDifference (LS x) (LS y) = LS (S.difference x y)++setIntersection :: LabelSet -> LabelSet -> LabelSet+setIntersection (LS x) (LS y) = LS (S.intersection x y)++setIsSubsetOf :: LabelSet -> LabelSet -> Bool+setIsSubsetOf (LS x) (LS y) = S.isSubsetOf x y++setFilter :: (Label -> Bool) -> LabelSet -> LabelSet+setFilter f (LS s) = LS (S.filter (f . mkHooplLabel) s)++{-# INLINE setFoldl #-}+setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t+setFoldl k z (LS s) = S.foldl (\a v -> k a (mkHooplLabel v)) z s++{-# INLINE setFoldr #-}+setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t+setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s++{-# INLINE setElems #-}+setElems :: LabelSet -> [Label]+setElems (LS s) = map mkHooplLabel (S.elems s)++{-# INLINE setFromList #-}+setFromList :: [Label] -> LabelSet+setFromList ks  = LS (S.fromList (map lblToUnique ks))+ ----------------------------------------------------------------------------- -- LabelMap -newtype LabelMap v = LM (UniqueMap v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)+newtype LabelMap v = LM (Word64Map v)+  deriving newtype (Eq, Ord, Show, Functor, Foldable)+  deriving stock   Traversable -instance IsMap LabelMap where-  type KeyOf LabelMap = Label+mapNull :: LabelMap a -> Bool+mapNull (LM m) = M.null m -  mapNull (LM m) = mapNull m-  mapSize (LM m) = mapSize m-  mapMember (Label k) (LM m) = mapMember k m-  mapLookup (Label k) (LM m) = mapLookup k m-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m+{-# INLINE mapSize #-}+mapSize :: LabelMap a -> Int+mapSize (LM m) = M.size m -  mapEmpty = LM mapEmpty-  mapSingleton (Label k) v = LM (mapSingleton k v)-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)-  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)-  mapDelete (Label k) (LM m) = LM (mapDelete k m)-  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)-  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)+mapMember :: Label -> LabelMap a -> Bool+mapMember (Label k) (LM m) = M.member k m -  mapUnion (LM x) (LM y) = LM (mapUnion x y)-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)-  mapDifference (LM x) (LM y) = LM (mapDifference x y)-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y+mapLookup :: Label -> LabelMap a -> Maybe a+mapLookup (Label k) (LM m) = M.lookup k m -  mapMap f (LM m) = LM (mapMap f m)-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)-  mapFoldl k z (LM m) = mapFoldl k z m-  mapFoldr k z (LM m) = mapFoldr k z m-  mapFoldlWithKey k z (LM m) =-      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m-  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m-  {-# INLINEABLE mapFilter #-}-  mapFilter f (LM m) = LM (mapFilter f m)-  {-# INLINEABLE mapFilterWithKey #-}-  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)+mapFindWithDefault :: a -> Label -> LabelMap a -> a+mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m -  mapElems (LM m) = mapElems m-  mapKeys (LM m) = map mkHooplLabel (mapKeys m)-  {-# INLINEABLE mapToList #-}-  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])-  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])+mapEmpty :: LabelMap v+mapEmpty = LM M.empty +mapSingleton :: Label -> v -> LabelMap v+mapSingleton (Label k) v = LM (M.singleton k v)++mapInsert :: Label -> v -> LabelMap v -> LabelMap v+mapInsert (Label k) v (LM m) = LM (M.insert k v m)++mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v+mapInsertWith f (Label k) v (LM m) = LM (M.insertWith f k v m)++mapDelete :: Label -> LabelMap v -> LabelMap v+mapDelete (Label k) (LM m) = LM (M.delete k m)++mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v+mapAlter f (Label k) (LM m) = LM (M.alter f k m)++mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v+mapAdjust f (Label k) (LM m) = LM (M.adjust f k m)++mapUnion :: LabelMap v -> LabelMap v -> LabelMap v+mapUnion (LM x) (LM y) = LM (M.union x y)++{-# INLINE mapUnions #-}+mapUnions :: [LabelMap a] -> LabelMap a+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)++mapDifference :: LabelMap v -> LabelMap b -> LabelMap v+mapDifference (LM x) (LM y) = LM (M.difference x y)++mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v+mapIntersection (LM x) (LM y) = LM (M.intersection x y)++mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool+mapIsSubmapOf (LM x) (LM y) = M.isSubmapOf x y++mapMap :: (a -> v) -> LabelMap a -> LabelMap v+mapMap f (LM m) = LM (M.map f m)++mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v+mapMapWithKey f (LM m) = LM (M.mapWithKey (f . mkHooplLabel) m)++{-# INLINE mapFoldl #-}+mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a+mapFoldl k z (LM m) = M.foldl k z m++{-# INLINE mapFoldr #-}+mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b+mapFoldr k z (LM m) = M.foldr k z m++{-# INLINE mapFoldlWithKey #-}+mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t+mapFoldlWithKey k z (LM m) = M.foldlWithKey (\a v -> k a (mkHooplLabel v)) z m++mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m+mapFoldMapWithKey f (LM m) = M.foldMapWithKey (\k v -> f (mkHooplLabel k) v) m++{-# INLINEABLE mapFilter #-}+mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v+mapFilter f (LM m) = LM (M.filter f m)++{-# INLINEABLE mapFilterWithKey #-}+mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v+mapFilterWithKey f (LM m)  = LM (M.filterWithKey (f . mkHooplLabel) m)++{-# INLINE mapElems #-}+mapElems :: LabelMap a -> [a]+mapElems (LM m) = M.elems m++{-# INLINE mapKeys #-}+mapKeys :: LabelMap a -> [Label]+mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)++{-# INLINE mapToList #-}+mapToList :: LabelMap b -> [(Label, b)]+mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]++{-# INLINE mapFromList #-}+mapFromList :: [(Label, v)] -> LabelMap v+mapFromList assocs = LM (M.fromList [(lblToUnique k, v) | (k, v) <- assocs])++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 @@ -137,11 +298,12 @@  instance TrieMap LabelMap where   type Key LabelMap = Label-  emptyTM = mapEmpty-  lookupTM k m = mapLookup k m+  emptyTM       = mapEmpty+  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+  foldTM k m z  = mapFoldr k z m+  filterTM f    = mapFilter f+  mapMaybeTM f  = mapMapMaybe f  ----------------------------------------------------------------------------- -- FactBase
compiler/GHC/Cmm/Expr.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}  module GHC.Cmm.Expr@@ -12,11 +8,11 @@     , AlignmentSpec(..)       -- TODO: Remove:     , LocalReg(..), localRegType-    , GlobalReg(..), isArgReg, globalRegType+    , GlobalReg(..), isArgReg, globalRegSpillType+    , GlobalRegUse(..)     , spReg, hpReg, spLimReg, hpLimReg, nodeReg     , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg     , node, baseReg-    , VGcPtr(..)      , DefinerOfRegs, UserOfRegs     , foldRegsDefd, foldRegsUsed@@ -248,9 +244,9 @@ cmmExprType platform = \case    (CmmLit lit)        -> cmmLitType platform lit    (CmmLoad _ rep _)   -> rep-   (CmmReg reg)        -> cmmRegType platform reg+   (CmmReg reg)        -> cmmRegType reg    (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)-   (CmmRegOff reg _)   -> cmmRegType platform reg+   (CmmRegOff reg _)   -> cmmRegType reg    (CmmStackSlot _ _)  -> bWord platform -- an address    -- Careful though: what is stored at the stack slot may be bigger than    -- an address@@ -385,10 +381,18 @@ instance UserOfRegs GlobalReg CmmReg where     {-# INLINEABLE foldRegsUsed #-}     foldRegsUsed _ _ z (CmmLocal _)    = z-    foldRegsUsed _ f z (CmmGlobal reg) = f z reg+    foldRegsUsed _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg +instance UserOfRegs GlobalRegUse CmmReg where+    {-# INLINEABLE foldRegsUsed #-}+    foldRegsUsed _ _ z (CmmLocal _)    = z+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg instance DefinerOfRegs GlobalReg CmmReg where     foldRegsDefd _ _ z (CmmLocal _)    = z+    foldRegsDefd _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg++instance DefinerOfRegs GlobalRegUse CmmReg where+    foldRegsDefd _ _ z (CmmLocal _)    = z     foldRegsDefd _ f z (CmmGlobal reg) = f z reg  instance Ord r => UserOfRegs r r where@@ -427,7 +431,7 @@         CmmRegOff reg i ->                 pprExpr platform (CmmMachOp (MO_Add rep)                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])-                where rep = typeWidth (cmmRegType platform reg)+                where rep = typeWidth (cmmRegType reg)         CmmLit lit -> pprLit platform lit         _other     -> pprExpr1 platform e @@ -502,6 +506,8 @@         CmmMachOp mop args  -> genMachOp platform mop args  genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc+genMachOp platform (MO_RelaxedRead w) [x] =+    ppr (cmmBits w) <> text "!" <> brackets (pdoc platform x) genMachOp platform mop args    | Just doc <- infixMachOp mop = case args of         -- dyadic
compiler/GHC/Cmm/MachOp.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Cmm.MachOp     ( MachOp(..)@@ -22,10 +22,14 @@     , CallishMachOp(..), callishMachOpHints     , pprCallishMachOp     , machOpMemcpyishAlign+    , callishMachOpArgTys      -- Atomic read-modify-write     , MemoryOrdering(..)     , AtomicMachOp(..)++    -- Fused multiply-add+    , FMASign(..), pprFMASign    ) where @@ -34,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 -----------------------------------------------------------------------------@@ -68,7 +75,7 @@ -- -- (1) has the benefit that its interpretation is completely independent of the -- architecture. So, the mid-term plan is to migrate to this--- interpretation/sematics.+-- interpretation/semantics.  data MachOp   -- Integer operations (insensitive to signed/unsigned)@@ -108,6 +115,10 @@   | MO_F_Mul  Width   | MO_F_Quot Width +  -- Floating-point fused multiply-add operations+  -- | Fused multiply-add, see 'FMASign'.+  | MO_FMA FMASign Length Width+   -- Floating point comparison   | MO_F_Eq Width   | MO_F_Ne Width@@ -116,6 +127,9 @@   | MO_F_Gt Width   | MO_F_Lt Width +  | MO_F_Min Width+  | MO_F_Max Width+   -- Bitwise operations.  Not all of these may be supported   -- at all sizes, and only integral Widths are valid.   | MO_And   Width@@ -130,8 +144,8 @@    -- Conversions.  Some of these will be NOPs.   -- Floating-point conversions use the signed variant.-  | MO_SF_Conv Width Width      -- Signed int -> Float-  | MO_FS_Conv Width Width      -- Float -> Signed int+  | MO_SF_Round    Width Width  -- Signed int -> Float+  | MO_FS_Truncate Width Width  -- Float -> Signed int   | MO_SS_Conv Width Width      -- Signed int -> Signed int   | MO_UU_Conv Width Width      -- unsigned int -> unsigned int   | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the@@ -142,29 +156,30 @@                                 -- MO_XX_Conv, e.g.,                                 --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)                                 -- is equivalent to just x.-  | MO_FF_Conv Width Width      -- Float -> Float+  | MO_FF_Conv Width Width      -- Float  -> Float +  | MO_WF_Bitcast Width      -- Word32/Word64   -> Float/Double+  | MO_FW_Bitcast Width      -- Float/Double  -> Word32/Word64+   -- Vector element insertion and extraction operations-  | MO_V_Insert  Length Width   -- Insert scalar into vector-  | MO_V_Extract Length Width   -- Extract scalar from vector+  | MO_V_Broadcast Length Width -- Broadcast a scalar into a vector+  | MO_V_Insert    Length Width -- Insert scalar into vector+  | MO_V_Extract   Length Width -- Extract scalar from vector    -- Integer vector operations   | 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]    -- Floating point vector element insertion and extraction operations-  | MO_VF_Insert  Length Width   -- Insert scalar into vector-  | MO_VF_Extract Length Width   -- Extract scalar from vector+  | MO_VF_Broadcast Length Width   -- Broadcast a scalar into a vector+  | MO_VF_Insert    Length Width   -- Insert scalar into vector+  | MO_VF_Extract   Length Width   -- Extract scalar from vector    -- Floating point vector operations   | MO_VF_Add  Length Width@@ -173,6 +188,18 @@   | MO_VF_Mul  Length Width   | MO_VF_Quot Length Width +  -- Min/max operations+  | MO_VS_Min Length Width+  | MO_VS_Max Length Width+  | MO_VU_Min Length Width+  | MO_VU_Max Length Width+  | MO_VF_Min Length Width+  | MO_VF_Max Length Width++  -- | An atomic read with no memory ordering. Address msut+  -- be naturally aligned.+  | MO_RelaxedRead Width+   -- Alignment check (for -falignment-sanitisation)   | MO_AlignmentCheck Int Width   deriving (Eq, Show)@@ -180,7 +207,30 @@ pprMachOp :: MachOp -> SDoc pprMachOp mo = text (show mo) +-- | Where are the signs in a fused multiply-add instruction?+--+-- @x*y + z@ vs @x*y - z@ vs @-x*y+z@ vs @-x*y-z@.+--+-- Warning: the signs aren't consistent across architectures (X86, PowerPC, AArch64).+-- The user-facing implementation uses the X86 convention, while the relevant+-- backends use their corresponding conventions.+data FMASign+  -- | Fused multiply-add @x*y + z@.+  = FMAdd+  -- | Fused multiply-subtract. On X86: @x*y - z@.+  | FMSub+  -- | Fused multiply-add. On X86: @-x*y + z@.+  | FNMAdd+  -- | Fused multiply-subtract. On X86: @-x*y - z@.+  | FNMSub+  deriving (Eq, Show) +pprFMASign :: IsLine doc => FMASign -> doc+pprFMASign = \case+  FMAdd  -> text "fmadd"+  FMSub  -> text "fmsub"+  FNMAdd -> text "fnmadd"+  FNMSub -> text "fnmsub"  -- ----------------------------------------------------------------------------- -- Some common MachReps@@ -276,6 +326,8 @@         MO_Xor _                -> True         MO_F_Add _              -> True         MO_F_Mul _              -> True+        MO_F_Min {}             -> True+        MO_F_Max {}             -> True         _other                  -> False  -- ----------------------------------------------------------------------------@@ -370,16 +422,16 @@ maybeInvertComparison :: MachOp -> Maybe MachOp maybeInvertComparison op   = case op of  -- None of these Just cases include floating point-        MO_Eq r   -> Just (MO_Ne r)-        MO_Ne r   -> Just (MO_Eq r)-        MO_U_Lt r -> Just (MO_U_Ge r)-        MO_U_Gt r -> Just (MO_U_Le r)-        MO_U_Le r -> Just (MO_U_Gt r)-        MO_U_Ge r -> Just (MO_U_Lt r)-        MO_S_Lt r -> Just (MO_S_Ge r)-        MO_S_Gt r -> Just (MO_S_Le r)-        MO_S_Le r -> Just (MO_S_Gt r)-        MO_S_Ge r -> Just (MO_S_Lt r)+        MO_Eq w   -> Just (MO_Ne w)+        MO_Ne w   -> Just (MO_Eq w)+        MO_U_Lt w -> Just (MO_U_Ge w)+        MO_U_Gt w -> Just (MO_U_Le w)+        MO_U_Le w -> Just (MO_U_Gt w)+        MO_U_Ge w -> Just (MO_U_Lt w)+        MO_S_Lt w -> Just (MO_S_Ge w)+        MO_S_Gt w -> Just (MO_S_Le w)+        MO_S_Le w -> Just (MO_S_Gt w)+        MO_S_Ge w -> Just (MO_S_Lt w)         _other    -> Nothing  -- ----------------------------------------------------------------------------@@ -393,13 +445,13 @@   case mop of     MO_Add {}           -> ty1  -- Preserve GC-ptr-hood     MO_Sub {}           -> ty1  -- of first arg-    MO_Mul    r         -> cmmBits r-    MO_S_MulMayOflo r   -> cmmBits r-    MO_S_Quot r         -> cmmBits r-    MO_S_Rem  r         -> cmmBits r-    MO_S_Neg  r         -> cmmBits r-    MO_U_Quot r         -> cmmBits r-    MO_U_Rem  r         -> cmmBits r+    MO_Mul    w         -> cmmBits w+    MO_S_MulMayOflo w   -> cmmBits w+    MO_S_Quot w         -> cmmBits w+    MO_S_Rem  w         -> cmmBits w+    MO_S_Neg  w         -> cmmBits w+    MO_U_Quot w         -> cmmBits w+    MO_U_Rem  w         -> cmmBits w      MO_Eq {}            -> comparisonResultRep platform     MO_Ne {}            -> comparisonResultRep platform@@ -413,11 +465,16 @@     MO_U_Gt {}          -> comparisonResultRep platform     MO_U_Lt {}          -> comparisonResultRep platform -    MO_F_Add r          -> cmmFloat r-    MO_F_Sub r          -> cmmFloat r-    MO_F_Mul r          -> cmmFloat r-    MO_F_Quot r         -> cmmFloat r-    MO_F_Neg r          -> cmmFloat r+    MO_F_Add w          -> cmmFloat w+    MO_F_Sub w          -> cmmFloat w+    MO_F_Mul w          -> cmmFloat w+    MO_F_Quot w         -> cmmFloat w+    MO_F_Neg w          -> cmmFloat w+    MO_F_Min w          -> cmmFloat w+    MO_F_Max w          -> cmmFloat w++    MO_FMA _ l w        -> if l == 1 then cmmFloat w else cmmVec l (cmmFloat w)+     MO_F_Eq  {}         -> comparisonResultRep platform     MO_F_Ne  {}         -> comparisonResultRep platform     MO_F_Ge  {}         -> comparisonResultRep platform@@ -428,18 +485,21 @@     MO_And {}           -> ty1  -- Used for pointer masking     MO_Or {}            -> ty1     MO_Xor {}           -> ty1-    MO_Not   r          -> cmmBits r-    MO_Shl   r          -> cmmBits r-    MO_U_Shr r          -> cmmBits r-    MO_S_Shr r          -> cmmBits r+    MO_Not   w          -> cmmBits w+    MO_Shl   w          -> cmmBits w+    MO_U_Shr w          -> cmmBits w+    MO_S_Shr w          -> cmmBits w      MO_SS_Conv _ to     -> cmmBits to     MO_UU_Conv _ to     -> cmmBits to     MO_XX_Conv _ to     -> cmmBits to-    MO_FS_Conv _ to     -> cmmBits to-    MO_SF_Conv _ to     -> cmmFloat to+    MO_FS_Truncate _ to -> cmmBits to+    MO_SF_Round _ to    -> cmmFloat to     MO_FF_Conv _ to     -> cmmFloat to+    MO_WF_Bitcast   w   -> cmmFloat w+    MO_FW_Bitcast   w   -> cmmBits w +    MO_V_Broadcast l w  -> cmmVec l (cmmBits w)     MO_V_Insert  l w    -> cmmVec l (cmmBits w)     MO_V_Extract _ w    -> cmmBits w @@ -447,13 +507,17 @@     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) +    MO_V_Shuffle  l w _ -> cmmVec l (cmmBits w)+    MO_VF_Shuffle l w _ -> cmmVec l (cmmFloat w)++    MO_VF_Broadcast l w -> cmmVec l (cmmFloat w)     MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)     MO_VF_Extract _ w   -> cmmFloat w @@ -462,10 +526,13 @@     MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)     MO_VF_Quot l w      -> cmmVec l (cmmFloat w)     MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Min  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Max  l w      -> cmmVec l (cmmFloat w) +    MO_RelaxedRead w    -> cmmBits w     MO_AlignmentCheck _ _ -> ty1   where-    (ty1:_) = tys+    ty1:|_ = expectNonEmpty tys  comparisonResultRep :: Platform -> CmmType comparisonResultRep = bWord  -- is it?@@ -482,79 +549,97 @@ machOpArgReps :: Platform -> MachOp -> [Width] machOpArgReps platform op =   case op of-    MO_Add    r         -> [r,r]-    MO_Sub    r         -> [r,r]-    MO_Eq     r         -> [r,r]-    MO_Ne     r         -> [r,r]-    MO_Mul    r         -> [r,r]-    MO_S_MulMayOflo r   -> [r,r]-    MO_S_Quot r         -> [r,r]-    MO_S_Rem  r         -> [r,r]-    MO_S_Neg  r         -> [r]-    MO_U_Quot r         -> [r,r]-    MO_U_Rem  r         -> [r,r]+    MO_Add    w         -> [w,w]+    MO_Sub    w         -> [w,w]+    MO_Eq     w         -> [w,w]+    MO_Ne     w         -> [w,w]+    MO_Mul    w         -> [w,w]+    MO_S_MulMayOflo w   -> [w,w]+    MO_S_Quot w         -> [w,w]+    MO_S_Rem  w         -> [w,w]+    MO_S_Neg  w         -> [w]+    MO_U_Quot w         -> [w,w]+    MO_U_Rem  w         -> [w,w] -    MO_S_Ge r           -> [r,r]-    MO_S_Le r           -> [r,r]-    MO_S_Gt r           -> [r,r]-    MO_S_Lt r           -> [r,r]+    MO_S_Ge w           -> [w,w]+    MO_S_Le w           -> [w,w]+    MO_S_Gt w           -> [w,w]+    MO_S_Lt w           -> [w,w] -    MO_U_Ge r           -> [r,r]-    MO_U_Le r           -> [r,r]-    MO_U_Gt r           -> [r,r]-    MO_U_Lt r           -> [r,r]+    MO_U_Ge w           -> [w,w]+    MO_U_Le w           -> [w,w]+    MO_U_Gt w           -> [w,w]+    MO_U_Lt w           -> [w,w] -    MO_F_Add r          -> [r,r]-    MO_F_Sub r          -> [r,r]-    MO_F_Mul r          -> [r,r]-    MO_F_Quot r         -> [r,r]-    MO_F_Neg r          -> [r]-    MO_F_Eq  r          -> [r,r]-    MO_F_Ne  r          -> [r,r]-    MO_F_Ge  r          -> [r,r]-    MO_F_Le  r          -> [r,r]-    MO_F_Gt  r          -> [r,r]-    MO_F_Lt  r          -> [r,r]+    MO_F_Add w          -> [w,w]+    MO_F_Sub w          -> [w,w]+    MO_F_Mul w          -> [w,w]+    MO_F_Quot w         -> [w,w]+    MO_F_Neg w          -> [w]+    MO_F_Min w          -> [w,w]+    MO_F_Max w          -> [w,w] -    MO_And   r          -> [r,r]-    MO_Or    r          -> [r,r]-    MO_Xor   r          -> [r,r]-    MO_Not   r          -> [r]-    MO_Shl   r          -> [r, wordWidth platform]-    MO_U_Shr r          -> [r, wordWidth platform]-    MO_S_Shr r          -> [r, wordWidth platform]+    MO_FMA _ l w        -> [vecwidth l w, vecwidth l w, vecwidth l w] -    MO_SS_Conv from _   -> [from]-    MO_UU_Conv from _   -> [from]-    MO_XX_Conv from _   -> [from]-    MO_SF_Conv from _   -> [from]-    MO_FS_Conv from _   -> [from]-    MO_FF_Conv from _   -> [from]+    MO_F_Eq  w          -> [w,w]+    MO_F_Ne  w          -> [w,w]+    MO_F_Ge  w          -> [w,w]+    MO_F_Le  w          -> [w,w]+    MO_F_Gt  w          -> [w,w]+    MO_F_Lt  w          -> [w,w] -    MO_V_Insert   l r   -> [typeWidth (vec l (cmmBits r)),r, W32]-    MO_V_Extract  l r   -> [typeWidth (vec l (cmmBits r)), W32]-    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,W32]-    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),W32]+    MO_And   w          -> [w,w]+    MO_Or    w          -> [w,w]+    MO_Xor   w          -> [w,w]+    MO_Not   w          -> [w]+    MO_Shl   w          -> [w, wordWidth platform]+    MO_U_Shr w          -> [w, wordWidth platform]+    MO_S_Shr w          -> [w, wordWidth platform]++    MO_SS_Conv from _     -> [from]+    MO_UU_Conv from _     -> [from]+    MO_XX_Conv from _     -> [from]+    MO_SF_Round from _    -> [from]+    MO_FS_Truncate from _ -> [from]+    MO_FF_Conv from _     -> [from]+    MO_WF_Bitcast w       -> [w]+    MO_FW_Bitcast w       -> [w]++    MO_V_Shuffle  l w _ -> [vecwidth l w, vecwidth l w]+    MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w]++    MO_V_Broadcast _ w  -> [w]+    MO_V_Insert   l w   -> [vecwidth l w, w, W32]+    MO_V_Extract  l w   -> [vecwidth l w, W32]+    MO_VF_Broadcast _ w -> [w]+    MO_VF_Insert  l w   -> [vecwidth l w, w, W32]+    MO_VF_Extract l w   -> [vecwidth l w, W32]       -- SIMD vector indices are always 32 bit -    MO_V_Add _ r        -> [r,r]-    MO_V_Sub _ r        -> [r,r]-    MO_V_Mul _ r        -> [r,r]+    MO_V_Add l w        -> [vecwidth l w, vecwidth l w]+    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 _ r      -> [r,r]-    MO_VS_Rem  _ r      -> [r,r]-    MO_VS_Neg  _ r      -> [r]+    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 _ r      -> [r,r]-    MO_VU_Rem  _ r      -> [r,r]+    MO_VU_Min  l w      -> [vecwidth l w, vecwidth l w]+    MO_VU_Max  l w      -> [vecwidth l w, vecwidth l w] -    MO_VF_Add  _ r      -> [r,r]-    MO_VF_Sub  _ r      -> [r,r]-    MO_VF_Mul  _ r      -> [r,r]-    MO_VF_Quot _ r      -> [r,r]-    MO_VF_Neg  _ r      -> [r]+    -- NOTE: The below is owing to the fact that floats use the SSE registers+    MO_VF_Add  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Sub  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Mul  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Quot l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Neg  l w      -> [vecwidth l w]+    MO_VF_Min  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Max  l w      -> [vecwidth l w, vecwidth l w] -    MO_AlignmentCheck _ r -> [r]+    MO_RelaxedRead _    -> [wordWidth platform]+    MO_AlignmentCheck _ w -> [w]+  where+    vecwidth l w = widthFromBytes (l * widthInBytes w)  ----------------------------------------------------------------------------- -- CallishMachOp@@ -652,8 +737,20 @@   | MO_SubIntC   Width   | MO_U_Mul2    Width -  | MO_ReadBarrier-  | MO_WriteBarrier+  -- 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@@ -683,6 +780,10 @@   | MO_BSwap Width   | MO_BRev Width +  | MO_AcquireFence+  | MO_ReleaseFence+  | MO_SeqCstFence+   -- | Atomic read-modify-write. Arguments are @[dest, n]@.   | MO_AtomicRMW Width AtomicMachOp   -- | Atomic read. Arguments are @[addr]@.@@ -744,3 +845,144 @@   MO_Memmove align -> Just align   MO_Memcmp  align -> Just align   _                -> Nothing++-- | 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/Node.hs view
@@ -1,11 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} @@ -41,7 +35,6 @@ import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import Data.Foldable (toList) import Data.Functor.Classes (liftCompare)@@ -125,7 +118,7 @@           -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or           -- (CmmStackSlot (Young b) _). -      cml_args_regs :: [GlobalReg],+      cml_args_regs :: [GlobalRegUse],           -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed           -- to the call.  This is essential information for the           -- native code generator's register allocator; without@@ -509,7 +502,7 @@  = pdoc platform                (mkForeignLabel                           (mkFastString (show op))-                          Nothing ForeignLabelInThisPackage IsFunction)+                          ForeignLabelInThisPackage IsFunction)  instance Outputable Convention where   ppr = pprConvention@@ -551,7 +544,7 @@                => (b -> LocalReg -> b) -> b -> a -> b           fold f z n = foldRegsUsed platform f z n -instance UserOfRegs GlobalReg (CmmNode e x) where+instance UserOfRegs GlobalRegUse (CmmNode e x) where   {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr@@ -562,10 +555,9 @@     CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt     CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args     _ -> z-    where fold :: forall a b.  UserOfRegs GlobalReg a-               => (b -> GlobalReg -> b) -> b -> a -> b+    where fold :: forall a b.  UserOfRegs GlobalRegUse a+               => (b -> GlobalRegUse -> b) -> b -> a -> b           fold f z n = foldRegsUsed platform f z n- instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where   -- The (Ord r) in the context is necessary here   -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance@@ -584,7 +576,7 @@                => (b -> LocalReg -> b) -> b -> a -> b           fold f z n = foldRegsDefd platform f z n -instance DefinerOfRegs GlobalReg (CmmNode e x) where+instance DefinerOfRegs GlobalRegUse (CmmNode e x) where   {-# INLINEABLE foldRegsDefd #-}   foldRegsDefd platform f !z n = case n of     CmmAssign lhs _ -> fold f z lhs@@ -593,12 +585,13 @@     CmmForeignCall {} -> fold f z activeRegs                       -- See Note [Safe foreign calls clobber STG registers]     _ -> z-    where fold :: forall a b. DefinerOfRegs GlobalReg a-               => (b -> GlobalReg -> b) -> b -> a -> b+    where fold :: forall a b. DefinerOfRegs GlobalRegUse a+               => (b -> GlobalRegUse -> b) -> b -> a -> b           fold f z n = foldRegsDefd platform f z n -          activeRegs = activeStgRegs platform-          activeCallerSavesRegs = filter (callerSaves platform) activeRegs+          activeRegs :: [GlobalRegUse]+          activeRegs = map (\ r -> GlobalRegUse r (globalRegSpillType platform r)) $ activeStgRegs platform+          activeCallerSavesRegs = filter (callerSaves platform . globalRegUse_reg) activeRegs            foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []           foreignTargetRegs _ = activeCallerSavesRegs
compiler/GHC/Cmm/Reg.hs view
@@ -11,12 +11,13 @@     , LocalReg(..)     , localRegType       -- * Global registers-    , GlobalReg(..), isArgReg, globalRegType-    , pprGlobalReg+    , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg     , spReg, hpReg, spLimReg, hpLimReg, nodeReg     , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg     , node, baseReg-    , VGcPtr(..)+    , GlobalRegUse(..), pprGlobalRegUse++    , GlobalArgRegs(..)     ) where  import GHC.Prelude@@ -30,10 +31,66 @@ --              Cmm registers ----------------------------------------------------------------------------- +{- Note [GlobalReg vs GlobalRegUse]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We distinguish GlobalReg, which describes registers in the STG abstract machine,+with GlobalRegUse, which describes an usage of such a register to store values+of a particular CmmType.++For example, we might want to load/store an 8-bit integer in a register that+can store 32-bit integers.++The width of the type must fit in the register, i.e. for a usage+@GlobalRegUse reg ty@ we must have that++  > typeWidth ty <= typeWidth (globalRegSpillType reg)++The restrictions about what categories of types can be stored in a given+register are less easily stated. Some examples are:++  - Vanilla registers can contain both pointers (gcWord) and non-pointers (bWord),+    as well as sub-word sized values (e.g. b16).+  - On x86_64, SIMD registers can be used to hold vectors of both floating+    and integral values (e.g. XmmReg may store 2 Double values or 4 Int32 values).+-}++-- | A use of a global register at a particular type.+--+-- While a 'GlobalReg' identifies a global register in the STG machine,+-- a 'GlobalRegUse' also contains information about the type we are storing+-- in the register.+--+-- See Note [GlobalReg vs GlobalRegUse] for more information.+data GlobalRegUse+  = GlobalRegUse+    { globalRegUse_reg  :: !GlobalReg+      -- ^ The underlying 'GlobalReg'+    , globalRegUse_type :: !CmmType+      -- ^ The 'CmmType' at which we are using the 'GlobalReg'.+      --+      -- Its width must be less than the width of the 'GlobalReg':+      --+      -- > typeWidth ty <= typeWidth (globalRegSpillType platform reg)+    }+  deriving Show++instance Outputable GlobalRegUse where+  ppr (GlobalRegUse reg _) = ppr reg++pprGlobalRegUse :: IsLine doc => GlobalRegUse -> doc+pprGlobalRegUse (GlobalRegUse reg _) = pprGlobalReg reg++-- TODO: these instances should be removed in favour+-- of more surgical uses of equality.+instance Eq GlobalRegUse where+  GlobalRegUse r1 _ == GlobalRegUse r2 _ = r1 == r2+instance Ord GlobalRegUse where+  GlobalRegUse r1 _ `compare` GlobalRegUse r2 _ = compare r1 r2+ data CmmReg   = CmmLocal  {-# UNPACK #-} !LocalReg-  | CmmGlobal GlobalReg-  deriving( Eq, Ord, Show )+  | CmmGlobal GlobalRegUse+  deriving ( Eq, Ord, Show )  instance Outputable CmmReg where     ppr e = pprReg e@@ -41,16 +98,15 @@ pprReg :: CmmReg -> SDoc pprReg r    = case r of-        CmmLocal  local  -> pprLocalReg  local-        CmmGlobal global -> pprGlobalReg global--cmmRegType :: Platform -> CmmReg -> CmmType-cmmRegType _        (CmmLocal  reg) = localRegType reg-cmmRegType platform (CmmGlobal reg) = globalRegType platform reg+        CmmLocal  local                   -> pprLocalReg  local+        CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global -cmmRegWidth :: Platform -> CmmReg -> Width-cmmRegWidth platform = typeWidth . cmmRegType platform+cmmRegType :: CmmReg -> CmmType+cmmRegType (CmmLocal  reg) = localRegType reg+cmmRegType (CmmGlobal reg) = globalRegUse_type reg +cmmRegWidth :: CmmReg -> Width+cmmRegWidth = typeWidth . cmmRegType  ----------------------------------------------------------------------------- --              Local registers@@ -129,13 +185,15 @@ there are likely still bugs there, beware! -} -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )-+-- | An abstract global register for the STG machine.+--+-- See also 'GlobalRegUse', which denotes a usage of a register at a particular+-- type (e.g. using a 32-bit wide register to store an 8-bit wide value), as per+-- Note [GlobalReg vs GlobalRegUse]. data GlobalReg   -- Argument and return registers   = VanillaReg                  -- pointers, unboxed ints and chars         {-# UNPACK #-} !Int     -- its number-        VGcPtr    | FloatReg            -- single-precision floating-point registers         {-# UNPACK #-} !Int     -- its number@@ -146,6 +204,13 @@   | LongReg             -- long int registers (64-bit, really)         {-# UNPACK #-} !Int     -- its number +  -- I think we should redesign 'GlobalReg', for example instead of+  -- FloatReg/DoubleReg/XmmReg/YmmReg/ZmmReg we could have a single VecReg+  -- which also stores the type we are storing in it.+  --+  -- We might then be able to get rid of GlobalRegUse, as the type information+  -- would already be contained in a 'GlobalReg'.+   | XmmReg                      -- 128-bit SIMD vector register         {-# UNPACK #-} !Int     -- its number @@ -156,140 +221,46 @@         {-# UNPACK #-} !Int     -- its number    -- STG registers-  | Sp                  -- Stack ptr; points to last occupied stack location.-  | SpLim               -- Stack limit-  | Hp                  -- Heap ptr; points to last occupied heap location.-  | HpLim               -- Heap limit register-  | CCCS                -- Current cost-centre stack-  | CurrentTSO          -- pointer to current thread's TSO-  | CurrentNursery      -- pointer to allocation area-  | HpAlloc             -- allocation count for heap check failure+  | Sp                  -- ^ Stack ptr; points to last occupied stack location.+  | SpLim               -- ^ Stack limit+  | Hp                  -- ^ Heap ptr; points to last occupied heap location.+  | HpLim               -- ^ Heap limit register+  | CCCS                -- ^ Current cost-centre stack+  | CurrentTSO          -- ^ pointer to current thread's TSO+  | CurrentNursery      -- ^ pointer to allocation area+  | HpAlloc             -- ^ allocation count for heap check failure                  -- We keep the address of some commonly-called                 -- functions in the register table, to keep code                 -- size down:-  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info-  | GCEnter1            -- stg_gc_enter_1-  | GCFun               -- stg_gc_fun+  | EagerBlackholeInfo  -- ^ address of stg_EAGER_BLACKHOLE_info+  | GCEnter1            -- ^ address of stg_gc_enter_1+  | GCFun               -- ^ address of stg_gc_fun -  -- Base offset for the register table, used for accessing registers+  -- | Base offset for the register table, used for accessing registers   -- which do not have real registers assigned to them.  This register   -- will only appear after we have expanded GlobalReg into memory accesses   -- (where necessary) in the native code generator.   | BaseReg -  -- The register used by the platform for the C stack pointer. This is+  -- | The register used by the platform for the C stack pointer. This is   -- a break in the STG abstraction used exclusively to setup stack unwinding   -- information.   | MachSp -  -- The is a dummy register used to indicate to the stack unwinder where+  -- | A dummy register used to indicate to the stack unwinder where   -- a routine would return to.   | UnwindReturnReg -  -- Base Register for PIC (position-independent code) calculations-  -- Only used inside the native code generator. It's exact meaning differs+  -- | Base Register for PIC (position-independent code) calculations.+  --+  -- Only used inside the native code generator. Its exact meaning differs   -- from platform to platform (see module PositionIndependentCode).   | PicBaseReg -  deriving( Show )--instance Eq GlobalReg where-   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes-   FloatReg i == FloatReg j = i==j-   DoubleReg i == DoubleReg j = i==j-   LongReg i == LongReg j = i==j-   -- NOTE: XMM, YMM, ZMM registers actually are the same registers-   -- at least with respect to store at YMM i and then read from XMM i-   -- and similarly for ZMM etc.-   XmmReg i == XmmReg j = i==j-   YmmReg i == YmmReg j = i==j-   ZmmReg i == ZmmReg j = i==j-   Sp == Sp = True-   SpLim == SpLim = True-   Hp == Hp = True-   HpLim == HpLim = True-   CCCS == CCCS = True-   CurrentTSO == CurrentTSO = True-   CurrentNursery == CurrentNursery = True-   HpAlloc == HpAlloc = True-   EagerBlackholeInfo == EagerBlackholeInfo = True-   GCEnter1 == GCEnter1 = True-   GCFun == GCFun = True-   BaseReg == BaseReg = True-   MachSp == MachSp = True-   UnwindReturnReg == UnwindReturnReg = True-   PicBaseReg == PicBaseReg = True-   _r1 == _r2 = False---- NOTE: this Ord instance affects the tuple layout in GHCi, see---       Note [GHCi and native call registers]-instance Ord GlobalReg where-   compare (VanillaReg i _) (VanillaReg j _) = compare i j-     -- Ignore type when seeking clashes-   compare (FloatReg i)  (FloatReg  j) = compare i j-   compare (DoubleReg i) (DoubleReg j) = compare i j-   compare (LongReg i)   (LongReg   j) = compare i j-   compare (XmmReg i)    (XmmReg    j) = compare i j-   compare (YmmReg i)    (YmmReg    j) = compare i j-   compare (ZmmReg i)    (ZmmReg    j) = compare i j-   compare Sp Sp = EQ-   compare SpLim SpLim = EQ-   compare Hp Hp = EQ-   compare HpLim HpLim = EQ-   compare CCCS CCCS = EQ-   compare CurrentTSO CurrentTSO = EQ-   compare CurrentNursery CurrentNursery = EQ-   compare HpAlloc HpAlloc = EQ-   compare EagerBlackholeInfo EagerBlackholeInfo = EQ-   compare GCEnter1 GCEnter1 = EQ-   compare GCFun GCFun = EQ-   compare BaseReg BaseReg = EQ-   compare MachSp MachSp = EQ-   compare UnwindReturnReg UnwindReturnReg = EQ-   compare PicBaseReg PicBaseReg = EQ-   compare (VanillaReg _ _) _ = LT-   compare _ (VanillaReg _ _) = GT-   compare (FloatReg _) _     = LT-   compare _ (FloatReg _)     = GT-   compare (DoubleReg _) _    = LT-   compare _ (DoubleReg _)    = GT-   compare (LongReg _) _      = LT-   compare _ (LongReg _)      = GT-   compare (XmmReg _) _       = LT-   compare _ (XmmReg _)       = GT-   compare (YmmReg _) _       = LT-   compare _ (YmmReg _)       = GT-   compare (ZmmReg _) _       = LT-   compare _ (ZmmReg _)       = GT-   compare Sp _ = LT-   compare _ Sp = GT-   compare SpLim _ = LT-   compare _ SpLim = GT-   compare Hp _ = LT-   compare _ Hp = GT-   compare HpLim _ = LT-   compare _ HpLim = GT-   compare CCCS _ = LT-   compare _ CCCS = GT-   compare CurrentTSO _ = LT-   compare _ CurrentTSO = GT-   compare CurrentNursery _ = LT-   compare _ CurrentNursery = GT-   compare HpAlloc _ = LT-   compare _ HpAlloc = GT-   compare GCEnter1 _ = LT-   compare _ GCEnter1 = GT-   compare GCFun _ = LT-   compare _ GCFun = GT-   compare BaseReg _ = LT-   compare _ BaseReg = GT-   compare MachSp _ = LT-   compare _ MachSp = GT-   compare UnwindReturnReg _ = LT-   compare _ UnwindReturnReg = GT-   compare EagerBlackholeInfo _ = LT-   compare _ EagerBlackholeInfo = GT+  deriving( Eq, Ord, Show )+    -- NOTE: the Ord instance affects the tuple layout in GHCi, see+    --       Note [GHCi and native call registers]  instance Outputable GlobalReg where     ppr e = pprGlobalReg e@@ -300,10 +271,7 @@ pprGlobalReg :: IsLine doc => GlobalReg -> doc pprGlobalReg gr     = case gr of-        VanillaReg n _ -> char 'R' <> int n--- Temp Jan08---        VanillaReg n VNonGcPtr -> char 'R' <> int n---        VanillaReg n VGcPtr    -> char 'P' <> int n+        VanillaReg n   -> char 'R' <> int n         FloatReg   n   -> char 'F' <> int n         DoubleReg  n   -> char 'D' <> int n         LongReg    n   -> char 'L' <> int n@@ -331,38 +299,38 @@  -- convenient aliases baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,-  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg-baseReg = CmmGlobal BaseReg-spReg = CmmGlobal Sp-hpReg = CmmGlobal Hp-hpLimReg = CmmGlobal HpLim-spLimReg = CmmGlobal SpLim-nodeReg = CmmGlobal node-currentTSOReg = CmmGlobal CurrentTSO-currentNurseryReg = CmmGlobal CurrentNursery-hpAllocReg = CmmGlobal HpAlloc-cccsReg = CmmGlobal CCCS+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg+baseReg           p = CmmGlobal (GlobalRegUse BaseReg        $ bWord p)+spReg             p = CmmGlobal (GlobalRegUse Sp             $ bWord p)+hpReg             p = CmmGlobal (GlobalRegUse Hp             $ gcWord p)+hpLimReg          p = CmmGlobal (GlobalRegUse HpLim          $ bWord p)+spLimReg          p = CmmGlobal (GlobalRegUse SpLim          $ bWord p)+nodeReg           p = CmmGlobal (GlobalRegUse (VanillaReg 1) $ gcWord p)+currentTSOReg     p = CmmGlobal (GlobalRegUse CurrentTSO     $ bWord p)+currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p)+hpAllocReg        p = CmmGlobal (GlobalRegUse HpAlloc        $ bWord p)+cccsReg           p = CmmGlobal (GlobalRegUse CCCS           $ bWord p)  node :: GlobalReg-node = VanillaReg 1 VGcPtr+node = VanillaReg 1 -globalRegType :: Platform -> GlobalReg -> CmmType-globalRegType platform = \case-   (VanillaReg _ VGcPtr)    -> gcWord platform-   (VanillaReg _ VNonGcPtr) -> bWord platform-   (FloatReg _)             -> cmmFloat W32-   (DoubleReg _)            -> cmmFloat W64-   (LongReg _)              -> cmmBits W64+globalRegSpillType :: Platform -> GlobalReg -> CmmType+globalRegSpillType platform = \case+   VanillaReg _ -> gcWord platform+   FloatReg   _ -> cmmFloat W32+   DoubleReg  _ -> cmmFloat W64+   LongReg    _ -> cmmBits  W64+    -- TODO: improve the internal model of SIMD/vectorized registers-   -- the right design SHOULd improve handling of float and double code too.+   -- the right design SHOULD improve handling of float and double code too.    -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim-   (XmmReg _) -> cmmVec 4 (cmmBits W32)-   (YmmReg _) -> cmmVec 8 (cmmBits W32)-   (ZmmReg _) -> cmmVec 16 (cmmBits W32)+   XmmReg    _ -> cmmVec  4 (cmmBits W32)+   YmmReg    _ -> cmmVec  8 (cmmBits W32)+   ZmmReg    _ -> cmmVec 16 (cmmBits W32) -   Hp         -> gcWord platform -- The initialiser for all-                                 -- dynamically allocated closures-   _          -> bWord platform+   Hp          -> gcWord platform -- The initialiser for all+                                  -- dynamically allocated closures+   _           -> bWord platform  isArgReg :: GlobalReg -> Bool isArgReg (VanillaReg {}) = True@@ -373,3 +341,24 @@ isArgReg (YmmReg {})     = True isArgReg (ZmmReg {})     = True isArgReg _               = False++-- --------------------------------------------------------------------------++-- | Global registers used for argument passing.+--+-- See Note [realArgRegsCover] in GHC.Cmm.CallConv.+data GlobalArgRegs+  -- | General-purpose (integer) argument-passing registers.+  = GP_ARG_REGS+  -- | Scalar (integer & floating-point) argument-passing registers.+  | SCALAR_ARG_REGS+  -- | 16 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V16_ARG_REGS+  -- | 32 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V32_ARG_REGS+  -- | 64 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V64_ARG_REGS+  deriving ( Show, Eq, Ord )
compiler/GHC/Cmm/Switch.hs view
@@ -4,7 +4,7 @@      SwitchTargets,      mkSwitchTargets,      switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,-     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,+     mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough,      switchTargetsToList, eqSwitchTargetWith,       SwitchPlan(..),@@ -135,6 +135,11 @@ mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets mapSwitchTargets f (SwitchTargets signed range mbdef branches)     = SwitchTargets signed range (fmap f mbdef) (fmap f branches)++-- | Changes all labels mentioned in the SwitchTargets value+mapSwitchTargetsA :: Applicative m => (Label -> m Label) -> SwitchTargets -> m SwitchTargets+mapSwitchTargetsA f (SwitchTargets signed range mbdef branches)+    = SwitchTargets signed range <$> traverse f mbdef <*> traverse f branches  -- | Returns the list of non-default branches of the SwitchTargets value switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
compiler/GHC/Cmm/Type.hs view
@@ -3,7 +3,8 @@     , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord     , cInt     , cmmBits, cmmFloat-    , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood+    , typeWidth, setCmmTypeWidth+    , cmmEqType, cmmCompatType     , isFloatType, isGcPtrType, isBitsType     , isWordAny, isWord32, isWord64     , isFloat64, isFloat32@@ -56,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)@@ -86,25 +89,34 @@ cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 -cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool-  -- This equality is temporary; used in CmmLint-  -- but the RTS files are not yet well-typed wrt pointers-cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2)-   = c1 `weak_eq` c2 && w1==w2+-- | A weaker notion of equality of 'CmmType's than 'cmmEqType',+-- used (only) in Cmm Lint.+--+-- Why "weaker"? Because:+--+--  - we don't distinguish GcPtr vs NonGcPtr, because the the RTS files+--    are not yet well-typed wrt pointers,+--  - for vectors, we only compare the widths, because in practice things like+--    X86 xmm registers support different types of data (e.g. 4xf32, 2xf64, 2xu64 etc).+cmmCompatType :: CmmType -> CmmType -> Bool+cmmCompatType (CmmType c1 w1) (CmmType c2 w2)+   = c1 `weak_eq` c2 && w1 == w2    where      weak_eq :: CmmCat -> CmmCat -> Bool-     FloatCat         `weak_eq` FloatCat         = True-     FloatCat         `weak_eq` _other           = False-     _other           `weak_eq` FloatCat         = False-     (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2-                                                   && cat1 `weak_eq` cat2-     (VecCat {})      `weak_eq` _other           = False-     _other           `weak_eq` (VecCat {})      = False-     _word1           `weak_eq` _word2           = True        -- Ignores GcPtr+     FloatCat    `weak_eq` FloatCat    = True+     FloatCat    `weak_eq` _other      = False+     _other      `weak_eq` FloatCat    = False+     (VecCat {}) `weak_eq` (VecCat {}) = True  -- only compare overall width+     (VecCat {}) `weak_eq` _other      = False+     _other      `weak_eq` (VecCat {}) = False+     _word1      `weak_eq` _word2      = True  -- Ignores GcPtr  --- Simple operations on CmmType ----- typeWidth :: CmmType -> Width typeWidth (CmmType _ w) = w++setCmmTypeWidth :: Width -> CmmType -> CmmType+setCmmTypeWidth w (CmmType c _) = CmmType c w  cmmBits, cmmFloat :: Width -> CmmType cmmBits  = CmmType BitsCat
+ compiler/GHC/Cmm/Utils.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+--+-- Cmm utilities.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.Cmm.Utils(+        -- CmmType+        primRepCmmType, slotCmmType,+        typeCmmType, typeForeignHint, primRepForeignHint,++        -- CmmLit+        zeroCLit, mkIntCLit,+        mkWordCLit, packHalfWordsCLit,+        mkByteStringCLit, mkFileEmbedLit,+        mkDataLits, mkRODataLits,+        mkStgWordCLit,++        -- CmmExpr+        mkIntExpr, zeroExpr,+        mkLblExpr,+        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,+        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,+        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,+        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,+        cmmLoadBWord, cmmLoadGCWord,+        cmmNegate,+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+        cmmSLtWord,+        cmmNeWord, cmmEqWord,+        cmmOrWord, cmmAndWord,+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,+        cmmToWord,++        cmmMkAssign,++        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,+        currentTSOExpr, currentNurseryExpr, cccsExpr,++        -- Tagging+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,+        cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,++        -- Overlap and usage+        regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn,++        -- Liveness and bitmaps+        mkLiveness,++        -- * Operations that probably don't belong here+        modifyGraph,++        ofBlockMap, toBlockMap,+        ofBlockList, toBlockList,+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,+        foldlGraphBlocks, mapGraphNodes, mapGraphNodes1,++        -- * Ticks+        blockTicks+  ) where++import GHC.Prelude++import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) )+import GHC.Types.RepType  ( NvUnaryType, SlotTy (..), typePrimRepU )++import GHC.Platform+import GHC.Runtime.Heap.Layout+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.Unique+import GHC.Platform.Regs++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++---------------------------------------------------+--+--      CmmTypes+--+---------------------------------------------------++primRepCmmType :: Platform -> PrimRep -> CmmType+primRepCmmType platform = \case+   BoxedRep _       -> gcWord platform+   IntRep           -> bWord platform+   WordRep          -> bWord platform+   Int8Rep          -> b8+   Word8Rep         -> b8+   Int16Rep         -> b16+   Word16Rep        -> b16+   Int32Rep         -> b32+   Word32Rep        -> b32+   Int64Rep         -> b64+   Word64Rep        -> b64+   AddrRep          -> bWord platform+   FloatRep         -> f32+   DoubleRep        -> f64+   VecRep len rep   -> vec len (primElemRepCmmType rep)++slotCmmType :: Platform -> SlotTy -> CmmType+slotCmmType platform = \case+   PtrUnliftedSlot -> gcWord platform+   PtrLiftedSlot   -> gcWord platform+   WordSlot        -> bWord platform+   Word64Slot      -> b64+   FloatSlot       -> f32+   DoubleSlot      -> f64+   VecSlot l e     -> vec l (primElemRepCmmType e)++primElemRepCmmType :: PrimElemRep -> CmmType+primElemRepCmmType Int8ElemRep   = b8+primElemRepCmmType Int16ElemRep  = b16+primElemRepCmmType Int32ElemRep  = b32+primElemRepCmmType Int64ElemRep  = b64+primElemRepCmmType Word8ElemRep  = b8+primElemRepCmmType Word16ElemRep = b16+primElemRepCmmType Word32ElemRep = b32+primElemRepCmmType Word64ElemRep = b64+primElemRepCmmType FloatElemRep  = f32+primElemRepCmmType DoubleElemRep = f64++typeCmmType :: Platform -> NvUnaryType -> CmmType+typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty)++primRepForeignHint :: PrimRep -> ForeignHint+primRepForeignHint (BoxedRep _) = AddrHint+primRepForeignHint IntRep       = SignedHint+primRepForeignHint Int8Rep      = SignedHint+primRepForeignHint Int16Rep     = SignedHint+primRepForeignHint Int32Rep     = SignedHint+primRepForeignHint Int64Rep     = SignedHint+primRepForeignHint WordRep      = NoHint+primRepForeignHint Word8Rep     = NoHint+primRepForeignHint Word16Rep    = NoHint+primRepForeignHint Word32Rep    = NoHint+primRepForeignHint Word64Rep    = NoHint+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg+primRepForeignHint FloatRep     = NoHint+primRepForeignHint DoubleRep    = NoHint+primRepForeignHint (VecRep {})  = NoHint++typeForeignHint :: NvUnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRepU++---------------------------------------------------+--+--      CmmLit+--+---------------------------------------------------++-- XXX: should really be Integer, since Int doesn't necessarily cover+-- the full range of target Ints.+mkIntCLit :: Platform -> Int -> CmmLit+mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)++mkIntExpr :: Platform -> Int -> CmmExpr+mkIntExpr platform i = CmmLit $! mkIntCLit platform i++zeroCLit :: Platform -> CmmLit+zeroCLit platform = CmmInt 0 (wordWidth platform)++zeroExpr :: Platform -> CmmExpr+zeroExpr platform = CmmLit (zeroCLit platform)++mkWordCLit :: Platform -> Integer -> CmmLit+mkWordCLit platform wd = CmmInt wd (wordWidth platform)++-- | We make a top-level decl for the string, and return a label pointing to it+mkByteStringCLit+  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)+mkByteStringCLit lbl bytes+  = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes])+  where+    -- This can not happen for String literals (as there \NUL is replaced by+    -- C0 80). However, it can happen with Addr# literals.+    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString++-- | We make a top-level decl for the embedded binary file, and return a label pointing to it+mkFileEmbedLit+  :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)+mkFileEmbedLit lbl path len+  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len]))+++-- | Build a data-segment data block+mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt+mkDataLits section lbl lits+  = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits)++mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt+-- Build a read-only data block+mkRODataLits lbl lits+  = mkDataLits section lbl lits+  where+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl+            | otherwise                = Section ReadOnlyData lbl+    needsRelocation (CmmLabel _)      = True+    needsRelocation (CmmLabelOff _ _) = True+    needsRelocation _                 = False++mkStgWordCLit :: Platform -> StgWord -> CmmLit+mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)++packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit+-- Make a single word literal in which the lower_half_word is+-- at the lower address, and the upper_half_word is at the+-- higher address+-- ToDo: consider using half-word lits instead+--       but be careful: that's vulnerable when reversed+packHalfWordsCLit platform lower_half_word upper_half_word+   = case platformByteOrder platform of+       BigEndian    -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)+       LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))+    where l = fromStgHalfWord lower_half_word+          u = fromStgHalfWord upper_half_word++---------------------------------------------------+--+--      CmmExpr+--+---------------------------------------------------++mkLblExpr :: CLabel -> CmmExpr+mkLblExpr lbl = CmmLit (CmmLabel lbl)++cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr+-- assumes base and offset have the same CmmType+cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)+cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]++cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr+cmmOffset _platform e 0        = e+cmmOffset platform  e byte_off = case e of+   CmmReg reg            -> cmmRegOff reg byte_off+   CmmRegOff reg m       -> cmmRegOff reg (m+byte_off)+   CmmLit lit            -> CmmLit (cmmOffsetLit lit byte_off)+   CmmStackSlot area off -> CmmStackSlot area (off - byte_off)+  -- note stack area offsets increase towards lower addresses+   CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]+      -> let !lit_off = (byte_off1 + toInteger byte_off)+         in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)]+   _ -> let !width = cmmExprWidth platform e+        in+        CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]++-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.+cmmRegOff :: CmmReg -> Int -> CmmExpr+cmmRegOff reg 0        = CmmReg reg+cmmRegOff reg byte_off = CmmRegOff reg byte_off++cmmOffsetLit :: CmmLit -> Int -> CmmLit+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)+cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)++cmmLabelOff :: CLabel -> Int -> CmmLit+-- Smart constructor for CmmLabelOff+cmmLabelOff lbl 0        = CmmLabel lbl+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off++-- | Useful for creating an index into an array, with a statically known offset.+-- The type is the element type; used for making the multiplier+cmmIndex :: Platform+         -> Width       -- Width w+         -> CmmExpr     -- Address of vector of items of width w+         -> Int         -- Which element of the vector (0 based)+         -> CmmExpr     -- Address of i'th element+cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)++-- | Useful for creating an index into an array, with an unknown offset.+cmmIndexExpr :: Platform+             -> Width           -- Width w+             -> CmmExpr         -- Address of vector of items of width w+             -> CmmExpr         -- Which element of the vector (0 based)+             -> CmmExpr         -- Address of i'th element+cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)+cmmIndexExpr platform width base idx =+  cmmOffsetExpr platform base byte_off+  where+    idx_w = cmmExprWidth platform idx+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]++cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr+cmmLoadIndex platform ty expr ix =+    CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses++-- | Load a naturally-aligned non-pointer word.+cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr+cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned++-- | Load a naturally-aligned GC pointer.+cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr+cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned++-- The "B" variants take byte offsets+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr+cmmRegOffB = cmmRegOff++cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr+cmmOffsetB = cmmOffset++cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExprB = cmmOffsetExpr++cmmLabelOffB :: CLabel -> ByteOff -> CmmLit+cmmLabelOffB = cmmLabelOff++cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit+cmmOffsetLitB = cmmOffsetLit++-----------------------+-- The "W" variants take word offsets++cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr+-- The second arg is a *word* offset; need to change it to bytes+cmmOffsetExprW platform  e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)+cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off++cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr+cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)++cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr+cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)++cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit+cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)++cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit+cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)++cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr+cmmLoadIndexW platform base off ty =+    CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses++-----------------------+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+  cmmSLtWord,+  cmmNeWord, cmmEqWord,+  cmmOrWord, cmmAndWord,+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord+  :: Platform -> CmmExpr -> CmmExpr -> CmmExpr+cmmOrWord platform  e1 e2 = CmmMachOp (mo_wordOr platform)  [e1, e2]+cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]+cmmNeWord platform  e1 e2 = CmmMachOp (mo_wordNe platform)  [e1, e2]+cmmEqWord platform  e1 e2 = CmmMachOp (mo_wordEq platform)  [e1, e2]+cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]+cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]+cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]+cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]+cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]+cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]+cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]+cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]+cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]++cmmNegate :: Platform -> CmmExpr -> CmmExpr+cmmNegate platform = \case+   (CmmLit (CmmInt n rep))+     -> CmmLit (CmmInt (-n) rep)+   e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]++cmmToWord :: Platform -> CmmExpr -> CmmExpr+cmmToWord platform e+  | w == word  = e+  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]+  where+    w = cmmExprWidth platform e+    word = wordWidth platform++cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)+cmmMkAssign platform expr uq =+  let !ty = cmmExprType platform expr+      reg = (CmmLocal (LocalReg uq ty))+  in  (CmmAssign reg expr, CmmReg reg)+++---------------------------------------------------+--+--      Tagging+--+---------------------------------------------------++tAG_MASK :: Platform -> Int+tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1++mAX_PTR_TAG :: Platform -> Int+mAX_PTR_TAG = tAG_MASK++-- Tag bits mask+cmmTagMask, cmmPointerMask :: Platform -> CmmExpr+cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)+cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))++-- Used to untag a possibly tagged pointer+-- A static label need not be untagged+cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr+cmmUntag _ e@(CmmLit (CmmLabel _)) = e+-- Default case+cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)++-- Test if a closure pointer is untagged/tagged.+cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)+cmmIsNotTagged platform e = cmmEqWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)++-- Get constructor tag, but one based.+cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)+++-----------------------------------------------------------------------------+-- Overlap and usage++-- | Returns True if the two STG registers overlap on the specified+-- platform, in the sense that writing to one will clobber the+-- other. This includes the case that the two registers are the same+-- STG register. See Note [Overlapping global registers] for details.+regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool+regsOverlap platform (CmmGlobal (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _))+  = globalRegsOverlap platform g1 g2+regsOverlap _ reg reg' = reg == reg'++globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool+globalRegsOverlap platform g1 g2+  | Just real  <- globalRegMaybe platform g1+  , Just real' <- globalRegMaybe platform g2+  , real == real'+  = True+  | otherwise+  = g1 == g2++-- | Returns True if the STG register is used by the expression, in+-- the sense that a store to the register might affect the value of+-- the expression.+--+-- We must check for overlapping registers and not just equal+-- registers here, otherwise CmmSink may incorrectly reorder+-- assignments that conflict due to overlap. See #10521 and Note+-- [Overlapping global registers].+regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool+regUsedIn platform = regUsedIn_ where+  _   `regUsedIn_` CmmLit _         = False+  reg `regUsedIn_` CmmLoad e _ _    = reg `regUsedIn_` e+  reg `regUsedIn_` CmmReg reg'      = regsOverlap platform reg reg'+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es+  _   `regUsedIn_` CmmStackSlot _ _ = False++globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool+globalRegUsedIn platform = globalRegUsedIn_ where+  _   `globalRegUsedIn_` CmmLit _+    = False+  reg `globalRegUsedIn_` CmmLoad e _ _+    = reg `globalRegUsedIn_` e+  reg `globalRegUsedIn_` CmmReg reg'+    | CmmGlobal (GlobalRegUse reg' _) <- reg'+    = globalRegsOverlap platform reg reg'+    | otherwise+    = False+  reg `globalRegUsedIn_` CmmRegOff reg' _+    | CmmGlobal (GlobalRegUse reg' _) <- reg'+    = globalRegsOverlap platform reg reg'+    | otherwise+    = False+  reg `globalRegUsedIn_` CmmMachOp _ es+    = any (reg `globalRegUsedIn_`) es+  _   `globalRegUsedIn_` CmmStackSlot _ _+    = False++--------------------------------------------+--+--        mkLiveness+--+---------------------------------------------++mkLiveness :: Platform -> [LocalReg] -> Liveness+mkLiveness _      [] = []+mkLiveness platform (reg:regs)+  = bits ++ mkLiveness platform regs+  where+    word_size = platformWordSizeInBytes platform+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)+            `quot` word_size+            -- number of words, rounded up+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr++    is_non_ptr = not $ isGcPtrType (localRegType reg)+++-- ============================================== -+-- ============================================== -+-- ============================================== -++---------------------------------------------------+--+--      Manipulating CmmGraphs+--+---------------------------------------------------++modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}++ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}++-- | like 'toBlockList', but the entry block always comes first+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]+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++-- | 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+-- list of blocks. This matches the way OldCmm blocks were output since in+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches+-- have both true and false successors. Block ordering can make a big difference+-- in performance in the LLVM backend. Note that we rely crucially on the order+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode+-- defined in "GHC.Cmm.Node". -GBM+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]+toBlockListEntryFirstFalseFallthrough g = dfs setEmpty $ toList $ mapLookup entry_id m+  where+    m = toBlockMap g+    entry_id = g_entry g++    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]+    dfs _ [] = []+    dfs visited (block:bs)+      | id `setMember` visited = dfs visited bs+      | otherwise              = block : dfs (setInsert id visited) bs'+      where id = entryLabel block+            bs' = foldr add_id bs (successors block)+            add_id id bs = case mapLookup id m of+                              Just b  -> b : bs+                              Nothing -> bs++ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph+ofBlockList entry blocks = CmmGraph { g_entry = entry+                                    , g_graph = GMany NothingO body NothingO }+  where body = foldr addBlock emptyBody blocks++mapGraphNodes :: ( CmmNode C O -> CmmNode C O+                 , CmmNode O O -> CmmNode O O+                 , CmmNode O C -> CmmNode O C)+              -> CmmGraph -> CmmGraph+mapGraphNodes funs@(mf,_,_) g =+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $+  mapMap (mapBlock3' funs) $ toBlockMap g++mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph+mapGraphNodes1 f = modifyGraph (mapGraph f)+++foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g++-------------------------------------------------+-- Tick utilities++-- | Extract all tick annotations from the given block+blockTicks :: Block CmmNode C C -> [CmmTickish]+blockTicks b = reverse $ foldBlockNodesF goStmt b []+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]+        goStmt  (CmmTick t) ts = t:ts+        goStmt  _other      ts = ts+++-- -----------------------------------------------------------------------------+-- Access to common global registers++baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,+  spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr+baseExpr           p = CmmReg $ baseReg           p+spExpr             p = CmmReg $ spReg             p+spLimExpr          p = CmmReg $ spLimReg          p+hpExpr             p = CmmReg $ hpReg             p+hpLimExpr          p = CmmReg $ hpLimReg          p+currentTSOExpr     p = CmmReg $ currentTSOReg     p+currentNurseryExpr p = CmmReg $ currentNurseryReg p+cccsExpr           p = CmmReg $ cccsReg           p
compiler/GHC/CmmToLlvm/Config.hs view
@@ -1,34 +1,20 @@-{-# LANGUAGE CPP #-}- -- | Llvm code generator configuration module GHC.CmmToLlvm.Config   ( LlvmCgConfig(..)   , LlvmConfig(..)   , LlvmTarget(..)   , initLlvmConfig-  -- * LLVM version-  , LlvmVersion(..)-  , supportedLlvmVersionLowerBound-  , supportedLlvmVersionUpperBound-  , parseLlvmVersion-  , llvmVersionSupported-  , llvmVersionStr-  , llvmVersionList   ) where -#include "ghc-llvm-version.h"- import GHC.Prelude import GHC.Platform  import GHC.Utils.Outputable import GHC.Settings.Utils import GHC.Utils.Panic+import GHC.CmmToLlvm.Version.Type (LlvmVersion) -import Data.Char (isDigit)-import Data.List (intercalate)-import qualified Data.List.NonEmpty as NE import System.FilePath  data LlvmCgConfig = LlvmCgConfig@@ -36,6 +22,7 @@   , llvmCgContext           :: !SDocContext  -- ^ Context for LLVM code generation   , llvmCgFillUndefWithGarbage :: !Bool      -- ^ Fill undefined literals with garbage values   , llvmCgSplitSection      :: !Bool         -- ^ Split sections+  , llvmCgAvxEnabled        :: !Bool   , llvmCgBmiVersion        :: Maybe BmiVersion  -- ^ (x86) BMI instructions   , llvmCgLlvmVersion       :: Maybe LlvmVersion -- ^ version of Llvm we're using   , llvmCgDoWarn            :: !Bool         -- ^ True ==> warn unsupported Llvm version@@ -93,43 +80,3 @@   { llvmTargets :: [(String, LlvmTarget)]   , llvmPasses  :: [(Int, String)]   }--------------------------------------------------------------- LLVM version------------------------------------------------------------newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }-  deriving (Eq, Ord)--parseLlvmVersion :: String -> Maybe LlvmVersion-parseLlvmVersion =-    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)-  where-    go vs s-      | null ver_str-      = reverse vs-      | '.' : rest' <- rest-      = go (read ver_str : vs) rest'-      | otherwise-      = reverse (read ver_str : vs)-      where-        (ver_str, rest) = span isDigit s---- | The (inclusive) lower bound on the LLVM Version that is currently supported.-supportedLlvmVersionLowerBound :: LlvmVersion-supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])---- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.-supportedLlvmVersionUpperBound :: LlvmVersion-supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])--llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported v =-  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound--llvmVersionStr :: LlvmVersion -> String-llvmVersionStr = intercalate "." . map show . llvmVersionList--llvmVersionList :: LlvmVersion -> [Int]-llvmVersionList = NE.toList . llvmVersionNE
+ compiler/GHC/CmmToLlvm/Version.hs view
@@ -0,0 +1,43 @@+module GHC.CmmToLlvm.Version+  ( LlvmVersion(..)+  , supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  , parseLlvmVersion+  , llvmVersionSupported+  , llvmVersionStr+  , llvmVersionList+  )+where++import GHC.Prelude++import GHC.CmmToLlvm.Version.Type+import GHC.CmmToLlvm.Version.Bounds++import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE++parseLlvmVersion :: String -> Maybe LlvmVersion+parseLlvmVersion =+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)+  where+    go vs s+      | null ver_str+      = reverse vs+      | '.' : rest' <- rest+      = go (read ver_str : vs) rest'+      | otherwise+      = reverse (read ver_str : vs)+      where+        (ver_str, rest) = span isDigit s++llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported v =+  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound++llvmVersionStr :: LlvmVersion -> String+llvmVersionStr = intercalate "." . map show . llvmVersionList++llvmVersionList :: LlvmVersion -> [Int]+llvmVersionList = NE.toList . llvmVersionNE
+ compiler/GHC/CmmToLlvm/Version/Bounds.hs view
@@ -0,0 +1,19 @@+module GHC.CmmToLlvm.Version.Bounds+  ( supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  )+where++import GHC.Prelude ()++import GHC.CmmToLlvm.Version.Type++import qualified Data.List.NonEmpty as NE++-- | The (inclusive) lower bound on the LLVM Version that is currently supported.+supportedLlvmVersionLowerBound :: LlvmVersion+supportedLlvmVersionLowerBound = LlvmVersion (13 NE.:| [])++-- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.+supportedLlvmVersionUpperBound :: LlvmVersion+supportedLlvmVersionUpperBound = LlvmVersion (21 NE.:| [])
+ compiler/GHC/CmmToLlvm/Version/Type.hs view
@@ -0,0 +1,11 @@+module GHC.CmmToLlvm.Version.Type+  ( LlvmVersion(..)+  )+where++import GHC.Prelude++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)
compiler/GHC/Core.hs view
@@ -3,9 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoPolyKinds #-}  -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core (@@ -16,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,@@ -27,7 +26,7 @@         mkIntLit, mkIntLitWrap,         mkWordLit, mkWordLitWrap,         mkWord8Lit,-        mkWord64LitWord64, mkInt64LitInt64,+        mkWord32LitWord32, mkWord64LitWord64, mkInt64LitInt64,         mkCharLit, mkStringLit,         mkFloatLit, mkFloatLitFloat,         mkDoubleLit, mkDoubleLitDouble,@@ -35,14 +34,16 @@         mkConApp, mkConApp2, mkTyBind, mkCoBind,         varToCoreExpr, varsToCoreExprs, +        mkBinds,+         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,12 +60,12 @@         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,          -- ** Predicates and deconstruction on 'Unfolding'-        unfoldingTemplate, expandUnfolding_maybe,+        expandUnfolding_maybe,         maybeUnfoldingTemplate, otherCons,         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,         isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,-        isInlineUnfolding, isBootUnfolding,+        isInlineUnfolding, isBootUnfolding, isBetterUnfoldingThan,         hasCoreUnfolding, hasSomeUnfolding,         canUnfold, neverUnfoldGuidance, isStableSource, @@ -112,12 +113,15 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  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) @@ -155,7 +159,7 @@ --      f_1 x_2 = let f_3 x_4 = x_4 + 1 --                in f_3 (x_2 - 2) -- @---    But see Note [Shadowing] below.+--    But see Note [Shadowing in Core] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating --    type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names.@@ -292,7 +296,7 @@ -- This instance is a bit shady. It can only be used to compare AltCons for -- a single type constructor. Fortunately, it seems quite unlikely that we'll -- ever need to compare AltCons for different type constructors.--- The instance adheres to the order described in [Core case invariants]+-- The instance adheres to the order described in Note [Case expression invariants] instance Ord AltCon where   compare (DataAlt con1) (DataAlt con2) =     assert (dataConTyCon con1 == dataConTyCon con2) $@@ -312,27 +316,18 @@             | Rec [(b, (Expr b))]   deriving Data -{--Note [Shadowing]-~~~~~~~~~~~~~~~~-While various passes attempt to rename on-the-fly in a manner that-avoids "shadowing" (thereby simplifying downstream optimizations),-neither the simplifier nor any other pass GUARANTEES that shadowing is-avoided. Thus, all passes SHOULD work fine even in the presence of-arbitrary shadowing in their inputs.--In particular, scrutinee variables `x` in expressions of the form-`Case e x t` are often renamed to variables with a prefix-"wild_". These "wild" variables may appear in the body of the-case-expression, and further, may be shadowed within the body.--So the Unique in a Var is not really unique at all.  Still, it's very-useful to give a constant-time equality/ordering for Vars, and to give-a key that can be used to make sets of Vars (VarSet), or mappings from-Vars to other things (VarEnv).   Moreover, if you do want to eliminate-shadowing, you can give a new Unique to an Id without changing its-printable name, which makes debugging easier.+-- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for+-- instance.+--+--   * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive+--     bindings with all the rhs/lhs pairs in @binds@+--   * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding+--     for each rhs/lhs pairs in @binds@+mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b]+mkBinds Recursive binds = [Rec binds]+mkBinds NonRecursive binds = map (uncurry NonRec) binds +{- Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals.@@ -364,41 +359,73 @@ Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in a Coercion, (sym c). +Note [Shadowing in Core]+~~~~~~~~~~~~~~~~~~~~~~~~+You might wonder if there is an invariant that a Core expression has no+"shadowing".  For example, is this illegal?+     \x. \x. blah     -- x is shadowed+Answer; no!  Core does /not/ have a no-shadowing invariant.++Neither the simplifier nor any other pass GUARANTEES that shadowing is+avoided. Thus, all passes SHOULD work fine even in the presence of+arbitrary shadowing in their inputs.++So the Unique in a Var is not really unique at all.  Still, it's very+useful to give a constant-time equality/ordering for Vars, and to give+a key that can be used to make sets of Vars (VarSet), or mappings from+Vars to other things (VarEnv).   Moreover, if you do want to eliminate+shadowing, you can give a new Unique to an Id without changing its+printable name, which makes debugging easier.++It would in many ways be easier to have a no-shadowing invariant.  And the+Simplifier does its best to clone variables that are shadowed.  But it is+extremely difficult to GUARANTEE it:++* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques+  that are locally-unique (enough for the purpose) but not globally unique.+  It is convenient not to have to plumb a unique supply to these functions.++* It is very difficult for the Simplifier to gurantee a no-shadowing result.+  See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration.++* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE++* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr+ Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: -    The right hand sides of all-      /top-level/ or /recursive/-    bindings must be of lifted type--    There is one exception to this rule, top-level @let@s are-    allowed to bind primitive string literals: see-    Note [Core top-level string literals].+  The right hand sides of all /top-level/ or /recursive/+  bindings must be of lifted type  See "Type#type_classification" in GHC.Core.Type-for the meaning of "lifted" vs. "unlifted").--For the non-top-level, non-recursive case see Note [Core let-can-float invariant].+for the meaning of "lifted" vs. "unlifted". -Note [Compilation plan for top-level string literals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here is a summary on how top-level string literals are handled by various-parts of the compilation pipeline.+For the non-top-level, non-recursive case see+Note [Core let-can-float invariant]. -* In the source language, there is no way to bind a primitive string literal-  at the top level.+At top level, however, there are two exceptions to this rule: -* In Core, we have a special rule that permits top-level Addr# bindings. See-  Note [Core top-level string literals]. Core-to-core passes may introduce-  new top-level string literals.+(TL1) A top-level binding is allowed to bind primitive string literal,+      (which is unlifted).  See Note [Core top-level string literals]. -* In STG, top-level string literals are explicitly represented in the syntax-  tree.+(TL2) In Core, we generate a top-level binding for every non-newtype data+constructor worker or wrapper+      e.g.   data T = MkT Int+      we generate+             MkT :: Int -> T+             MkT = \x. MkT x+      (This binding looks recursive, but isn't; it defines a top-level, curried+      function whose body just allocates and returns the data constructor.) -* A top-level string literal may end up exported from a module. In this case,-  in the object file, the content of the exported literal is given a label with-  the _bytes suffix.+      But if (a) the data constructor is nullary and (b) the data type is unlifted,+      this binding is unlifted.+      e.g.   data S :: UnliftedType where { S1 :: S, S2 :: S -> S }+      we generate+             S1 :: S   -- A top-level unlifted binding+             S1 = S1+      We allow this top-level unlifted binding to exist.  Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -428,9 +455,6 @@  The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make. -For discussion of some implications of the let-can-float invariant primops see-Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.- Historical Note [The let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules@@ -452,7 +476,7 @@ Note [Core top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted,-we allow binding primitive string literals (of type Addr#) of type Addr# at the+we allow binding primitive string literals (of type Addr#) at the top level. This allows us to share string literals earlier in the pipeline and crucially allows other optimizations in the Core2Core pipeline to fire. Consider,@@ -496,6 +520,45 @@   in the object file, the content of the exported literal is given a label with   the _bytes suffix. +Note [NON-BOTTOM-DICTS invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is a global invariant (not checkable by Lint) that++     every non-newtype dictionary-typed expression is non-bottom.++These conditions are captured by GHC.Core.Type.isTerminatingType.++How are we so sure about this?  Dictionaries are built by GHC in only two ways:++* A dictionary function (DFun), arising from an instance declaration.+  DFuns do no computation: they always return a data constructor immediately.+  See DFunUnfolding in GHC.Core.  So the result of a call to a DFun is always+  non-bottom.++  Exception: newtype dictionaries.++  Plus: see the Very Nasty Wrinkle in Note [Speculative evaluation]+  in GHC.CoreToStg.Prep++* A superclass selection from some other dictionary. This is harder to guarantee:+  see Note [Recursive superclasses] and Note [Solving superclass constraints]+  in GHC.Tc.TyCl.Instance.++A bad Core-to-Core pass could invalidate this reasoning, but that's too bad.+It's still an invariant of Core programs generated by GHC from Haskell, and+Core-to-Core passes maintain it.++Why is it useful to know that dictionaries are non-bottom?++1. It justifies the use of `-XDictsStrict`;+   see `GHC.Core.Types.Demand.strictifyDictDmd`++2. It means that (eq_sel d) is ok-for-speculation and thus+     case (eq_sel d) of _ -> blah+   can be discarded by the Simplifier.  See these Notes:+   Note [exprOkForSpeculation and type classes] in GHC.Core.Utils+   Note[Speculative evaluation] in GHC.CoreToStg.Prep+ Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions are one of the more complicated elements of the Core@@ -584,18 +647,14 @@       case (df @Int) of (co :: a ~# b) -> blah   Which is very exotic, and I think never encountered; but see   Note [Equality superclasses in quantified constraints]-  in GHC.Tc.Solver.Canonical--Note [Core case invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [Case expression invariants]+  in GHC.Tc.Solver.Dict  Note [Representation polymorphism invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC allows us to abstract over calling conventions using **representation polymorphism**. For example, we have: -  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). a -> b -> b+  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). (a -> b) -> a -> b  In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`, where the type variable `r :: RuntimeRep` abstracts over the runtime representation@@ -610,13 +669,6 @@       (except for join points: See Note [Invariants on join points])   I2. The type of a function argument must have a fixed runtime representation. -On top of these two invariants, GHC's internal eta-expansion mechanism also requires:--  I3. In any partial application `f e_1 .. e_n`, where `f` is `hasNoBinding`,-      it must be the case that the application can be eta-expanded to match-      the arity of `f`.-      See Note [checkCanEtaExpand] in GHC.Core.Lint for more details.- Example of I1:    \(r::RuntimeRep). \(a::TYPE r). \(x::a). e@@ -631,38 +683,32 @@     This contravenes I2: we are applying the function `f` to a value     with an unknown runtime representation. -Examples of I3:+Note that these two invariants require us to check other types than just the+types of bound variables and types of function arguments, due to transformations+that GHC performs. For example, the definition -  myUnsafeCoerce# :: forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b-  myUnsafeCoerce# = unsafeCoerce#+  myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b+  myCoerce = coerce -    This contravenes I3: we are instantiating `unsafeCoerce#` without any-    value arguments, and with a remaining argument type, `a`, which does not-    have a fixed runtime representation.-    But `unsafeCorce#` has no binding (see Note [Wiring in unsafeCoerce#]-    in GHC.HsToCore).  So before code-generation we must saturate it-    by eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate), thus-       myUnsafeCoerce# = \x. unsafeCoerce# x-    But we can't do that because now the \x binding would violate I1.+is invalid, because `coerce` has no binding (see GHC.Types.Id.Make.coerceId).+So, before code-generation, GHC saturates the RHS of 'myCoerce' by performing+an eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate): -  bar :: forall (a :: TYPE) r (b :: TYPE r). a -> b-  bar = unsafeCoerce#+  myCoerce = \ (x :: TYPE r) -> coerce x -    OK: eta expand to `\ (x :: Type) -> unsafeCoerce# x`,-    and `x` has a fixed RuntimeRep.+However, this transformation would be invalid, because now the binding of x+in the lambda abstraction would violate I1. +See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete+and Note [Linting representation-polymorphic builtins] in GHC.Core.Lint for+more details.+ Note that we currently require something slightly stronger than a fixed runtime representation: we check whether bound variables and function arguments have a /fixed RuntimeRep/ in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete for an overview of how we enforce these invariants in the typechecker. -Note [Core let goal]-~~~~~~~~~~~~~~~~~~~~-* The simplifier tries to ensure that if the RHS of a let is a constructor-  application, its arguments are trivial, so that the constructor can be-  inlined vigorously.- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The alternatives of a case expression should be exhaustive.  But@@ -707,10 +753,14 @@   its scrutinee is (see GHC.Core.Utils.exprIsTrivial).  This is actually   important; see Note [Empty case is trivial] in GHC.Core.Utils -* An empty case is replaced by its scrutinee during the CoreToStg-  conversion; remember STG is un-typed, so there is no need for-  the empty case to do the type conversion.+* We lower empty cases in GHC.CoreToStg.coreToStgExpr to an eval on the+  scrutinee. +Historical Note: We used to lower EmptyCase in CorePrep by way of an+unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when+we were beginning to eta expand in arguments, plus required to mess with+heterogenously-kinded coercions. It's simpler to stick to it just a bit longer.+ Note [Join points] ~~~~~~~~~~~~~~~~~~ In Core, a *join point* is a specially tagged function whose only occurrences@@ -984,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@@ -1052,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@@ -1072,6 +1187,10 @@                 n <- get bh                 return $ NotOrphan n +instance NFData IsOrphan where+  rnf IsOrphan = ()+  rnf (NotOrphan n) = rnf n+ {- Note [Orphans] ~~~~~~~~~~~~~~@@ -1107,7 +1226,7 @@  Orphan-hood is computed   * For class instances:-    when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance+    when we make a ClsInst in GHC.Core.InstEnv.mkLocalClsInst       (because it is needed during instance lookup)     See Note [When exactly is an instance decl an orphan?]         in GHC.Core.InstEnv@@ -1222,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 @@ -1242,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@@ -1468,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@@ -1511,7 +1627,6 @@ -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' isConLikeUnfolding :: Unfolding -> Bool-isConLikeUnfolding (OtherCon _)                         = True isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache isConLikeUnfolding _                                    = False @@ -1596,6 +1711,33 @@ canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) canUnfold _                                   = False +isBetterUnfoldingThan :: Unfolding -> Unfolding -> Bool+-- See Note [Better unfolding]+isBetterUnfoldingThan NoUnfolding   _ = False+isBetterUnfoldingThan BootUnfolding _ = False++isBetterUnfoldingThan (CoreUnfolding {uf_cache = uc1}) unf2+  = case unf2 of+      CoreUnfolding {uf_cache = uc2} -> uf_is_value uc1 && not (uf_is_value uc2)+      OtherCon _                     -> uf_is_value uc1+      _                              -> True+         -- Default case: CoreUnfolding better than NoUnfolding etc+         -- Better than DFunUnfolding? I don't care.++isBetterUnfoldingThan (DFunUnfolding {}) unf2+  | DFunUnfolding {} <- unf2 = False+  | otherwise                = True++isBetterUnfoldingThan (OtherCon cs1) unf2+  = case unf2 of+      CoreUnfolding {uf_cache = uc}             -- If unf1 is OtherCon and unf2 is+                       -> not (uf_is_value uc)  -- just a thunk, unf1 is better++      OtherCon cs2     -> not (null cs1) && null cs2  -- A bit crude+      DFunUnfolding {} -> False+      NoUnfolding      -> True+      BootUnfolding    -> True+ {- Note [Fragile unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An unfolding is "fragile" if it mentions free variables (and hence would@@ -1610,6 +1752,20 @@  We consider even a StableUnfolding as fragile, because it needs substitution. +Note [Better unfolding]+~~~~~~~~~~~~~~~~~~~~~~~+(unf1 `isBetterUnfoldingThan` unf2) is used when we have+    let x = <rhs> in   -- unf2+    let $j y = ...x...+    in case x of+          K a -> ...$j v....++At the /call site/ of $j, `x` has a better unfolding than it does at the+/defnition site/ of $j; so we are keener to inline $j.  See+Note [Inlining join points] in GHC.Core.Opt.Simplify.Inline for discussion.++The notion of "better" is encapsulated here.+ Note [Stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~ When you say@@ -1856,6 +2012,9 @@ mkWord8Lit :: Integer -> Expr b mkWord8Lit    w = Lit (mkLitWord8 w) +mkWord32LitWord32 :: Word32 -> Expr b+mkWord32LitWord32 w = Lit (mkLitWord32 (toInteger w))+ mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) @@ -1995,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] @@ -2071,6 +2235,17 @@     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 -- being applied. Looking through casts and ticks to find it. collectFunSimple :: Expr b -> Expr b collectFunSimple expr@@ -2101,7 +2276,7 @@ stripNArgs n (App f _) = stripNArgs (n - 1) f stripNArgs _ _ = Nothing --- | Like @collectArgs@, but also collects looks through floatable+-- | Like @collectArgs@, but also looks through floatable -- ticks if it means that we can find more arguments. collectArgsTicks :: (CoreTickish -> Bool) -> Expr b                  -> (Expr b, [Arg b], [CoreTickish])
compiler/GHC/Core.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoPolyKinds #-} module GHC.Core where import {-# SOURCE #-} GHC.Types.Var
compiler/GHC/Core/Class.hs view
@@ -8,7 +8,7 @@ module GHC.Core.Class (         Class,         ClassOpItem,-        ClassATItem(..), ATValidityInfo(..),+        ClassATItem(..), TyFamEqnValidityInfo(..),         ClassMinimalDef,         DefMethInfo, pprDefMethInfo, @@ -17,8 +17,13 @@         mkClass, mkAbstractClass, classTyVars, classArity,         classKey, className, classATs, classATItems, classTyCon, classMethods,         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,-        classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,-        isAbstractClass,+        classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef,+        classHasFds,++        -- Predicates+        -- NB: other isXXlass predicates are defined in GHC.Core.Predicate+        --     to avoid module loops+        isAbstractClass     ) where  import GHC.Prelude@@ -26,16 +31,17 @@ 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 import GHC.Types.Unique import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain 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 @@ -76,10 +82,6 @@ -- >  class C a b c | a b -> c, a c -> b where... -- --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]------  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'',---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type FunDep a = ([a],[a])  type ClassOpItem = (Id, DefMethInfo)@@ -96,22 +98,46 @@  data ClassATItem   = ATI TyCon         -- See Note [Associated type tyvar names]-        (Maybe (Type, ATValidityInfo))-                      -- Default associated type (if any) from this template-                      -- Note [Associated type defaults]+        (Maybe (Type, TyFamEqnValidityInfo))+          -- ^ Default associated type (if any) from this template.+          --+          -- As per Note [Associated type defaults], the Type has been renamed+          -- to use the class tyvars, while the 'TyFamEqnValidityInfo' uses+          -- the original user-written type variables. --- | Information about an associated type family default implementation. This--- is used solely for validity checking.+-- | Information about a type family equation, used for validity checking+-- of closed type family equations and associated type family default equations.+--+-- This type exists to delay validity-checking after typechecking type declaration+-- groups, to avoid cyclic evaluation inside the typechecking knot.+-- -- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".-data ATValidityInfo-  = NoATVI               -- Used for associated type families that are imported-                         -- from another module, for which we don't need to-                         -- perform any validity checking.+data TyFamEqnValidityInfo+  -- | Used for equations which don't need any validity checking,+  -- for example equations imported from another module.+  = NoVI -  | ATVI SrcSpan [Type]  -- Used for locally defined associated type families.-                         -- The [Type] are the LHS patterns.+  -- | Information necessary for validity checking of a type family equation.+  | VI+    { vi_loc :: SrcSpan+    , vi_qtvs :: [TcTyVar]+      -- ^ LHS quantified type variables+    , vi_non_user_tvs :: TyVarSet+      -- ^ non-user-written type variables (for error message reporting)+      --+      -- Example: with -XPolyKinds, typechecking @type instance forall a. F = ()@+      -- introduces the kind variable @k@ for the kind of @a@. See #23734.+    , vi_pats :: [Type]+      -- ^ LHS patterns+    , vi_rhs :: Type+      -- ^ RHS of the equation+      --+      -- NB: for associated type family default declarations, this is the RHS+      -- *before* applying the substitution from+      -- 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@@ -166,10 +192,15 @@  * HOWEVER, in the internal ClassATItem we rename the RHS to match the    tyConTyVars of the family TyCon.  So in the example above we'd get    a ClassATItem of-        ATI F ((x,a) -> b)-   So the tyConTyVars of the family TyCon bind the free vars of-   the default Type rhs +        ATI F (Just ((x,a) -> b, validity_info)++   That is, the type stored in the first component of the pair has been+   renamed to use the class type variables. On the other hand, the+   TyFamEqnValidityInfo, used for validity checking of the type family equation+   (considered as a free-standing equation) uses the original types, e.g.+   involving the type variables 'p', 'q', 'r'.+ The @mkClass@ function fills in the indirect superclasses.  The SrcSpan is for the entire original declaration.@@ -294,6 +325,9 @@ classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})   = theta_stuff classSCTheta _ = []++classHasSCs :: Class -> Bool+classHasSCs cls = not (null (classSCTheta cls))  classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) classTvsFds c = (classTyVars c, classFunDeps c)
compiler/GHC/Core/Coercion.hs view
@@ -24,2759 +24,2784 @@          -- ** Functions over coercions         coVarRType, coVarLType, coVarTypes,-        coVarKind, coVarKindsTypesRole, coVarRole,-        coercionType, mkCoercionType,-        coercionKind, coercionLKind, coercionRKind,coercionKinds,-        coercionRole, coercionKindRole,--        -- ** Constructing coercions-        mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo,-        mkCoVarCo, mkCoVarCos,-        mkAxInstCo, mkUnbranchedAxInstCo,-        mkAxInstRHS, mkUnbranchedAxInstRHS,-        mkAxInstLHS, mkUnbranchedAxInstLHS,-        mkPiCo, mkPiCos, mkCoCast,-        mkSymCo, mkTransCo,-        mkSelCo, getNthFun, getNthFromType, mkLRCo,-        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,-        mkFunCo1, mkFunCo2, mkFunCoNoFTF, mkFunResCo,-        mkNakedFunCo1, mkNakedFunCo2,-        mkForAllCo, mkForAllCos, mkHomoForAllCos,-        mkPhantomCo,-        mkHoleCo, mkUnivCo, mkSubCo,-        mkAxiomInstCo, mkProofIrrelCo,-        downgradeRole, mkAxiomRuleCo,-        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,-        mkKindCo,-        castCoercionKind, castCoercionKind1, castCoercionKind2,--        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,--        -- ** Decomposition-        instNewTyCon_maybe,--        NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper,-        topNormaliseNewType_maybe, topNormaliseTypeX,--        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,-        splitAppCo_maybe,-        splitFunCo_maybe,-        splitForAllCo_maybe,-        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,--        tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,-        tyConRoleListX, tyConRoleListRepresentational, funRole,-        pickLR,--        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,-        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,-        mkCoherenceRightMCo,--        coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,-        mkHomoForAllMCo, mkFunResMCo, mkPiMCos,-        isReflMCo, checkReflexiveMCo,--        -- ** Coercion variables-        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,--        -- ** Free variables-        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,-        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,-        coercionSize, anyFreeVarsOfCo,--        -- ** Substitution-        CvSubstEnv, emptyCvSubstEnv,-        lookupCoVar,-        substCo, substCos, substCoVar, substCoVars, substCoWith,-        substCoVarBndr,-        extendTvSubstAndInScope, getCvSubstEnv,--        -- ** Lifting-        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,-        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,-        liftCoSubstVarBndrUsing, isMappedByLC,--        mkSubstLiftingContext, zapLiftingContext,-        substForAllCoBndrUsingLC, lcSubst, lcInScopeSet,--        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,-        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,--        -- ** Comparison-        eqCoercion, eqCoercionX,--        -- ** Forcing evaluation of coercions-        seqCo,--        -- * Pretty-printing-        pprCo, pprParendCo,-        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,-        pprCoAxBranchUser, tidyCoAxBndrsForUser,-        etaExpandCoAxBranch,--        -- * Tidying-        tidyCo, tidyCos,--        -- * Other-        promoteCoercion, buildCoercion,--        multToCo, mkRuntimeRepCo,--        hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy,--        setCoHoleType-       ) where--import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)--import GHC.Prelude--import GHC.Iface.Type-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.FVs-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.Tidy-import GHC.Core.TyCo.Compare( eqType, eqTypeX )-import GHC.Core.Type-import GHC.Core.TyCon-import GHC.Core.TyCon.RecWalk-import GHC.Core.Coercion.Axiom-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name hiding ( varName )-import GHC.Types.Basic-import GHC.Types.Unique-import GHC.Data.FastString-import GHC.Data.Pair-import GHC.Types.SrcLoc-import GHC.Builtin.Names-import GHC.Builtin.Types.Prim-import GHC.Data.List.SetOps-import GHC.Data.Maybe-import GHC.Types.Unique.FM-import GHC.Data.List.Infinite (Infinite (..))-import qualified GHC.Data.List.Infinite as Inf--import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain--import Control.Monad (foldM, zipWithM)-import Data.Function ( on )-import Data.Char( isDigit )-import qualified Data.Monoid as Monoid--{--%************************************************************************-%*                                                                      *-     -- The coercion arguments always *precisely* saturate-     -- arity of (that branch of) the CoAxiom.  If there are-     -- any left over, we use AppCo.  See-     -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep--\subsection{Coercion variables}-%*                                                                      *-%************************************************************************--}--coVarName :: CoVar -> Name-coVarName = varName--setCoVarUnique :: CoVar -> Unique -> CoVar-setCoVarUnique = setVarUnique--setCoVarName :: CoVar -> Name -> CoVar-setCoVarName   = setVarName--{--%************************************************************************-%*                                                                      *-                   Pretty-printing CoAxioms-%*                                                                      *-%************************************************************************--Defined here to avoid module loops. CoAxiom is loaded very early on.---}--etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)--- Return the (tvs,lhs,rhs) after eta-expanding,--- to the way in which the axiom was originally written--- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom-etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs-                                , cab_eta_tvs = eta_tvs-                                , cab_lhs = lhs-                                , cab_rhs = rhs })-  -- ToDo: what about eta_cvs?-  = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys)- where-    eta_tys = mkTyVarTys eta_tvs--pprCoAxiom :: CoAxiom br -> SDoc--- Used in debug-printing only-pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })-  = hang (text "axiom" <+> ppr ax)-       2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))--pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc--- Used when printing injectivity errors (FamInst.reportInjectivityErrors)--- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch)--- This happens in error messages: don't print the RHS of a data---   family axiom, which is meaningless to a user-pprCoAxBranchUser tc br-  | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br-  | otherwise            = pprCoAxBranch    tc br--pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc--- Print the family-instance equation when reporting---   a conflict between equations (FamInst.conflictInstErr)--- For type families the RHS is important; for data families not so.---   Indeed for data families the RHS is a mysterious internal---   type constructor, so we suppress it (#14179)--- See FamInstEnv Note [Family instance overlap conflicts]-pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs-  where-    pp_rhs _ _ = empty--pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc-pprCoAxBranch = ppr_co_ax_branch ppr_rhs-  where-    ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs--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')-         -- 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-           , ppUnless (null incomps) $ whenPprDebug $-             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ]-    ]-  where-    incomps = coAxBranchIncomps branch-    loc = coAxBranchSpan branch-    pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)-           | otherwise         = text "in" <+> ppr loc--    -- Eta-expand LHS and RHS types, because sometimes data family-    -- instances are eta-reduced.-    -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.-    (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch--    pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)-                             (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs)--    (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs--tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])--- Tidy wildcards "_1", "_2" to "_", and do not return them--- in the list of binders to be printed--- This is so that in error messages we see---     forall a. F _ [a] _ = ...--- rather than---     forall a _1 _2. F _1 [a] _2 = ...------ This is a rather disgusting function--- See Note [Wildcard names] in GHC.Tc.Gen.HsType-tidyCoAxBndrsForUser init_env tcvs-  = (tidy_env, reverse tidy_bndrs)-  where-    (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs--    tidy_one (env@(occ_env, subst), rev_bndrs') bndr-      | is_wildcard bndr = (env_wild, rev_bndrs')-      | otherwise        = (env',     bndr' : rev_bndrs')-      where-        (env', bndr') = tidyVarBndr env bndr-        env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)-        wild_bndr = setVarName bndr $-                    tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_"))-                    -- Tidy the binder to "_"--    is_wildcard :: Var -> Bool-    is_wildcard tv = case occNameString (getOccName tv) of-                       ('_' : rest) -> all isDigit rest-                       _            -> False---{- *********************************************************************-*                                                                      *-              MCoercion-*                                                                      *-********************************************************************* -}--coToMCo :: Coercion -> MCoercion--- Convert a coercion to a MCoercion,--- It's not clear whether or not isReflexiveCo would be better here---    See #19815 for a bit of data and discussion on this point-coToMCo co | isReflCo co = MRefl-           | otherwise   = MCo co--checkReflexiveMCo :: MCoercion -> MCoercion-checkReflexiveMCo MRefl                       = MRefl-checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl-                           | otherwise        = MCo co---- | Tests if this MCoercion is obviously generalized reflexive--- Guaranteed to work very quickly.-isGReflMCo :: MCoercion -> Bool-isGReflMCo MRefl = True-isGReflMCo (MCo co) | isGReflCo co = True-isGReflMCo _ = False---- | Make a generalized reflexive coercion-mkGReflCo :: Role -> Type -> MCoercionN -> Coercion-mkGReflCo r ty mco-  | isGReflMCo mco = if r == Nominal then Refl ty-                     else GRefl r ty MRefl-  | otherwise    = GRefl r ty mco---- | Compose two MCoercions via transitivity-mkTransMCo :: MCoercion -> MCoercion -> MCoercion-mkTransMCo MRefl     co2       = co2-mkTransMCo co1       MRefl     = co1-mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)--mkTransMCoL :: MCoercion -> Coercion -> MCoercion-mkTransMCoL MRefl     co2 = coToMCo co2-mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2)--mkTransMCoR :: Coercion -> MCoercion -> MCoercion-mkTransMCoR co1 MRefl     = coToMCo co1-mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2)---- | Get the reverse of an 'MCoercion'-mkSymMCo :: MCoercion -> MCoercion-mkSymMCo MRefl    = MRefl-mkSymMCo (MCo co) = MCo (mkSymCo co)---- | Cast a type by an 'MCoercion'-mkCastTyMCo :: Type -> MCoercion -> Type-mkCastTyMCo ty MRefl    = ty-mkCastTyMCo ty (MCo co) = ty `mkCastTy` co--mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion-mkHomoForAllMCo _   MRefl    = MRefl-mkHomoForAllMCo tcv (MCo co) = MCo (mkHomoForAllCos [tcv] co)--mkPiMCos :: [Var] -> MCoercion -> MCoercion-mkPiMCos _ MRefl = MRefl-mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)--mkFunResMCo :: Id -> MCoercionR -> MCoercionR-mkFunResMCo _      MRefl    = MRefl-mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co)--mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion-mkGReflLeftMCo r ty MRefl    = mkReflCo r ty-mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co--mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion-mkGReflRightMCo r ty MRefl    = mkReflCo r ty-mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co---- | Like 'mkCoherenceRightCo', but with an 'MCoercion'-mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion-mkCoherenceRightMCo _ _  MRefl    co2 = co2-mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2--isReflMCo :: MCoercion -> Bool-isReflMCo MRefl = True-isReflMCo _     = False--{--%************************************************************************-%*                                                                      *-        Destructing coercions-%*                                                                      *-%************************************************************************--}---- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into--- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:------ > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]-decomposeCo :: Arity -> Coercion-            -> Infinite Role  -- the roles of the output coercions-            -> [Coercion]-decomposeCo arity co rs-  = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]-     -- Remember, SelTyCon is zero-indexed--decomposeFunCo :: HasDebugCallStack-               => Coercion  -- Input coercion-               -> (CoercionN, Coercion, Coercion)--- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2)--- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2)--- actually cow will be a Phantom coercion if the input is a Phantom coercion--decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 })-  = (w, co1, co2)-   -- Short-circuits the calls to mkSelCo--decomposeFunCo co-  = assertPpr all_ok (ppr co) $-    ( mkSelCo (SelFun SelMult) co-    , mkSelCo (SelFun SelArg) co-    , mkSelCo (SelFun SelRes) co )-  where-    Pair s1t1 s2t2 = coercionKind co-    all_ok = isFunTy s1t1 && isFunTy s2t2--{- Note [Pushing a coercion into a pi-type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have this:-    (f |> co) t1 .. tn-Then we want to push the coercion into the arguments, so as to make-progress. For example of why you might want to do so, see Note-[Respecting definitional equality] in GHC.Core.TyCo.Rep.--This is done by decomposePiCos.  Specifically, if-    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)-then-    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn--Notes:--* k can be smaller than n! That is decomposePiCos can return *fewer*-  coercions than there are arguments (ie k < n), if the kind provided-  doesn't have enough binders.--* If there is a type error, we might see-       (f |> co) t1-  where co :: (forall a. ty) ~ (ty1 -> ty2)-  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.-  So decomposePiCos carefully tests both sides of the coercion to check-  they are both foralls or both arrows.  Not doing this caused #15343.--}--decomposePiCos :: HasDebugCallStack-               => CoercionN -> Pair Type  -- Coercion and its kind-               -> [Type]-               -> ([CoercionN], CoercionN)--- See Note [Pushing a coercion into a pi-type]-decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args-  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args-  where-    orig_subst = mkEmptySubst $ mkInScopeSet $-                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co--    go :: [CoercionN]      -- accumulator for argument coercions, reversed-       -> (Subst,Kind)  -- Lhs kind of coercion-       -> CoercionN        -- coercion originally applied to the function-       -> (Subst,Kind)  -- Rhs kind of coercion-       -> [Type]           -- Arguments to that function-       -> ([CoercionN], Coercion)-    -- Invariant:  co :: subst1(k1) ~ subst2(k2)--    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)-      | Just (a, t1) <- splitForAllTyCoVar_maybe k1-      , Just (b, t2) <- splitForAllTyCoVar_maybe k2-        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)-        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)-        --           a :: s1-        --           b :: s2-        --          ty :: s2-        -- need arg_co :: s2 ~ s1-        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]-      = let arg_co  = mkSelCo SelForAll (mkSymCo co)-            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)-            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)-            subst2' = extendTCvSubst subst2 b ty-        in-        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys--      | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1-      , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2-      , af1 == af2  -- Same sort of arrow-        -- know     co :: (s1 -> t1) ~ (s2 -> t2)-        --    function :: s1 -> t1-        --          ty :: s2-        -- need arg_co :: s2 ~ s1-        --      res_co :: t1 ~ t2-      = let (_, sym_arg_co, res_co) = decomposeFunCo co-            -- It should be fine to ignore the multiplicity bit-            -- of the coercion for a Nominal coercion.-            arg_co = mkSymCo sym_arg_co-        in-        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys--      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)-      = go acc_arg_cos (zapSubst subst1, substTy subst1 k1)-                       co-                       (zapSubst subst2, substTy subst1 k2)-                       (ty:tys)--      -- tys might not be empty, if the left-hand type of the original coercion-      -- didn't have enough binders-    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)---- | Extract a covar, if possible. This check is dirty. Be ashamed--- of yourself. (It's dirty because it cares about the structure of--- a coercion, which is morally reprehensible.)-getCoVar_maybe :: Coercion -> Maybe CoVar-getCoVar_maybe (CoVarCo cv) = Just cv-getCoVar_maybe _            = Nothing--multToCo :: Mult -> Coercion-multToCo r = mkNomReflCo r---- first result has role equal to input; third result is Nominal-splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)--- ^ Attempt to take a coercion application apart.-splitAppCo_maybe (AppCo co arg) = Just (co, arg)-splitAppCo_maybe (TyConAppCo r tc args)-  | args `lengthExceeds` tyConArity tc-  , Just (args', arg') <- snocView args-  = Just ( mkTyConAppCo r tc args', arg' )--  | not (tyConMustBeSaturated tc)-    -- Never create unsaturated type family apps!-  , Just (args', arg') <- snocView args-  , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg'-  = Just ( mkTyConAppCo r tc args', arg'' )-       -- Use mkTyConAppCo to preserve the invariant-       --  that identity coercions are always represented by Refl--splitAppCo_maybe co-  | Just (ty, r) <- isReflCo_maybe co-  , Just (ty1, ty2) <- splitAppTy_maybe ty-  = Just (mkReflCo r ty1, mkNomReflCo ty2)-splitAppCo_maybe _ = Nothing---- Only used in specialise/Rules-splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)-splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res)-splitFunCo_maybe _ = Nothing--splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)-splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)-splitForAllCo_maybe _                     = Nothing---- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder-splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)-splitForAllCo_ty_maybe (ForAllCo tv k_co co)-  | isTyVar tv = Just (tv, k_co, co)-splitForAllCo_ty_maybe _ = Nothing---- | Like 'splitForAllCo_maybe', but only returns Just for covar binder-splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)-splitForAllCo_co_maybe (ForAllCo cv k_co co)-  | isCoVar cv = Just (cv, k_co, co)-splitForAllCo_co_maybe _ = Nothing------------------------------------------------------------ and some coercion kind stuff--coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type-coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1-coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2--coVarTypes :: HasDebugCallStack => CoVar -> Pair Type-coVarTypes cv-  | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv-  = Pair ty1 ty2--coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)-coVarKindsTypesRole cv- | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)- = (k1, k2, ty1, ty2, eqTyConRole tc)- | otherwise- = pprPanic "coVarKindsTypesRole, non coercion variable"-            (ppr cv $$ ppr (varType cv))--coVarKind :: CoVar -> Type-coVarKind cv-  = assert (isCoVar cv )-    varType cv--coVarRole :: CoVar -> Role-coVarRole cv-  = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of-                   Just tc0 -> tc0-                   Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv))--eqTyConRole :: TyCon -> Role--- Given (~#) or (~R#) return the Nominal or Representational respectively-eqTyConRole tc-  | tc `hasKey` eqPrimTyConKey-  = Nominal-  | tc `hasKey` eqReprPrimTyConKey-  = Representational-  | otherwise-  = pprPanic "eqTyConRole: unknown tycon" (ppr tc)---- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`--- produce a coercion `rep_co :: r1 ~ r2`--- But actually it is possible that---     co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2)--- or  co :: (t1 :: TYPE r1)       ~ (t2 :: CONSTRAINT r2)--- or  co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2)--- See Note [mkRuntimeRepCo]-mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion-mkRuntimeRepCo co-  = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $-    mkSelCo (SelTyCon 0 Nominal) kind_co-  where-    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2-    Pair k1 k2 = coercionKind kind_co--{- Note [mkRuntimeRepCo]-~~~~~~~~~~~~~~~~~~~~~~~~-Given-   class C a where { op :: Maybe a }-we will get an axiom-   axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2)-(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.)--Then we may call mkRuntimeRepCo on (axC ty), and that will return-   mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2--So mkSelCo needs to be happy with decomposing a coercion of kind-   CONSTRAINT r1 ~ TYPE r2--Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call`-in `mkSelCo`. See #23018 for a concrete example.  (In this context it's-important that TYPE and CONSTRAINT have the same arity and kind, not-merely that they are not-apart; otherwise SelCo would not make sense.)--}--isReflCoVar_maybe :: Var -> Maybe Coercion--- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)--- Works on all kinds of Vars, not just CoVars-isReflCoVar_maybe cv-  | isCoVar cv-  , Pair ty1 ty2 <- coVarTypes cv-  , ty1 `eqType` ty2-  = Just (mkReflCo (coVarRole cv) ty1)-  | otherwise-  = Nothing---- | Tests if this coercion is obviously a generalized reflexive coercion.--- Guaranteed to work very quickly.-isGReflCo :: Coercion -> Bool-isGReflCo (GRefl{}) = True-isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl-isGReflCo _         = False---- | Tests if this coercion is obviously reflexive. Guaranteed to work--- very quickly. Sometimes a coercion can be reflexive, but not obviously--- so. c.f. 'isReflexiveCo'-isReflCo :: Coercion -> Bool-isReflCo (Refl{}) = True-isReflCo (GRefl _ _ mco) | isGReflMCo mco = True-isReflCo _ = False---- | Returns the type coerced if this coercion is a generalized reflexive--- coercion. Guaranteed to work very quickly.-isGReflCo_maybe :: Coercion -> Maybe (Type, Role)-isGReflCo_maybe (GRefl r ty _) = Just (ty, r)-isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)-isGReflCo_maybe _ = Nothing---- | Returns the type coerced if this coercion is reflexive. Guaranteed--- to work very quickly. Sometimes a coercion can be reflexive, but not--- obviously so. c.f. 'isReflexiveCo_maybe'-isReflCo_maybe :: Coercion -> Maybe (Type, Role)-isReflCo_maybe (Refl ty) = Just (ty, Nominal)-isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)-isReflCo_maybe _ = Nothing---- | Slowly checks if the coercion is reflexive. Don't call this in a loop,--- as it walks over the entire coercion.-isReflexiveCo :: Coercion -> Bool-isReflexiveCo = isJust . isReflexiveCo_maybe---- | Extracts the coerced type from a reflexive coercion. This potentially--- walks over the entire coercion, so avoid doing this in a loop.-isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)-isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)-isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)-isReflexiveCo_maybe co-  | ty1 `eqType` ty2-  = Just (ty1, r)-  | otherwise-  = Nothing-  where (Pair ty1 ty2, r) = coercionKindRole co---{--%************************************************************************-%*                                                                      *-            Building coercions-%*                                                                      *-%************************************************************************--These "smart constructors" maintain the invariants listed in the definition-of Coercion, and they perform very basic optimizations.--Note [Role twiddling functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are a plethora of functions for twiddling roles:--mkSubCo: Requires a nominal input coercion and always produces a-representational output. This is used when you (the programmer) are sure you-know exactly that role you have and what you want.--downgradeRole_maybe: This function takes both the input role and the output role-as parameters. (The *output* role comes first!) It can only *downgrade* a-role -- that is, change it from N to R or P, or from R to P. This one-way-behavior is why there is the "_maybe". If an upgrade is requested, this-function produces Nothing. This is used when you need to change the role of a-coercion, but you're not sure (as you're writing the code) of which roles are-involved.--This function could have been written using coercionRole to ascertain the role-of the input. But, that function is recursive, and the caller of downgradeRole_maybe-often knows the input role. So, this is more efficient.--downgradeRole: This is just like downgradeRole_maybe, but it panics if the-conversion isn't a downgrade.--setNominalRole_maybe: This is the only function that can *upgrade* a coercion.-The result (if it exists) is always Nominal. The input can be at any role. It-works on a "best effort" basis, as it should never be strictly necessary to-upgrade a coercion during compilation. It is currently only used within GHC in-splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second-coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable-that splitAppCo_maybe is operating over a TyConAppCo that uses a-representational coercion. Hence the need for setNominalRole_maybe.-splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,-it is not absolutely critical that setNominalRole_maybe be complete.--Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom-UnivCos are perfectly type-safe, whereas representational and nominal ones are-not. (Nominal ones are no worse than representational ones, so this function *will*-change a UnivCo Representational to a UnivCo Nominal.)--Conal Elliott also came across a need for this function while working with the-GHC API, as he was decomposing Core casts. The Core casts use representational-coercions, as they must, but his use case required nominal coercions (he was-building a GADT). So, that's why this function is exported from this module.--One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as-appropriate? I (Richard E.) have decided not to do this, because upgrading a-role is bizarre and a caller should have to ask for this behavior explicitly.---}---- | Make a reflexive coercion-mkReflCo :: Role -> Type -> Coercion-mkReflCo Nominal ty = Refl ty-mkReflCo r       ty = GRefl r ty MRefl---- | Make a representational reflexive coercion-mkRepReflCo :: Type -> Coercion-mkRepReflCo ty = GRefl Representational ty MRefl---- | Make a nominal reflexive coercion-mkNomReflCo :: Type -> Coercion-mkNomReflCo = Refl---- | Apply a type constructor to a list of coercions. It is the--- caller's responsibility to get the roles correct on argument coercions.-mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion-mkTyConAppCo r tc cos-  | Just co <- tyConAppFunCo_maybe r tc cos-  = co--  -- Expand type synonyms-  | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos-  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos--  | Just tys_roles <- traverse isReflCo_maybe cos-  = mkReflCo r (mkTyConApp tc (map fst tys_roles))-  -- See Note [Refl invariant]--  | otherwise = TyConAppCo r tc cos--mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion--- This version of mkFunCo takes no FunTyFlags; it works them out-mkFunCoNoFTF r w arg_co res_co-  = mkFunCo2 r afl afr w arg_co res_co-  where-    afl = chooseFunTyFlag argl_ty resl_ty-    afr = chooseFunTyFlag argr_ty resr_ty-    Pair argl_ty argr_ty = coercionKind arg_co-    Pair resl_ty resr_ty = coercionKind res_co---- | Build a function 'Coercion' from two other 'Coercion's. That is,--- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@--- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@.--- This (most common) version takes a single FunTyFlag, which is used---   for both fco_afl and ftf_afr of the FunCo-mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion-mkFunCo1 r af w arg_co res_co-  = mkFunCo2 r af af w arg_co res_co--mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion--- This version of mkFunCo1 does not check FunCo invariants (checkFunCo)--- It is called during typechecking on un-zonked types;--- in particular there may be un-zonked coercion variables.-mkNakedFunCo1 r af w arg_co res_co-  = mkNakedFunCo2 r af af w arg_co res_co--mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag-                              -> CoercionN -> Coercion -> Coercion -> Coercion--- This is the smart constructor for FunCo; it checks invariants-mkFunCo2 r afl afr w arg_co res_co-  = assertPprMaybe (checkFunCo r afl afr w arg_co res_co) $-    mkNakedFunCo2 r afl afr w arg_co res_co--mkNakedFunCo2 :: Role -> FunTyFlag -> FunTyFlag-              -> CoercionN -> Coercion -> Coercion -> Coercion--- This is the smart constructor for FunCo--- "Naked"; it does not check invariants-mkNakedFunCo2 r afl afr w arg_co res_co-  | Just (ty1, _) <- isReflCo_maybe arg_co-  , Just (ty2, _) <- isReflCo_maybe res_co-  , Just (w, _)   <- isReflCo_maybe w-  = mkReflCo r (mkFunTy afl w ty1 ty2)  -- See Note [Refl invariant]--  | otherwise-  = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr-          , fco_mult = w, fco_arg = arg_co, fco_res = res_co }---checkFunCo :: Role -> FunTyFlag -> FunTyFlag-           -> CoercionN -> Coercion -> Coercion-           -> Maybe SDoc--- Checks well-formed-ness for FunCo--- Used only in assertions and Lint-{-# NOINLINE checkFunCo #-}-checkFunCo _r afl afr _w arg_co res_co-  | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty)-  = Just (hang (text "Bad arg or res types") 2 pp_inputs)--  | afl == computed_afl-  , afr == computed_afr-  = Nothing-  | otherwise-  = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl-               , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr-               , pp_inputs ])-  where-    computed_afl = chooseFunTyFlag argl_ty resl_ty-    computed_afr = chooseFunTyFlag argr_ty resr_ty-    Pair argl_ty argr_ty = coercionKind arg_co-    Pair resl_ty resr_ty = coercionKind res_co--    pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty-                     , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty-                     , text "arg_co:" <+> ppr arg_co-                     , text "res_co:" <+> ppr res_co ]--    ok ty = isTYPEorCONSTRAINT (typeKind ty)-    pp_ty str ty = text str <> colon <+> hang (ppr ty)-                                            2 (dcolon <+> ppr (typeKind ty))---- | Apply a 'Coercion' to another 'Coercion'.--- The second coercion must be Nominal, unless the first is Phantom.--- If the first is Phantom, then the second can be either Phantom or Nominal.-mkAppCo :: Coercion     -- ^ :: t1 ~r t2-        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2-        -> Coercion     -- ^ :: t1 s1 ~r t2 s2-mkAppCo co arg-  | Just (ty1, r) <- isReflCo_maybe co-  , Just (ty2, _) <- isReflCo_maybe arg-  = mkReflCo r (mkAppTy ty1 ty2)--  | Just (ty1, r) <- isReflCo_maybe co-  , Just (tc, tys) <- splitTyConApp_maybe ty1-    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)-  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)-  where-    zip_roles (Inf r1 _)  []            = [downgradeRole r1 Nominal arg]-    zip_roles (Inf r1 rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys--mkAppCo (TyConAppCo r tc args) arg-  = case r of-      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])-      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])-        where new_role = tyConRolesRepresentational tc Inf.!! length args-              arg'     = downgradeRole new_role Nominal arg-      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])-mkAppCo co arg = AppCo co  arg--- Note, mkAppCo is careful to maintain invariants regarding--- where Refl constructors appear; see the comments in the definition--- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep.---- | Applies multiple 'Coercion's to another 'Coercion', from left to right.--- See also 'mkAppCo'.-mkAppCos :: Coercion-         -> [Coercion]-         -> Coercion-mkAppCos co1 cos = foldl' mkAppCo co1 cos--{- Note [Unused coercion variable in ForAllCo]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the-motivation for checking coercion variable in types.-To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:--(1) In mkForAllCo, we check whether cv is a coercion variable-    and whether it is not used in body_co. If so we construct a FunCo.-(2) We don't do this check in mkForAllCo.-    In coercionKind, we use mkTyCoForAllTy to perform the check and construct-    a FunTy when necessary.--We chose (2) for two reasons:--* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not-  make a difference.-* even if cv occurs in body_co, it is possible that cv does not occur in the kind-  of body_co. Therefore the check in coercionKind is inevitable.--The last wrinkle is that there are restrictions around the use of the cv in the-coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that-we cannot prove that the type system is consistent with unrestricted use of this-cv; the consistency proof uses an untyped rewrite relation that works over types-with all coercions and casts removed. So, we can allow the cv to appear only in-positions that are erased. As an approximation of this (and keeping close to the-published theory), we currently allow the cv only within the type in a Refl node-and under a GRefl node (including in the Coercion stored in a GRefl). It's-possible other places are OK, too, but this is a safe approximation.--Sadly, with heterogeneous equality, this restriction might be able to be violated;-Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst-function might create an invalid coercion. Because a violation of the-restriction might lead to a program that "goes wrong", it is checked all the time,-even in a production compiler and without -dcore-lint. We *have* proved that the-problem does not occur with homogeneous equality, so this check can be dropped-once ~# is made to be homogeneous.--}----- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.--- The kind of the tycovar should be the left-hand kind of the kind coercion.--- See Note [Unused coercion variable in ForAllCo]-mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo v kind_co co-  | assert (varType v `eqType` (coercionLKind kind_co)) True-  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True-  , Just (ty, r) <- isReflCo_maybe co-  , isGReflCo kind_co-  = mkReflCo r (mkTyCoInvForAllTy v ty)-  | otherwise-  = ForAllCo v kind_co co---- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.--- The kind of the tycovar should be the left-hand kind of the kind coercion.-mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo_NoRefl v kind_co co-  | assert (varType v `eqType` (coercionLKind kind_co)) True-  , assert (not (isReflCo co)) True-  , isCoVar v-  , assert (almostDevoidCoVarOfCo v co) True-  , not (v `elemVarSet` tyCoVarsOfCo co)-  = mkFunCoNoFTF (coercionRole co) (multToCo ManyTy) kind_co co-      -- Functions from coercions are always unrestricted-  | otherwise-  = ForAllCo v kind_co co---- | Make nested ForAllCos-mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion-mkForAllCos bndrs co-  | Just (ty, r ) <- isReflCo_maybe co-  = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in-    foldl' (flip $ uncurry mkForAllCo_NoRefl)-           (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty))-           non_refls_rev'd-  | otherwise-  = foldr (uncurry mkForAllCo_NoRefl) co bndrs---- | Make a Coercion quantified over a type/coercion variable;--- the variable has the same type in both sides of the coercion-mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos vs co-  | Just (ty, r) <- isReflCo_maybe co-  = mkReflCo r (mkTyCoInvForAllTys vs ty)-  | otherwise-  = mkHomoForAllCos_NoRefl vs co---- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.-mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos_NoRefl vs orig_co-  = assert (not (isReflCo orig_co))-    foldr go orig_co vs-  where-    go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co--mkCoVarCo :: CoVar -> Coercion--- cv :: s ~# t--- See Note [mkCoVarCo]-mkCoVarCo cv = CoVarCo cv--mkCoVarCos :: [CoVar] -> [Coercion]-mkCoVarCos = map mkCoVarCo--{- Note [mkCoVarCo]-~~~~~~~~~~~~~~~~~~~-In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is-valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but-it's a relatively expensive test and perhaps better done in-optCoercion.  Not a big deal either way.--}--mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]-           -> Coercion--- mkAxInstCo can legitimately be called over-saturated;--- i.e. with more type arguments than the coercion requires-mkAxInstCo role ax index tys cos-  | arity == n_tys = downgradeRole role ax_role $-                     mkAxiomInstCo ax_br index (rtys `chkAppend` cos)-  | otherwise      = assert (arity < n_tys) $-                     downgradeRole role ax_role $-                     mkAppCos (mkAxiomInstCo ax_br index-                                             (ax_args `chkAppend` cos))-                              leftover_args-  where-    n_tys         = length tys-    ax_br         = toBranchedAxiom ax-    branch        = coAxiomNthBranch ax_br index-    tvs           = coAxBranchTyVars branch-    arity         = length tvs-    arg_roles     = coAxBranchRoles branch-    rtys          = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys-    (ax_args, leftover_args)-                  = splitAt arity rtys-    ax_role       = coAxiomRole ax---- worker function-mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion-mkAxiomInstCo ax index args-  = assert (args `lengthIs` coAxiomArity ax index) $-    AxiomInstCo ax index args---- to be used only with unbranched axioms-mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched-                     -> [Type] -> [Coercion] -> Coercion-mkUnbranchedAxInstCo role ax tys cos-  = mkAxInstCo role ax 0 tys cos--mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type--- Instantiate the axiom with specified types,--- returning the instantiated RHS--- A companion to mkAxInstCo:---    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))-mkAxInstRHS ax index tys cos-  = assert (tvs `equalLength` tys1) $-    mkAppTys rhs' tys2-  where-    branch       = coAxiomNthBranch ax index-    tvs          = coAxBranchTyVars branch-    cvs          = coAxBranchCoVars branch-    (tys1, tys2) = splitAtList tvs tys-    rhs'         = substTyWith tvs tys1 $-                   substTyWithCoVars cvs cos $-                   coAxBranchRHS branch--mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type-mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0---- | Return the left-hand type of the axiom, when the axiom is instantiated--- at the types given.-mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type-mkAxInstLHS ax index tys cos-  = assert (tvs `equalLength` tys1) $-    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)-  where-    branch       = coAxiomNthBranch ax index-    tvs          = coAxBranchTyVars branch-    cvs          = coAxBranchCoVars branch-    (tys1, tys2) = splitAtList tvs tys-    lhs_tys      = substTysWith tvs tys1 $-                   substTysWithCoVars cvs cos $-                   coAxBranchLHS branch-    fam_tc       = coAxiomTyCon ax---- | Instantiate the left-hand side of an unbranched axiom-mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type-mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0---- | Make a coercion from a coercion hole-mkHoleCo :: CoercionHole -> Coercion-mkHoleCo h = HoleCo h---- | Make a universal coercion between two arbitrary types.-mkUnivCo :: UnivCoProvenance-         -> Role       -- ^ role of the built coercion, "r"-         -> Type       -- ^ t1 :: k1-         -> Type       -- ^ t2 :: k2-         -> Coercion   -- ^ :: t1 ~r t2-mkUnivCo prov role ty1 ty2-  | ty1 `eqType` ty2 = mkReflCo role ty1-  | otherwise        = UnivCo prov role ty1 ty2---- | Create a symmetric version of the given 'Coercion' that asserts---   equality between the same types but in the other "direction", so---   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.-mkSymCo :: Coercion -> Coercion---- Do a few simple optimizations, but don't bother pushing occurrences--- of symmetry to the leaves; the optimizer will take care of that.-mkSymCo co | isReflCo co          = co-mkSymCo    (SymCo co)             = co-mkSymCo    (SubCo (SymCo co))     = SubCo co-mkSymCo co                        = SymCo co---- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.---   (co1 ; co2)-mkTransCo :: Coercion -> Coercion -> Coercion-mkTransCo co1 co2 | isReflCo co1 = co2-                  | isReflCo co2 = co1-mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))-  = GRefl r t1 (MCo $ mkTransCo co1 co2)-mkTransCo co1 co2                = TransCo co1 co2--mkSelCo :: HasDebugCallStack-        => CoSel-        -> Coercion-        -> Coercion-mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co--mkSelCo_maybe :: HasDebugCallStack-        => CoSel-        -> Coercion-        -> Maybe Coercion--- mkSelCo_maybe tries to optimise call to mkSelCo-mkSelCo_maybe cs co-  = assertPpr (good_call cs) bad_call_msg $-    go cs co-  where-    Pair ty1 ty2 = coercionKind co--    go cs co-      | Just (ty, _co_role) <- isReflCo_maybe co-      = let new_role = coercionRole (SelCo cs co)-        in Just (mkReflCo new_role (getNthFromType cs ty))-        -- The role of the result (new_role) does not have to-        -- be equal to _co_role, the role of co, per Note [SelCo].-        -- This was revealed by #23938.--    go SelForAll (ForAllCo _ kind_co _)-      = Just kind_co-      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)-      -- then (nth SelForAll co :: k1 ~N k2)-      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)-      -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4))--    go (SelFun fs) (FunCo _ _ _ w arg res)-      = Just (getNthFun fs w arg res)--    go (SelTyCon i r) (TyConAppCo r0 tc arg_cos)-      = assertPpr (r == tyConRole r0 tc i)-                  (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $-        Just (arg_cos `getNth` i)--    go cs (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo-      = do { co' <- go cs co; return (mkSymCo co') }--    go _ _ = Nothing--    -- Assertion checking-    bad_call_msg = vcat [ text "Coercion =" <+> ppr co-                        , text "LHS ty =" <+> ppr ty1-                        , text "RHS ty =" <+> ppr ty2-                        , text "cs =" <+> ppr cs-                        , text "coercion role =" <+> ppr (coercionRole co) ]--    -- good_call checks the typing rules given in Note [SelCo]-    good_call SelForAll-      | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1-      , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2-      =  True--    good_call (SelFun {})-       = isFunTy ty1 && isFunTy ty2--    good_call (SelTyCon n r)-       | Just (tc1, tys1) <- splitTyConApp_maybe ty1-       , Just (tc2, tys2) <- splitTyConApp_maybe ty2-       , let { len1 = length tys1-             ; len2 = length tys2 }-       =  (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2))-                      -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo]-       && len1 == len2-       && n < len1-       && r == tyConRole (coercionRole co) tc1 n--    good_call _ = False---- | Extract the nth field of a FunCo-getNthFun :: FunSel-          -> a    -- ^ multiplicity-          -> a    -- ^ argument-          -> a    -- ^ result-          -> a    -- ^ One of the above three-getNthFun SelMult mult _   _   = mult-getNthFun SelArg _     arg _   = arg-getNthFun SelRes _     _   res = res--mkLRCo :: LeftOrRight -> Coercion -> Coercion-mkLRCo lr co-  | Just (ty, eq) <- isReflCo_maybe co-  = mkReflCo eq (pickLR lr (splitAppTy ty))-  | otherwise-  = LRCo lr co---- | Instantiates a 'Coercion'.-mkInstCo :: Coercion -> CoercionN -> Coercion-mkInstCo (ForAllCo tcv _kind_co body_co) co-  | Just (arg, _) <- isReflCo_maybe co-      -- works for both tyvar and covar-  = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co-mkInstCo co arg = InstCo co arg---- | Given @ty :: k1@, @co :: k1 ~ k2@,--- produces @co' :: ty ~r (ty |> co)@-mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion-mkGReflRightCo r ty co-  | isGReflCo co = mkReflCo r ty-    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@-    -- instead of @isReflCo@-  | otherwise = GRefl r ty (MCo co)---- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@,--- produces @co' :: (ty |> co) ~r ty@-mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion-mkGReflLeftCo r ty co-  | isGReflCo co = mkReflCo r ty-    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@-    -- instead of @isReflCo@-  | otherwise    = mkSymCo $ GRefl r ty (MCo co)---- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,--- produces @co' :: (ty |> co) ~r ty'--- It is not only a utility function, but it saves allocation when co--- is a GRefl coercion.-mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion-mkCoherenceLeftCo r ty co co2-  | isGReflCo co = co2-  | otherwise    = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2---- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,--- produces @co' :: ty' ~r (ty |> co)--- It is not only a utility function, but it saves allocation when co--- is a GRefl coercion.-mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion-mkCoherenceRightCo r ty co co2-  | isGReflCo co = co2-  | otherwise    = co2 `mkTransCo` GRefl r ty (MCo co)---- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.-mkKindCo :: Coercion -> Coercion-mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)-mkKindCo (GRefl _ _ (MCo co)) = co-mkKindCo (UnivCo (PhantomProv h) _ _ _)    = h-mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h-mkKindCo co-  | Pair ty1 ty2 <- coercionKind co-       -- generally, calling coercionKind during coercion creation is a bad idea,-       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,-       -- so it's OK here.-  , let tk1 = typeKind ty1-        tk2 = typeKind ty2-  , tk1 `eqType` tk2-  = Refl tk1-  | otherwise-  = KindCo co--mkSubCo :: HasDebugCallStack => Coercion -> Coercion--- Input coercion is Nominal, result is Representational--- see also Note [Role twiddling functions]-mkSubCo (Refl ty) = GRefl Representational ty MRefl-mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co-mkSubCo (TyConAppCo Nominal tc cos)-  = TyConAppCo Representational tc (applyRoles tc cos)-mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })-  = co { fco_role = Representational-       , fco_arg = downgradeRole Representational Nominal arg-       , fco_res = downgradeRole Representational Nominal res }-mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $-             SubCo co---- | Changes a role, but only a downgrade. See Note [Role twiddling functions]-downgradeRole_maybe :: Role   -- ^ desired role-                    -> Role   -- ^ current role-                    -> Coercion -> Maybe Coercion--- In (downgradeRole_maybe dr cr co) it's a precondition that---                                   cr = coercionRole co--downgradeRole_maybe Nominal          Nominal          co = Just co-downgradeRole_maybe Nominal          _                _  = Nothing--downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)-downgradeRole_maybe Representational Representational co = Just co-downgradeRole_maybe Representational Phantom          _  = Nothing--downgradeRole_maybe Phantom          Phantom          co = Just co-downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)---- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.--- See Note [Role twiddling functions]-downgradeRole :: Role  -- desired role-              -> Role  -- current role-              -> Coercion -> Coercion-downgradeRole r1 r2 co-  = case downgradeRole_maybe r1 r2 co of-      Just co' -> co'-      Nothing  -> pprPanic "downgradeRole" (ppr co)--mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion-mkAxiomRuleCo = AxiomRuleCo---- | Make a "coercion between coercions".-mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"-               -> CoercionN  -- ^ :: phi1 ~N phi2-               -> Coercion   -- ^ g1 :: phi1-               -> Coercion   -- ^ g2 :: phi2-               -> Coercion   -- ^ :: g1 ~r g2---- if the two coercion prove the same fact, I just don't care what--- the individual coercions are.-mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)-  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@-mkProofIrrelCo r kco        g1 g2 = mkUnivCo (ProofIrrelProv kco) r-                                             (mkCoercionTy g1) (mkCoercionTy g2)--{--%************************************************************************-%*                                                                      *-   Roles-%*                                                                      *-%************************************************************************--}---- | Converts a coercion to be nominal, if possible.--- See Note [Role twiddling functions]-setNominalRole_maybe :: Role -- of input coercion-                     -> Coercion -> Maybe CoercionN-setNominalRole_maybe r co-  | r == Nominal = Just co-  | otherwise = setNominalRole_maybe_helper co-  where-    setNominalRole_maybe_helper (SubCo co)  = Just co-    setNominalRole_maybe_helper co@(Refl _) = Just co-    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co-    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)-      = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos-           ; return $ TyConAppCo Nominal tc cos' }-    setNominalRole_maybe_helper co@(FunCo { fco_role = Representational-                                          , fco_arg = co1, fco_res = co2 })-      = do { co1' <- setNominalRole_maybe Representational co1-           ; co2' <- setNominalRole_maybe Representational co2-           ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' }-           }-    setNominalRole_maybe_helper (SymCo co)-      = SymCo <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (TransCo co1 co2)-      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2-    setNominalRole_maybe_helper (AppCo co1 co2)-      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2-    setNominalRole_maybe_helper (ForAllCo tv kind_co co)-      = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (SelCo cs co) =-      -- NB, this case recurses via setNominalRole_maybe, not-      -- setNominalRole_maybe_helper!-      case cs of-        SelTyCon n _r ->-          -- Remember to update the role in SelTyCon to nominal;-          -- not doing this caused #23362.-          -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.-          SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co-        SelFun fs ->-          SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co-        SelForAll ->-          pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)-    setNominalRole_maybe_helper (InstCo co arg)-      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg-    setNominalRole_maybe_helper (UnivCo prov _ co1 co2)-      | case prov of PhantomProv _    -> False  -- should always be phantom-                     ProofIrrelProv _ -> True   -- it's always safe-                     PluginProv _     -> False  -- who knows? This choice is conservative.-                     CorePrepProv _   -> True-      = Just $ UnivCo prov Nominal co1 co2-    setNominalRole_maybe_helper _ = Nothing---- | Make a phantom coercion between two types. The coercion passed--- in must be a nominal coercion between the kinds of the--- types.-mkPhantomCo :: Coercion -> Type -> Type -> Coercion-mkPhantomCo h t1 t2-  = mkUnivCo (PhantomProv h) Phantom t1 t2---- takes any coercion and turns it into a Phantom coercion-toPhantomCo :: Coercion -> Coercion-toPhantomCo co-  = mkPhantomCo (mkKindCo co) ty1 ty2-  where Pair ty1 ty2 = coercionKind co---- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational-applyRoles :: TyCon -> [Coercion] -> [Coercion]-applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational---- The Role parameter is the Role of the TyConAppCo--- defined here because this is intimately concerned with the implementation--- of TyConAppCo--- Always returns an infinite list (with a infinite tail of Nominal)-tyConRolesX :: Role -> TyCon -> Infinite Role-tyConRolesX Representational tc = tyConRolesRepresentational tc-tyConRolesX role             _  = Inf.repeat role--tyConRoleListX :: Role -> TyCon -> [Role]-tyConRoleListX role = Inf.toList . tyConRolesX role---- Returns the roles of the parameters of a tycon, with an infinite tail--- of Nominal-tyConRolesRepresentational :: TyCon -> Infinite Role-tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal---- Returns the roles of the parameters of a tycon, with an infinite tail--- of Nominal-tyConRoleListRepresentational :: TyCon -> [Role]-tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational--tyConRole :: Role -> TyCon -> Int -> Role-tyConRole Nominal          _  _ = Nominal-tyConRole Phantom          _  _ = Phantom-tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n--funRole :: Role -> FunSel -> Role-funRole Nominal          _  = Nominal-funRole Phantom          _  = Phantom-funRole Representational fs = funRoleRepresentational fs--funRoleRepresentational :: FunSel -> Role-funRoleRepresentational SelMult = Nominal-funRoleRepresentational SelArg  = Representational-funRoleRepresentational SelRes  = Representational--ltRole :: Role -> Role -> Bool--- Is one role "less" than another?---     Nominal < Representational < Phantom-ltRole Phantom          _       = False-ltRole Representational Phantom = True-ltRole Representational _       = False-ltRole Nominal          Nominal = False-ltRole Nominal          _       = True------------------------------------- | like mkKindCo, but aggressively & recursively optimizes to avoid using--- a KindCo constructor. The output role is nominal.-promoteCoercion :: Coercion -> CoercionN---- First cases handles anything that should yield refl.-promoteCoercion co = case co of--    Refl _ -> mkNomReflCo ki1--    GRefl _ _ MRefl -> mkNomReflCo ki1--    GRefl _ _ (MCo co) -> co--    _ | ki1 `eqType` ki2-      -> mkNomReflCo (typeKind ty1)-     -- No later branch should return refl-     -- The assert (False )s throughout-     -- are these cases explicitly, but they should never fire.--    TyConAppCo _ tc args-      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args-      -> co'-      | otherwise-      -> mkKindCo co--    AppCo co1 arg-      | Just co' <- instCoercion (coercionKind (mkKindCo co1))-                                 (promoteCoercion co1) arg-      -> co'-      | otherwise-      -> mkKindCo co--    ForAllCo tv _ g-      | isTyVar tv-      -> promoteCoercion g--    ForAllCo {}-      -> assert False $-            -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2)-            -- The tyvar case is handled above, so the bound var is a-            -- a coercion variable. So both sides have kind Type-            -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep).-            -- So the result is Refl, and that should have been caught by-            -- the first equation above-         mkNomReflCo liftedTypeKind--    FunCo {} -> mkKindCo co-       -- We can get Type~Constraint or Constraint~Type-       -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint))--    CoVarCo {}     -> mkKindCo co-    HoleCo {}      -> mkKindCo co-    AxiomInstCo {} -> mkKindCo co-    AxiomRuleCo {} -> mkKindCo co--    UnivCo (PhantomProv kco)    _ _ _ -> kco-    UnivCo (ProofIrrelProv kco) _ _ _ -> kco-    UnivCo (PluginProv _)       _ _ _ -> mkKindCo co-    UnivCo (CorePrepProv _)     _ _ _ -> mkKindCo co--    SymCo g-      -> mkSymCo (promoteCoercion g)--    TransCo co1 co2-      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)--    SelCo n co1-      | Just co' <- mkSelCo_maybe n co1-      -> promoteCoercion co'--      | otherwise-      -> mkKindCo co--    LRCo lr co1-      | Just (lco, rco) <- splitAppCo_maybe co1-      -> case lr of-           CLeft  -> promoteCoercion lco-           CRight -> promoteCoercion rco--      | otherwise-      -> mkKindCo co--    InstCo g _-      | isForAllTy_ty ty1-      -> assert (isForAllTy_ty ty2) $-         promoteCoercion g-      | otherwise-      -> assert False $-         mkNomReflCo liftedTypeKind-           -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep--    KindCo _-      -> assert False $ -- See the first equation above-         mkNomReflCo liftedTypeKind--    SubCo g-      -> promoteCoercion g--  where-    Pair ty1 ty2 = coercionKind co-    ki1 = typeKind ty1-    ki2 = typeKind ty2---- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,--- where @g' = promoteCoercion (h w)@.--- fails if this is not possible, if @g@ coerces between a forall and an ->--- or if second parameter has a representational role and can't be used--- with an InstCo.-instCoercion :: Pair Type -- g :: lty ~ rty-             -> CoercionN  -- ^  must be nominal-             -> Coercion-             -> Maybe CoercionN-instCoercion (Pair lty rty) g w-  | (isForAllTy_ty lty && isForAllTy_ty rty)-  || (isForAllTy_co lty && isForAllTy_co rty)-  , Just w' <- setNominalRole_maybe (coercionRole w) w-    -- g :: (forall t1. t2) ~ (forall t1. t3)-    -- w :: s1 ~ s2-    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]-  = Just $ mkInstCo g w'--  | isFunTy lty && isFunTy rty-    -- g :: (t1 -> t2) ~ (t3 -> t4)-    -- returns t2 ~ t4-  = Just $ mkSelCo (SelFun SelRes) g -- extract result type--  | otherwise -- one forall, one funty...-  = Nothing---- | Repeated use of 'instCoercion'-instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN-instCoercions g ws-  = let arg_ty_pairs = map coercionKind ws in-    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)-  where-    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)-       -> Maybe (Pair Type, Coercion)-    go (g_tys, g) (w_tys, w)-      = do { g' <- instCoercion g_tys g w-           ; return (piResultTy <$> g_tys <*> w_tys, g') }---- | Creates a new coercion with both of its types casted by different casts--- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,--- has type @(t1 |> h1) ~r (t2 |> h2)@.--- @h1@ and @h2@ must be nominal.-castCoercionKind2 :: Coercion -> Role -> Type -> Type-                 -> CoercionN -> CoercionN -> Coercion-castCoercionKind2 g r t1 t2 h1 h2-  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)---- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@--- That is, it's a specialised form of castCoercionKind, where the two---          kind coercions are identical--- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,--- has type @(t1 |> h) ~r (t2 |> h)@.--- @h@ must be nominal.--- See Note [castCoercionKind1]-castCoercionKind1 :: Coercion -> Role -> Type -> Type-                  -> CoercionN -> Coercion-castCoercionKind1 g r t1 t2 h-  = case g of-      Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal-                 mkNomReflCo (mkCastTy t2 h)-      GRefl _ _ mco -> case mco of-           MRefl       -> mkReflCo r (mkCastTy t2 h)-           MCo kind_co -> GRefl r (mkCastTy t1 h) $-                          MCo (mkSymCo h `mkTransCo` kind_co `mkTransCo` h)-      _ -> castCoercionKind2 g r t1 t2 h h---- | Creates a new coercion with both of its types casted by different casts--- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,--- has type @(t1 |> h1) ~r (t2 |> h2)@.--- @h1@ and @h2@ must be nominal.--- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)--- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand.-castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion-castCoercionKind g h1 h2-  = castCoercionKind2 g r t1 t2 h1 h2-  where-    (Pair t1 t2, r) = coercionKindRole g--mkPiCos :: Role -> [Var] -> Coercion -> Coercion-mkPiCos r vs co = foldr (mkPiCo r) co vs---- | Make a forall 'Coercion', where both types related by the coercion--- are quantified over the same variable.-mkPiCo  :: Role -> Var -> Coercion -> Coercion-mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co-              | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $-                  -- We didn't call mkForAllCo here because if v does not appear-                  -- in co, the argument coercion will be nominal. But here we-                  -- want it to be r. It is only called in 'mkPiCos', which is-                  -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for-                  -- now (Aug 2018) v won't occur in co.-                            mkFunResCo r v co-              | otherwise = mkFunResCo r v co--mkFunResCo :: Role -> Id -> Coercion -> Coercion--- Given res_co :: res1 ~ res2,---   mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2)--- Reflexive in the multiplicity argument-mkFunResCo role id res_co-  = mkFunCoNoFTF role mult arg_co res_co-  where-    arg_co = mkReflCo role (varType id)-    mult   = multToCo (varMult 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--- Lifted and unlifted equalities take different numbers of arguments,--- so we have to make sure to supply the right parameter to decomposeCo.--- Also, note that the role of the first coercion is the same as the role of--- the equalities related by the second coercion. The second coercion is--- itself always representational.-mkCoCast :: Coercion -> CoercionR -> Coercion-mkCoCast c g-  | (g2:g1:_) <- reverse co_list-  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2--  | otherwise-  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))-  where-    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)-    -- g1 :: s1 ~# s2-    -- g2 :: t1 ~# t2-    (tc, _) = splitTyConApp (coercionLKind g)-    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)--{- Note [castCoercionKind1]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-castCoercionKind1 deals with the very important special case of castCoercionKind2-where the two kind coercions are identical.  In that case we can exploit the-situation where the main coercion is reflexive, via the special cases for Refl-and GRefl.--This is important when rewriting  (ty |> co). We rewrite ty, yielding-   fco :: ty ~ ty'-and now we want a coercion xco between-   xco :: (ty |> co) ~ (ty' |> co)-That's exactly what castCoercionKind1 does.  And it's very very common for-fco to be Refl.  In that case we do NOT want to get some terrible composition-of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2-has to do in its full generality.  See #18413.--}--{--%************************************************************************-%*                                                                      *-            Newtypes-%*                                                                      *-%************************************************************************--}---- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)`---   then `co :: T ts ~R# rep_ty`------ Checks for a newtype, and for being saturated-instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)-instNewTyCon_maybe tc tys-  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype-  , tvs `leLength` tys                                    -- Check saturated enough-  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])-  | otherwise-  = Nothing--{--************************************************************************-*                                                                      *-         Type normalisation-*                                                                      *-************************************************************************--}---- | A function to check if we can reduce a type by one step. Used--- with 'topNormaliseTypeX'.-type NormaliseStepper ev = RecTcChecker-                         -> TyCon     -- tc-                         -> [Type]    -- tys-                         -> NormaliseStepResult ev---- | The result of stepping in a normalisation function.--- See 'topNormaliseTypeX'.-data NormaliseStepResult ev-  = NS_Done   -- ^ Nothing more to do-  | NS_Abort  -- ^ Utter failure. The outer function should fail too.-  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;-                                    -- ^ ev is evidence;-                                    -- Usually a co :: old type ~ new type-  deriving (Functor)--instance Outputable ev => Outputable (NormaliseStepResult ev) where-  ppr NS_Done           = text "NS_Done"-  ppr NS_Abort          = text "NS_Abort"-  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]---- | Try one stepper and then try the next, if the first doesn't make--- progress.--- So if it returns NS_Done, it means that both steppers are satisfied-composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev-                -> NormaliseStepper ev-composeSteppers step1 step2 rec_nts tc tys-  = case step1 rec_nts tc tys of-      success@(NS_Step {}) -> success-      NS_Done              -> step2 rec_nts tc tys-      NS_Abort             -> NS_Abort---- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into--- a loop. If it would fall into a loop, it produces 'NS_Abort'.-unwrapNewTypeStepper :: NormaliseStepper Coercion-unwrapNewTypeStepper rec_nts tc tys-  | Just (ty', co) <- instNewTyCon_maybe tc tys-  = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $-    case checkRecTc rec_nts tc of-      Just rec_nts' -> NS_Step rec_nts' ty' co-      Nothing       -> NS_Abort--  | otherwise-  = NS_Done---- | A general function for normalising the top-level of a type. It continues--- to use the provided 'NormaliseStepper' until that function fails, and then--- this function returns. The roles of the coercions produced by the--- 'NormaliseStepper' must all be the same, which is the role returned from--- the call to 'topNormaliseTypeX'.------ Typically ev is Coercion.------ If topNormaliseTypeX step plus ty = Just (ev, ty')--- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'--- and ev = ev1 `plus` ev2 `plus` ... `plus` evn--- If it returns Nothing then no newtype unwrapping could happen-topNormaliseTypeX :: NormaliseStepper ev-                  -> (ev -> ev -> ev)-                  -> Type -> Maybe (ev, Type)-topNormaliseTypeX stepper plus ty- | Just (tc, tys) <- splitTyConApp_maybe ty- -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous- --      for certain type synonyms, we should think about reducing it (see #20990)- , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys- = go rec_nts ev ty'- | otherwise- = Nothing- where-    go rec_nts ev ty-      | Just (tc, tys) <- splitTyConApp_maybe ty-      = case stepper rec_nts tc tys of-          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'-          NS_Done  -> Just (ev, ty)-          NS_Abort -> Nothing--      | otherwise-      = Just (ev, ty)--topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)--- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.--- This function strips off @newtype@ layers enough to reveal something that isn't--- a @newtype@.  Specifically, here's the invariant:------ > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')------ then (a)  @co : ty ~R ty'@.---      (b)  ty' is not a newtype.------ The function returns @Nothing@ for non-@newtypes@,--- or unsaturated applications------ This function does *not* look through type families, because it has no access to--- the type family environment. If you do have that at hand, consider to use--- topNormaliseType_maybe, which should be a drop-in replacement for--- topNormaliseNewType_maybe--- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'-topNormaliseNewType_maybe ty-  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty--{--%************************************************************************-%*                                                                      *-                   Comparison of coercions-%*                                                                      *-%************************************************************************--}---- | Syntactic equality of coercions-eqCoercion :: Coercion -> Coercion -> Bool-eqCoercion = eqType `on` coercionType---- | Compare two 'Coercion's, with respect to an RnEnv2-eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool-eqCoercionX env = eqTypeX env `on` coercionType--{--%************************************************************************-%*                                                                      *-                   "Lifting" substitution-           [(TyCoVar,Coercion)] -> Type -> Coercion-%*                                                                      *-%************************************************************************--Note [Lifting coercions over types: liftCoSubst]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The KPUSH rule deals with this situation-   data T a = K (a -> Maybe a)-   g :: T t1 ~ T t2-   x :: t1 -> Maybe t1--   case (K @t1 x) |> g of-     K (y:t2 -> Maybe t2) -> rhs--We want to push the coercion inside the constructor application.-So we do this--   g' :: t1~t2  =  SelCo (SelTyCon 0) g--   case K @t2 (x |> g' -> Maybe g') of-     K (y:t2 -> Maybe t2) -> rhs--The crucial operation is that we-  * take the type of K's argument: a -> Maybe a-  * and substitute g' for a-thus giving *coercion*.  This is what liftCoSubst does.--In the presence of kind coercions, this is a bit-of a hairy operation. So, we refer you to the paper introducing kind coercions,-available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf--Note [extendLiftingContextEx]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider we have datatype-  K :: /\k. /\a::k. P -> T k  -- P be some type-  g :: T k1 ~ T k2--  case (K @k1 @t1 x) |> g of-    K y -> rhs--We want to push the coercion inside the constructor application.-We first get the coercion mapped by the universal type variable k:-   lc = k |-> SelCo (SelTyCon 0) g :: k1~k2--Here, the important point is that the kind of a is coerced, and P might be-dependent on the existential type variable a.-Thus we first get the coercion of a's kind-   g2 = liftCoSubst lc k :: k1 ~ k2--Then we store a new mapping into the lifting context-   lc2 = a |-> (t1 ~ t1 |> g2), lc--So later when we can correctly deal with the argument type P-   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]--This is exactly what extendLiftingContextEx does.-* For each (tyvar:k, ty) pair, we product the mapping-    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))-* For each (covar:s1~s2, ty) pair, we produce the mapping-    covar |-> (co ~ co')-    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'--This follows the lifting context extension definition in the-"FC with Explicit Kind Equality" paper.--}---- ------------------------------------------------------- See Note [Lifting coercions over types: liftCoSubst]--- ------------------------------------------------------data LiftingContext = LC Subst LiftCoEnv-  -- in optCoercion, we need to lift when optimizing InstCo.-  -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt-  -- We thus propagate the substitution from GHC.Core.Coercion.Opt here.--instance Outputable LiftingContext where-  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)--type LiftCoEnv = VarEnv Coercion-     -- Maps *type variables* to *coercions*.-     -- That's the whole point of this function!-     -- 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-                  -> [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))--liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion-liftCoSubstWith r tvs cos ty-  = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty---- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)--- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where--- @lc_left@ is a substitution mapping type variables to the left-hand--- types of the mapped coercions in @lc@, and similar for @lc_right@.-liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion-{-# INLINE liftCoSubst #-}--- Inlining this function is worth 2% of allocation in T9872d,-liftCoSubst r lc@(LC subst env) ty-  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)-  | otherwise         = ty_co_subst lc r ty--emptyLiftingContext :: InScopeSet -> LiftingContext-emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv--mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext-mkLiftingContext pairs-  = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))-       (mkVarEnv pairs)--mkSubstLiftingContext :: Subst -> LiftingContext-mkSubstLiftingContext subst = LC subst emptyVarEnv---- | Extend a lifting context with a new mapping.-extendLiftingContext :: LiftingContext  -- ^ original LC-                     -> TyCoVar         -- ^ new variable to map...-                     -> Coercion        -- ^ ...to this lifted version-                     -> LiftingContext-    -- mappings to reflexive coercions are just substitutions-extendLiftingContext (LC subst env) tv arg-  | Just (ty, _) <- isReflCo_maybe arg-  = LC (extendTCvSubst subst tv ty) env-  | otherwise-  = LC subst (extendVarEnv env tv arg)---- | Extend a lifting context with a new mapping, and extend the in-scope set-extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC-                               -> TyCoVar         -- ^ new variable to map...-                               -> Coercion        -- ^ to this coercion-                               -> LiftingContext-extendLiftingContextAndInScope (LC subst env) tv co-  = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co---- | Extend a lifting context with existential-variable bindings.--- See Note [extendLiftingContextEx]-extendLiftingContextEx :: LiftingContext    -- ^ original lifting context-                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs-                       -> LiftingContext--- Note that this is more involved than extendLiftingContext. That function--- takes a coercion to extend with, so it's assumed that the caller has taken--- into account any of the kind-changing stuff worried about here.-extendLiftingContextEx lc [] = lc-extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)--- This function adds bindings for *Nominal* coercions. Why? Because it--- works with existentially bound variables, which are considered to have--- nominal roles.-  | isTyVar v-  = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty)-                 (extendVarEnv env v $-                  mkGReflRightCo Nominal-                                 ty-                                 (ty_co_subst lc Nominal (tyVarKind v)))-    in extendLiftingContextEx lc' rest-  | CoercionTy co <- ty-  = -- co      :: s1 ~r s2-    -- lift_s1 :: s1 ~r s1'-    -- lift_s2 :: s2 ~r s2'-    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')-    assert (isCoVar v) $-    let (_, _, s1, s2, r) = coVarKindsTypesRole v-        lift_s1 = ty_co_subst lc r s1-        lift_s2 = ty_co_subst lc r s2-        kco     = mkTyConAppCo Nominal (equalityTyCon r)-                               [ mkKindCo lift_s1, mkKindCo lift_s2-                               , lift_s1         , lift_s2          ]-        lc'     = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co)-                     (extendVarEnv env v-                        (mkProofIrrelCo Nominal kco co $-                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))-    in extendLiftingContextEx lc' rest-  | otherwise-  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)----- | Erase the environments in a lifting context-zapLiftingContext :: LiftingContext -> LiftingContext-zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv---- | Like 'substForAllCoBndr', but works on a lifting context-substForAllCoBndrUsingLC :: Bool-                            -> (Coercion -> Coercion)-                            -> LiftingContext -> TyCoVar -> Coercion-                            -> (LiftingContext, TyCoVar, Coercion)-substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co-  = (LC subst' lc_env, tv', co')-  where-    (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co---- | The \"lifting\" operation which substitutes coercions for type---   variables in a type to produce a coercion.------   For the inverse operation, see 'liftCoMatch'-ty_co_subst :: LiftingContext -> Role -> Type -> Coercion-ty_co_subst !lc role ty-    -- !lc: making this function strict in lc allows callers to-    -- pass its two components separately, rather than boxing them.-    -- Unfortunately, Boxity Analysis concludes that we need lc boxed-    -- because it's used that way in liftCoSubstTyVarBndrUsing.-  = go role ty-  where-    go :: Role -> Type -> Coercion-    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" $-                              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)-    go r (FunTy af w t1 t2) = mkFunCo1 r af (go Nominal w) (go r t1) (go r t2)-    go r t@(ForAllTy (Bndr v _) ty)-       = let (lc', v', h) = liftCoSubstVarBndr lc v-             body_co = ty_co_subst lc' r ty in-         if isTyVar v' || almostDevoidCoVarOfCo v' body_co-           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo-           -- imposes an extra restriction on where a covar can appear. See last-           -- wrinkle in Note [Unused coercion variable in ForAllCo].-           -- We specifically check for this and panic because we know that-           -- there's a hole in the type system here, and we'd rather panic than-           -- fall into it.-         then mkForAllCo v' h body_co-         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)-    go r ty@(LitTy {})     = assert (r == Nominal) $-                             mkNomReflCo ty-    go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)-                                                        (substRightCo lc co)-    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)-                                                  (substRightCo lc co)-      where kco = go Nominal (coercionType co)--    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))-                                  (substTy (lcSubstLeft  lc) ty)-                                  (substTy (lcSubstRight lc) ty)--{--Note [liftCoSubstTyVar]-~~~~~~~~~~~~~~~~~~~~~~~~~-This function can fail if a coercion in the environment is of too low a role.--liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and-also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting-lemma guarantees that the roles work out. If we fail in this-case, we really should panic -- something is deeply wrong. But, in matchAxiom,-failing is fine. matchAxiom is trying to find a set of coercions-that match, but it may fail, and this is healthy behavior.--}---- See Note [liftCoSubstTyVar]-liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion-liftCoSubstTyVar (LC subst env) r v-  | Just co_arg <- lookupVarEnv env v-  = downgradeRole_maybe r (coercionRole co_arg) co_arg--  | otherwise-  = Just $ mkReflCo r (substTyVar subst v)--{- Note [liftCoSubstVarBndr]-   ~~~~~~~~~~~~~~~~~~~~~~~~~-callback:-  'liftCoSubstVarBndrUsing' needs to be general enough to work in two-  situations:--    - in this module, which manipulates 'Coercion's, and-    - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain-      a coercion as well as a type.--  To achieve this, we require that the return type of the 'callback' function-  contain a coercion within it. This is witnessed by the first argument-  to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve-  the coercion inside the return type. Thus:--    - in this module, we simply pass 'id' as the getter,-    - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter.--liftCoSubstTyVarBndrUsing:-  Given-    forall tv:k. t-  We want to get-    forall (tv:k1) (kind_co :: k1 ~ k2) body_co--  We lift the kind k to get the kind_co-    kind_co = ty_co_subst k :: k1 ~ k2--  Now in the LiftingContext, we add the new mapping-    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)--liftCoSubstCoVarBndrUsing:-  Given-    forall cv:(s1 ~ s2). t-  We want to get-    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co--  We lift s1 and s2 respectively to get-    eta1 :: s1' ~ t1-    eta2 :: s2' ~ t2-  And-    kind_co = TyConAppCo Nominal (~#) eta1 eta2--  Now in the liftingContext, we add the new mapping-    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)--}---- See Note [liftCoSubstVarBndr]-liftCoSubstVarBndr :: LiftingContext -> TyCoVar-                   -> (LiftingContext, TyCoVar, Coercion)-liftCoSubstVarBndr lc tv-  = liftCoSubstVarBndrUsing id callback lc tv-  where-    callback lc' ty' = ty_co_subst lc' Nominal ty'---- the callback must produce a nominal coercion-liftCoSubstVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter-                        -> (LiftingContext -> Type -> r) -- ^ callback-                        -> LiftingContext -> TyCoVar-                        -> (LiftingContext, TyCoVar, r)-liftCoSubstVarBndrUsing view_co fun lc old_var-  | isTyVar old_var-  = liftCoSubstTyVarBndrUsing view_co fun lc old_var-  | otherwise-  = liftCoSubstCoVarBndrUsing view_co fun lc old_var---- Works for tyvar binder-liftCoSubstTyVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter-                          -> (LiftingContext -> Type -> r) -- ^ callback-                          -> LiftingContext -> TyVar-                          -> (LiftingContext, TyVar, r)-liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var-  = assert (isTyVar old_var) $-    ( LC (subst `extendSubstInScope` new_var) new_cenv-    , new_var, stuff )-  where-    old_kind = tyVarKind old_var-    stuff    = fun lc old_kind-    eta      = view_co stuff-    k1       = coercionLKind eta-    new_var  = uniqAway (getSubstInScope subst) (setVarType old_var k1)--    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta-               -- :: new_var ~ new_var |> eta-    new_cenv = extendVarEnv cenv old_var lifted---- Works for covar binder-liftCoSubstCoVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter-                          -> (LiftingContext -> Type -> r) -- ^ callback-                          -> LiftingContext -> CoVar-                          -> (LiftingContext, CoVar, r)-liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var-  = assert (isCoVar old_var) $-    ( LC (subst `extendSubstInScope` new_var) new_cenv-    , new_var, stuff )-  where-    old_kind = coVarKind old_var-    stuff    = fun lc old_kind-    eta      = view_co stuff-    k1       = coercionLKind eta-    new_var  = uniqAway (getSubstInScope subst) (setVarType old_var k1)--    -- old_var :: s1  ~r s2-    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)-    -- eta1    :: s1' ~r t1-    -- eta2    :: s2' ~r t2-    -- co1     :: s1' ~r s2'-    -- co2     :: t1  ~r t2-    -- lifted  :: co1 ~N co2--    role   = coVarRole old_var-    eta'   = downgradeRole role Nominal eta-    eta1   = mkSelCo (SelTyCon 2 role) eta'-    eta2   = mkSelCo (SelTyCon 3 role) eta'--    co1     = mkCoVarCo new_var-    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2-    lifted  = mkProofIrrelCo Nominal eta co1 co2--    new_cenv = extendVarEnv cenv old_var lifted---- | Is a var in the domain of a lifting context?-isMappedByLC :: TyCoVar -> LiftingContext -> Bool-isMappedByLC tv (LC _ env) = tv `elemVarEnv` env---- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1--- If [a |-> (g1, g2)] is in the substitution, substitute a for g1-substLeftCo :: LiftingContext -> Coercion -> Coercion-substLeftCo lc co-  = substCo (lcSubstLeft lc) co---- Ditto, but for t2 and g2-substRightCo :: LiftingContext -> Coercion -> Coercion-substRightCo lc co-  = substCo (lcSubstRight lc) co---- | Apply "sym" to all coercions in a 'LiftCoEnv'-swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv-swapLiftCoEnv = mapVarEnv mkSymCo--lcSubstLeft :: LiftingContext -> Subst-lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env--lcSubstRight :: LiftingContext -> Subst-lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env--liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst-liftEnvSubstLeft = liftEnvSubst pFst--liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst-liftEnvSubstRight = liftEnvSubst pSnd--liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst-liftEnvSubst selector subst lc_env-  = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst-  where-    pairs            = nonDetUFMToList lc_env-                       -- It's OK to use nonDetUFMToList here because we-                       -- immediately forget the ordering by creating-                       -- a VarEnv-    (tpairs, cpairs) = partitionWith ty_or_co pairs-    -- Make sure the in-scope set is wide enough to cover the range of the-    -- substitution (#22235).-    in_scope         = mkInScopeSet $-                       tyCoVarsOfTypes (map snd tpairs) `unionVarSet`-                       tyCoVarsOfCos (map snd cpairs)-    tenv             = mkVarEnv_Directly tpairs-    cenv             = mkVarEnv_Directly cpairs--    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)-    ty_or_co (u, co)-      | Just equality_co <- isCoercionTy_maybe equality_ty-      = Right (u, equality_co)-      | otherwise-      = Left (u, equality_ty)-      where-        equality_ty = selector (coercionKind co)---- | Extract the underlying substitution from the LiftingContext-lcSubst :: LiftingContext -> Subst-lcSubst (LC subst _) = subst---- | Get the 'InScopeSet' from a 'LiftingContext'-lcInScopeSet :: LiftingContext -> InScopeSet-lcInScopeSet (LC subst _) = getSubstInScope subst--{--%************************************************************************-%*                                                                      *-            Sequencing on coercions-%*                                                                      *-%************************************************************************--}--seqMCo :: MCoercion -> ()-seqMCo MRefl    = ()-seqMCo (MCo co) = seqCo co--seqCo :: Coercion -> ()-seqCo (Refl ty)                 = seqType ty-seqCo (GRefl r ty mco)          = r `seq` seqType ty `seq` seqMCo mco-seqCo (TyConAppCo r tc cos)     = r `seq` tc `seq` seqCos cos-seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2-seqCo (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k-                                                       `seq` seqCo co-seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq`-                                    seqCo w `seq` seqCo co1 `seq` seqCo co2-seqCo (CoVarCo cv)              = cv `seq` ()-seqCo (HoleCo h)                = coHoleCoVar h `seq` ()-seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos-seqCo (UnivCo p r t1 t2)-  = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2-seqCo (SymCo co)                = seqCo co-seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2-seqCo (SelCo n co)              = n `seq` seqCo co-seqCo (LRCo lr co)              = lr `seq` seqCo co-seqCo (InstCo co arg)           = seqCo co `seq` seqCo arg-seqCo (KindCo co)               = seqCo co-seqCo (SubCo co)                = seqCo co-seqCo (AxiomRuleCo _ cs)        = seqCos cs--seqProv :: UnivCoProvenance -> ()-seqProv (PhantomProv co)    = seqCo co-seqProv (ProofIrrelProv co) = seqCo co-seqProv (PluginProv _)      = ()-seqProv (CorePrepProv _)    = ()--seqCos :: [Coercion] -> ()-seqCos []       = ()-seqCos (co:cos) = seqCo co `seq` seqCos cos--{--%************************************************************************-%*                                                                      *-             The kind of a type, and of a coercion-%*                                                                      *-%************************************************************************--}---- | Apply 'coercionKind' to multiple 'Coercion's-coercionKinds :: [Coercion] -> Pair [Type]-coercionKinds tys = sequenceA $ map coercionKind tys---- | Get a coercion's kind and role.-coercionKindRole :: Coercion -> (Pair Type, Role)-coercionKindRole co = (coercionKind co, coercionRole co)--coercionType :: Coercion -> Type-coercionType co = case coercionKindRole co of-  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2----------------------- | If it is the case that------ > c :: (t1 ~ t2)------ i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.--coercionKind :: Coercion -> Pair Type-coercionKind co = Pair (coercionLKind co) (coercionRKind co)--coercionLKind :: Coercion -> Type-coercionLKind co-  = go co-  where-    go (Refl ty)                 = ty-    go (GRefl _ ty _)            = ty-    go (TyConAppCo _ tc cos)     = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)           = mkAppTy (go co1) (go co2)-    go (ForAllCo tv1 _ co1)      = mkTyCoInvForAllTy tv1 (go co1)-    go (FunCo { fco_afl = af, fco_mult = mult, fco_arg = arg, fco_res = res})-       {- See Note [FunCo] -}    = FunTy { ft_af = af, ft_mult = go mult-                                         , ft_arg = go arg, ft_res = go res }-    go (CoVarCo cv)              = coVarLType cv-    go (HoleCo h)                = coVarLType (coHoleCoVar h)-    go (UnivCo _ _ ty1 _)        = ty1-    go (SymCo co)                = coercionRKind co-    go (TransCo co1 _)           = go co1-    go (LRCo lr co)              = pickLR lr (splitAppTy (go co))-    go (InstCo aco arg)          = go_app aco [go arg]-    go (KindCo co)               = typeKind (go co)-    go (SubCo co)                = go co-    go (SelCo d co)              = getNthFromType d (go co)-    go (AxiomInstCo ax ind cos)  = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)      = pFst $ expectJust "coercionKind" $-                                   coaxrProves ax $ map coercionKind cos--    go_ax_inst ax ind tys-      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                   , cab_lhs = lhs } <- coAxiomNthBranch ax ind-      , let (tys1, cotys1) = splitAtList tvs tys-            cos1           = map stripCoercionTy cotys1-      = assert (tys `equalLength` (tvs ++ cvs)) $-                  -- Invariant of AxiomInstCo: cos should-                  -- exactly saturate the axiom branch-        substTyWith tvs tys1       $-        substTyWithCoVars cvs cos1 $-        mkTyConApp (coAxiomTyCon ax) lhs--    go_app :: Coercion -> [Type] -> Type-    -- Collect up all the arguments and apply all at once-    -- See Note [Nested InstCos]-    go_app (InstCo co arg) args = go_app co (go arg:args)-    go_app co              args = piResultTys (go co) args--getNthFromType :: HasDebugCallStack => CoSel -> Type -> Type-getNthFromType (SelFun fs) ty-  | Just (_af, mult, arg, res) <- splitFunTy_maybe ty-  = getNthFun fs mult arg res--getNthFromType (SelTyCon n _) ty-  | Just args <- tyConAppArgs_maybe ty-  = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $-    args `getNth` n--getNthFromType SelForAll ty       -- Works for both tyvar and covar-  | Just (tv,_) <- splitForAllTyCoVar_maybe ty-  = tyVarKind tv--getNthFromType cs ty-  = pprPanic "getNthFromType" (ppr cs $$ ppr ty)--coercionRKind :: Coercion -> Type-coercionRKind co-  = go co-  where-    go (Refl ty)                 = ty-    go (GRefl _ ty MRefl)        = ty-    go (GRefl _ ty (MCo co1))    = mkCastTy ty co1-    go (TyConAppCo _ tc cos)     = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)           = mkAppTy (go co1) (go co2)-    go (CoVarCo cv)              = coVarRType cv-    go (HoleCo h)                = coVarRType (coHoleCoVar h)-    go (FunCo { fco_afr = af, fco_mult = mult, fco_arg = arg, fco_res = res})-       {- See Note [FunCo] -}    = FunTy { ft_af = af, ft_mult = go mult-                                         , ft_arg = go arg, ft_res = go res }-    go (UnivCo _ _ _ ty2)        = ty2-    go (SymCo co)                = coercionLKind co-    go (TransCo _ co2)           = go co2-    go (LRCo lr co)              = pickLR lr (splitAppTy (go co))-    go (InstCo aco arg)          = go_app aco [go arg]-    go (KindCo co)               = typeKind (go co)-    go (SubCo co)                = go co-    go (SelCo d co)              = getNthFromType d (go co)-    go (AxiomInstCo ax ind cos)  = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)      = pSnd $ expectJust "coercionKind" $-                                   coaxrProves ax $ map coercionKind cos--    go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar-       | isGReflCo k_co           = mkTyCoInvForAllTy tv1 (go co1)-         -- kind_co always has kind @Type@, thus @isGReflCo@-       | otherwise                = go_forall empty_subst co-       where-         empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co)--    go_ax_inst ax ind tys-      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                   , cab_rhs = rhs } <- coAxiomNthBranch ax ind-      , let (tys2, cotys2) = splitAtList tvs tys-            cos2           = map stripCoercionTy cotys2-      = assert (tys `equalLength` (tvs ++ cvs)) $-                  -- Invariant of AxiomInstCo: cos should-                  -- exactly saturate the axiom branch-        substTyWith tvs tys2 $-        substTyWithCoVars cvs cos2 rhs--    go_app :: Coercion -> [Type] -> Type-    -- Collect up all the arguments and apply all at once-    -- See Note [Nested InstCos]-    go_app (InstCo co arg) args = go_app co (go arg:args)-    go_app co              args = piResultTys (go co) args--    go_forall subst (ForAllCo tv1 k_co co)-      -- See Note [Nested ForAllCos]-      | isTyVar tv1-      = mkInfForAllTy tv2 (go_forall subst' co)-      where-        k2  = coercionRKind k_co-        tv2 = setTyVarKind tv1 (substTy subst k2)-        subst' | isGReflCo k_co = extendSubstInScope subst tv1-                 -- kind_co always has kind @Type@, thus @isGReflCo@-               | otherwise      = extendTvSubst (extendSubstInScope subst tv2) tv1 $-                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co--    go_forall subst (ForAllCo cv1 k_co co)-      | isCoVar cv1-      = mkTyCoInvForAllTy cv2 (go_forall subst' co)-      where-        k2    = coercionRKind k_co-        r     = coVarRole cv1-        k_co' = downgradeRole r Nominal k_co-        eta1  = mkSelCo (SelTyCon 2 r) k_co'-        eta2  = mkSelCo (SelTyCon 3 r) k_co'--        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)-        -- k1    = t1 ~r t2-        -- k2    = s1 ~r s2-        -- cv1  :: t1 ~r t2-        -- cv2  :: s1 ~r s2-        -- eta1 :: t1 ~r s1-        -- eta2 :: t2 ~r s2-        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2--        cv2     = setVarType cv1 (substTy subst k2)-        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)-        subst'  | isReflCo k_co = extendSubstInScope subst cv1-                | otherwise     = extendCvSubst (extendSubstInScope subst cv2)-                                                cv1 n_subst--    go_forall subst other_co-      -- when other_co is not a ForAllCo-      = substTy subst (go other_co)--{---Note [Nested ForAllCos]-~~~~~~~~~~~~~~~~~~~~~~~--Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an-co)...) )`.   We do not want to perform `n` single-type-variable-substitutions over the kind of `co`; rather we want to do one substitution-which substitutes for all of `a1`, `a2` ... simultaneously.  If we do one-at a time we get the performance hole reported in #11735.--Solution: gather up the type variables for nested `ForAllCos`, and-substitute for them all at once.  Remarkably, for #11735 this single-change reduces /total/ compile time by a factor of more than ten.---}---- | Retrieve the role from a coercion.-coercionRole :: Coercion -> Role-coercionRole = go-  where-    go (Refl _) = Nominal-    go (GRefl r _ _) = r-    go (TyConAppCo r _ _) = r-    go (AppCo co1 _) = go co1-    go (ForAllCo _ _ co) = go co-    go (FunCo { fco_role = r }) = r-    go (CoVarCo cv) = coVarRole cv-    go (HoleCo h)   = coVarRole (coHoleCoVar h)-    go (AxiomInstCo ax _ _) = coAxiomRole ax-    go (UnivCo _ r _ _)  = r-    go (SymCo co) = go co-    go (TransCo co1 _co2) = go co1-    go (SelCo SelForAll      _co) = Nominal-    go (SelCo (SelTyCon _ r) _co) = r-    go (SelCo (SelFun fs)     co) = funRole (coercionRole co) fs-    go (LRCo {}) = Nominal-    go (InstCo co _) = go co-    go (KindCo {}) = Nominal-    go (SubCo _) = Representational-    go (AxiomRuleCo ax _) = coaxrRole ax--{--Note [Nested InstCos]-~~~~~~~~~~~~~~~~~~~~~-In #5631 we found that 70% of the entire compilation time was-being spent in coercionKind!  The reason was that we had-   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos-where-   g :: forall a1 a2 .. a100. phi-If we deal with the InstCos one at a time, we'll do this:-   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'-   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst-But this is a *quadratic* algorithm, and the blew up #5631.-So it's very important to do the substitution simultaneously;-cf Type.piResultTys (which in fact we call here).---}---- | 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 Phantom          = \ty1 ty2 ->-  let ki1 = typeKind ty1-      ki2 = typeKind ty2-  in-  TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]---- | Creates a primitive type equality predicate.--- 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---- | 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 type equality predicate with explicit kinds-mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type-mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]---- | Creates a primitive representational type equality predicate--- with explicit kinds-mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type-mkHeteroReprPrimEqPred k1 k2 ty1 ty2-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]--mkReprPrimEqPred :: Type -> Type -> Type-mkReprPrimEqPred ty1  ty2-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind 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--- AppCos might yield different kinds. See Note [EtaAppCo] in--- "GHC.Core.Coercion.Opt".-buildCoercion :: Type -> Type -> CoercionN-buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2-  where-    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2-               | Just ty2' <- coreView ty2 = go ty1 ty2'--    go (CastTy ty1 co) ty2-      = let co' = go ty1 ty2-            r = coercionRole co'-        in  mkCoherenceLeftCo r ty1 co co'--    go ty1 (CastTy ty2 co)-      = let co' = go ty1 ty2-            r = coercionRole co'-        in  mkCoherenceRightCo r ty2 co co'--    go ty1@(TyVarTy tv1) _tyvarty-      = assert (case _tyvarty of-                  { TyVarTy tv2 -> tv1 == tv2-                  ; _           -> False      }) $-        mkNomReflCo ty1--    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })-       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })-      = assert (af1 == af2) $-        mkFunCo1 Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2)--    go (TyConApp tc1 args1) (TyConApp tc2 args2)-      = assert (tc1 == tc2) $-        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)--    go (AppTy ty1a ty1b) ty2-      | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2-      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)--    go ty1 (AppTy ty2a ty2b)-      | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1-      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)--    go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)-      | isTyVar tv1-      = assert (isTyVar tv2) $-        mkForAllCo tv1 kind_co (go ty1 ty2')-      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)-            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co-            ty2'     = substTyWithInScope in_scope [tv2]-                         [mkTyVarTy tv1 `mkCastTy` kind_co]-                         ty2--    go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)-      = assert (isCoVar cv1 && isCoVar cv2) $-        mkForAllCo cv1 kind_co (go ty1 ty2')-      where s1 = varType cv1-            s2 = varType cv2-            kind_co = go s1 s2--            -- s1 = t1 ~r t2-            -- s2 = t3 ~r t4-            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)-            -- eta1 :: t1 ~r t3-            -- eta2 :: t2 ~r t4--            r    = coVarRole cv1-            kind_co' = downgradeRole r Nominal kind_co-            eta1 = mkSelCo (SelTyCon 2 r) kind_co'-            eta2 = mkSelCo (SelTyCon 3 r) kind_co'--            subst = mkEmptySubst $ mkInScopeSet $-                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co-            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`-                                                       mkCoVarCo cv1 `mkTransCo`-                                                       eta2)-                            ty2--    go ty1@(LitTy lit1) _lit2-      = assert (case _lit2 of-                  { LitTy lit2 -> lit1 == lit2-                  ; _          -> False        }) $-        mkNomReflCo ty1--    go (CoercionTy co1) (CoercionTy co2)-      = mkProofIrrelCo Nominal kind_co co1 co2-      where-        kind_co = go (coercionType co1) (coercionType co2)--    go ty1 ty2-      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2-                                           , ppr ty1, ppr ty2 ])---{--%************************************************************************-%*                                                                      *-       Coercion holes-%*                                                                      *-%************************************************************************--}--has_co_hole_ty :: Type -> Monoid.Any-has_co_hole_co :: Coercion -> Monoid.Any-(has_co_hole_ty, _, has_co_hole_co, _)-  = foldTyCo folder ()-  where-    folder = TyCoFolder { tcf_view  = noView-                        , tcf_tyvar = const2 (Monoid.Any False)-                        , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = const2 (Monoid.Any True)-                        , tcf_tycobinder = const2-                        }---- | Is there a coercion hole in this type?-hasCoercionHoleTy :: Type -> Bool-hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty---- | Is there a 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-                        }---- | Set the type of a 'CoercionHole'-setCoHoleType :: CoercionHole -> Type -> CoercionHole-setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t)+        coVarKind, coVarTypesRole, coVarRole,+        coercionType, mkCoercionType,+        coercionKind, coercionLKind, coercionRKind,coercionKinds,+        coercionRole, coercionKindRole,++        -- ** Constructing coercions+        mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo,+        mkCoVarCo, mkCoVarCos,+        mkAxInstCo, mkUnbranchedAxInstCo,+        mkAxInstRHS, mkUnbranchedAxInstRHS,+        mkAxInstLHS, mkUnbranchedAxInstLHS,+        mkPiCo, mkPiCos, mkCoCast,+        mkSymCo, mkTransCo,+        mkSelCo, mkSelCoResRole, getNthFun, selectFromType, mkLRCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,+        mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,+        mkNakedFunCo,+        mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos,+        mkPhantomCo, mkAxiomCo,+        mkHoleCo, mkUnivCo, mkSubCo,+        mkProofIrrelCo,+        downgradeRole,+        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,+        mkKindCo,+        castCoercionKind, castCoercionKind1, castCoercionKind2,++        -- ** Decomposition+        instNewTyCon_maybe,++        NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper,+        topNormaliseNewType_maybe, topNormaliseTypeX,++        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,+        splitAppCo_maybe,+        splitFunCo_maybe,+        splitForAllCo_maybe,+        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,++        tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,+        tyConRoleListX, tyConRoleListRepresentational, funRole,+        pickLR,++        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,+        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,+        mkCoherenceRightMCo,++        coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,+        mkFunResMCo, mkPiMCos,+        isReflMCo, checkReflexiveMCo,++        -- ** Coercion variables+        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,++        -- ** Free variables+        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,+        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,+        coercionSize, anyFreeVarsOfCo,++        -- ** Substitution+        CvSubstEnv, emptyCvSubstEnv,+        lookupCoVar,+        substCo, substCos, substCoVar, substCoVars, substCoWith,+        substCoVarBndr,+        extendTvSubstAndInScope, getCvSubstEnv,++        -- ** Lifting+        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,+        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,+        liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,+        updateLCSubst,++        mkSubstLiftingContext, liftingContextSubst, zapLiftingContext,+        lcLookupCoVar, lcInScopeSet,++        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,+        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,++        -- ** Comparison+        eqCoercion, eqCoercionX,++        -- ** Forcing evaluation of coercions+        seqCo,++        -- * Pretty-printing+        pprCo, pprParendCo,+        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,+        pprCoAxBranchUser, tidyCoAxBndrsForUser,+        etaExpandCoAxBranch,++        -- * Tidying+        tidyCo, tidyCos,++        -- * Other+        promoteCoercion, buildCoercion,++        multToCo, mkRuntimeRepCo,++        hasCoercionHole,+        setCoHoleType+       ) where++import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)++import GHC.Prelude++import GHC.Iface.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst+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+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name hiding ( varName )+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Data.FastString+import GHC.Data.Pair+import GHC.Types.SrcLoc+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Data.List.SetOps+import GHC.Data.Maybe+import GHC.Types.Unique.FM+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Monad (foldM, zipWithM)+import Data.Function ( on )+import Data.Char( isDigit )+import qualified Data.Monoid as Monoid+import Data.List.NonEmpty ( NonEmpty (..) )+import Control.DeepSeq++{-+%************************************************************************+%*                                                                      *+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom.  If there are+     -- any left over, we use AppCo.  See+     -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep++\subsection{Coercion variables}+%*                                                                      *+%************************************************************************+-}++coVarName :: CoVar -> Name+coVarName = varName++setCoVarUnique :: CoVar -> Unique -> CoVar+setCoVarUnique = setVarUnique++setCoVarName :: CoVar -> Name -> CoVar+setCoVarName   = setVarName++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing CoAxioms+%*                                                                      *+%************************************************************************++Defined here to avoid module loops. CoAxiom is loaded very early on.++-}++etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)+-- Return the (tvs,lhs,rhs) after eta-expanding,+-- to the way in which the axiom was originally written+-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom+etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs+                                , cab_eta_tvs = eta_tvs+                                , cab_lhs = lhs+                                , cab_rhs = rhs })+  -- ToDo: what about eta_cvs?+  = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys)+ where+    eta_tys = mkTyVarTys eta_tvs++pprCoAxiom :: CoAxiom br -> SDoc+-- Used in debug-printing only+pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })+  = hang (text "axiom" <+> ppr ax)+       2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))++pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc+-- Used when printing injectivity errors (FamInst.reportInjectivityErrors)+-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch)+-- This happens in error messages: don't print the RHS of a data+--   family axiom, which is meaningless to a user+pprCoAxBranchUser tc br+  | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br+  | otherwise            = pprCoAxBranch    tc br++pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc+-- Print the family-instance equation when reporting+--   a conflict between equations (FamInst.conflictInstErr)+-- For type families the RHS is important; for data families not so.+--   Indeed for data families the RHS is a mysterious internal+--   type constructor, so we suppress it (#14179)+-- See FamInstEnv Note [Family instance overlap conflicts]+pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs+  where+    pp_rhs _ _ = empty++pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc+pprCoAxBranch = ppr_co_ax_branch ppr_rhs+  where+    ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs++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') :|+         -- 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+           , ppUnless (null incomps) $ whenPprDebug $+             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) :+    []+  where+    incomps = coAxBranchIncomps branch+    loc = coAxBranchSpan branch+    pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)+           | otherwise         = text "in" <+> ppr loc++    -- Eta-expand LHS and RHS types, because sometimes data family+    -- instances are eta-reduced.+    -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.+    (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch++    pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)+                             (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs)++    (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs++tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])+-- Tidy wildcards "_1", "_2" to "_", and do not return them+-- in the list of binders to be printed+-- This is so that in error messages we see+--     forall a. F _ [a] _ = ...+-- rather than+--     forall a _1 _2. F _1 [a] _2 = ...+--+-- This is a rather disgusting function+-- See Note [Wildcard names] in GHC.Tc.Gen.HsType+tidyCoAxBndrsForUser init_env tcvs+  = (tidy_env, reverse tidy_bndrs)+  where+    (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs++    tidy_one (env@(occ_env, subst), rev_bndrs') bndr+      | is_wildcard bndr = (env_wild, rev_bndrs')+      | otherwise        = (env',     bndr' : rev_bndrs')+      where+        (env', bndr') = tidyVarBndr env bndr+        env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)+        wild_bndr = setVarName bndr $+                    tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_"))+                    -- Tidy the binder to "_"++    is_wildcard :: Var -> Bool+    is_wildcard tv = case occNameString (getOccName tv) of+                       ('_' : rest) -> all isDigit rest+                       _            -> False+++{- *********************************************************************+*                                                                      *+              MCoercion+*                                                                      *+********************************************************************* -}++coToMCo :: Coercion -> MCoercion+-- Convert a coercion to a MCoercion,+-- It's not clear whether or not isReflexiveCo would be better here+--    See #19815 for a bit of data and discussion on this point+coToMCo co | isReflCo co = MRefl+           | otherwise   = MCo co++checkReflexiveMCo :: MCoercion -> MCoercion+checkReflexiveMCo MRefl                       = MRefl+checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl+                           | otherwise        = MCo co++-- | Tests if this MCoercion is obviously generalized reflexive+-- Guaranteed to work very quickly.+isGReflMCo :: MCoercion -> Bool+isGReflMCo MRefl = True+isGReflMCo (MCo co) | isGReflCo co = True+isGReflMCo _ = False++-- | Make a generalized reflexive coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflCo r ty mco+  | isGReflMCo mco = if r == Nominal then Refl ty+                                     else GRefl r ty MRefl+  | otherwise+  = -- I'd like to have this assert, but sadly it's not true during type+    -- inference because the types are not fully zonked+    -- assertPpr (case mco of+    --              MCo co -> typeKind ty `eqType` coercionLKind co+    --              MRefl  -> True)+    --          (vcat [ text "ty" <+> ppr ty <+> dcolon <+> ppr (typeKind ty)+    --                , case mco of+    --                     MCo co -> text "co" <+> ppr co+    --                                  <+> dcolon <+> ppr (coercionKind co)+    --                     MRefl  -> text "MRefl"+    --                , callStackDoc ]) $+    GRefl r ty mco++mkGReflMCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion+mkGReflMCo r ty co = mkGReflCo r ty (MCo co)++-- | Compose two MCoercions via transitivity+mkTransMCo :: MCoercion -> MCoercion -> MCoercion+mkTransMCo MRefl     co2       = co2+mkTransMCo co1       MRefl     = co1+mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)++mkTransMCoL :: MCoercion -> Coercion -> MCoercion+mkTransMCoL MRefl     co2 = coToMCo co2+mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2)++mkTransMCoR :: Coercion -> MCoercion -> MCoercion+mkTransMCoR co1 MRefl     = coToMCo co1+mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2)++-- | Get the reverse of an 'MCoercion'+mkSymMCo :: MCoercion -> MCoercion+mkSymMCo MRefl    = MRefl+mkSymMCo (MCo co) = MCo (mkSymCo co)++-- | Cast a type by an 'MCoercion'+mkCastTyMCo :: Type -> MCoercion -> Type+mkCastTyMCo ty MRefl    = ty+mkCastTyMCo ty (MCo co) = ty `mkCastTy` co++mkPiMCos :: [Var] -> MCoercion -> MCoercion+mkPiMCos _ MRefl = MRefl+mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)++mkFunResMCo :: Id -> MCoercionR -> MCoercionR+mkFunResMCo _      MRefl    = MRefl+mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co)++mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflLeftMCo r ty MRefl    = mkReflCo r ty+mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co++mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflRightMCo r ty MRefl    = mkReflCo r ty+mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co++-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'+mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion+mkCoherenceRightMCo _ _  MRefl    co2 = co2+mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2++isReflMCo :: MCoercion -> Bool+isReflMCo MRefl = True+isReflMCo _     = False++{-+%************************************************************************+%*                                                                      *+        Destructing coercions+%*                                                                      *+%************************************************************************+-}++-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into+-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:+--+-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]+decomposeCo :: Arity -> Coercion+            -> Infinite Role  -- the roles of the output coercions+            -> [Coercion]+decomposeCo arity co rs+  = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]+     -- Remember, SelTyCon is zero-indexed++decomposeFunCo :: HasDebugCallStack+               => Coercion  -- Input coercion+               -> (CoercionN, Coercion, Coercion)+-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2)+-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2)+-- actually cow will be a Phantom coercion if the input is a Phantom coercion++decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 })+  = (w, co1, co2)+   -- Short-circuits the calls to mkSelCo++decomposeFunCo co+  = assertPpr all_ok (ppr co) $+    ( mkSelCo (SelFun SelMult) co+    , mkSelCo (SelFun SelArg) co+    , mkSelCo (SelFun SelRes) co )+  where+    Pair s1t1 s2t2 = coercionKind co+    all_ok = isFunTy s1t1 && isFunTy s2t2++{- Note [Pushing a coercion into a pi-type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this:+    (f |> co) t1 .. tn+Then we want to push the coercion into the arguments, so as to make+progress. For example of why you might want to do so, see Note+[Respecting definitional equality] in GHC.Core.TyCo.Rep.++This is done by decomposePiCos.  Specifically, if+    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)+then+    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn++Notes:++* k can be smaller than n! That is decomposePiCos can return *fewer*+  coercions than there are arguments (ie k < n), if the kind provided+  doesn't have enough binders.++* If there is a type error, we might see+       (f |> co) t1+  where co :: (forall a. ty) ~ (ty1 -> ty2)+  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.+  So decomposePiCos carefully tests both sides of the coercion to check+  they are both foralls or both arrows.  Not doing this caused #15343.+-}++decomposePiCos :: HasDebugCallStack+               => CoercionN -> Pair Type  -- Coercion and its kind+               -> [Type]+               -> ([CoercionN], CoercionN)+-- See Note [Pushing a coercion into a pi-type]+decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args+  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args+  where+    orig_subst = mkEmptySubst $ mkInScopeSet $+                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co++    go :: [CoercionN]      -- accumulator for argument coercions, reversed+       -> (Subst,Kind)  -- Lhs kind of coercion+       -> CoercionN        -- coercion originally applied to the function+       -> (Subst,Kind)  -- Rhs kind of coercion+       -> [Type]           -- Arguments to that function+       -> ([CoercionN], Coercion)+    -- Invariant:  co :: subst1(k1) ~ subst2(k2)++    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)+      | Just (a, t1) <- splitForAllTyCoVar_maybe k1+      , Just (b, t2) <- splitForAllTyCoVar_maybe k2+        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)+        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)+        --           a :: s1+        --           b :: s2+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]+      = let arg_co  = mkSelCo SelForAll (mkSymCo co)+            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)+            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)+            subst2' = extendTCvSubst subst2 b ty+        in+        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys++      | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1+      , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2+      , af1 == af2  -- Same sort of arrow+        -- know     co :: (s1 -> t1) ~ (s2 -> t2)+        --    function :: s1 -> t1+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1 ~ t2+      = let (_, sym_arg_co, res_co) = decomposeFunCo co+            -- It should be fine to ignore the multiplicity bit+            -- of the coercion for a Nominal coercion.+            arg_co = mkSymCo sym_arg_co+        in+        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys++      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)+      = go acc_arg_cos (zapSubst subst1, substTy subst1 k1)+                       co+                       (zapSubst subst2, substTy subst1 k2)+                       (ty:tys)++      -- tys might not be empty, if the left-hand type of the original coercion+      -- didn't have enough binders+    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)++-- | Extract a covar, if possible. This check is dirty. Be ashamed+-- of yourself. (It's dirty because it cares about the structure of+-- a coercion, which is morally reprehensible.)+getCoVar_maybe :: Coercion -> Maybe CoVar+getCoVar_maybe (CoVarCo cv) = Just cv+getCoVar_maybe _            = Nothing++multToCo :: Mult -> Coercion+multToCo r = mkNomReflCo r++-- first result has role equal to input; third result is Nominal+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+-- ^ Attempt to take a coercion application apart.+splitAppCo_maybe (AppCo co arg) = Just (co, arg)+splitAppCo_maybe (TyConAppCo r tc args)+  | args `lengthExceeds` tyConArity tc+  , Just (args', arg') <- snocView args+  = Just ( mkTyConAppCo r tc args', arg' )++  | not (tyConMustBeSaturated tc)+    -- Never create unsaturated type family apps!+  , Just (args', arg') <- snocView args+  , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg'+  = Just ( mkTyConAppCo r tc args', arg'' )+       -- Use mkTyConAppCo to preserve the invariant+       --  that identity coercions are always represented by Refl++splitAppCo_maybe co+  | Just (ty, r) <- isReflCo_maybe co+  , Just (ty1, ty2) <- splitAppTy_maybe ty+  = Just (mkReflCo r ty1, mkNomReflCo ty2)+splitAppCo_maybe _ = Nothing++-- Only used in specialise/Rules+splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res)+splitFunCo_maybe _ = Nothing++splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR+                              , fco_kind = k_co, fco_body = co })+  = Just (tv, vL, vR, k_co, co)+splitForAllCo_maybe co+  | Just (ty, r)        <- isReflCo_maybe co+  , Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty+  = Just (tcv, vis, vis, mkNomReflCo (varType tcv), mkReflCo r body_ty)+splitForAllCo_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder+splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_ty_maybe co+  | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co+  , isTyVar tv+  = Just stuff+splitForAllCo_ty_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder+splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_co_maybe co+  | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co+  , isCoVar cv+  = Just stuff+splitForAllCo_co_maybe _ = Nothing++-------------------------------------------------------+-- and some coercion kind stuff++coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type+coVarLType cv | (ty1, _, _) <- coVarTypesRole cv = ty1+coVarRType cv | (_, ty2, _) <- coVarTypesRole cv = ty2++coVarTypes :: HasDebugCallStack => CoVar -> Pair Type+coVarTypes cv | (ty1, ty2, _) <- coVarTypesRole cv = Pair ty1 ty2++coVarTypesRole :: HasDebugCallStack => CoVar -> (Type,Type,Role)+coVarTypesRole cv+ | Just (tc, [_,_,ty1,ty2]) <- splitTyConApp_maybe (varType cv)+ = (ty1, ty2, eqTyConRole tc)+ | otherwise+ = pprPanic "coVarTypesRole, non coercion variable"+            (ppr cv $$ ppr (varType cv))++coVarKind :: CoVar -> Type+coVarKind cv+  = assert (isCoVar cv )+    varType cv++coVarRole :: CoVar -> Role+coVarRole cv+  = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of+                   Just tc0 -> tc0+                   Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv))++eqTyConRole :: TyCon -> Role+-- Given (~#) or (~R#) return the Nominal or Representational respectively+eqTyConRole tc+  | tc `hasKey` eqPrimTyConKey+  = Nominal+  | tc `hasKey` eqReprPrimTyConKey+  = Representational+  | otherwise+  = pprPanic "eqTyConRole: unknown tycon" (ppr tc)++-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`+-- produce a coercion `rep_co :: r1 ~ r2`+-- But actually it is possible that+--     co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2)+-- or  co :: (t1 :: TYPE r1)       ~ (t2 :: CONSTRAINT r2)+-- or  co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2)+-- See Note [mkRuntimeRepCo]+mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion+mkRuntimeRepCo co+  = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $+    mkSelCo (SelTyCon 0 Nominal) kind_co+  where+    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2+    Pair k1 k2 = coercionKind kind_co++{- Note [mkRuntimeRepCo]+~~~~~~~~~~~~~~~~~~~~~~~~+Given+   class C a where { op :: Maybe a }+we will get an axiom+   axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2)+(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.)++Then we may call mkRuntimeRepCo on (axC ty), and that will return+   mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2++So mkSelCo needs to be happy with decomposing a coercion of kind+   CONSTRAINT r1 ~ TYPE r2++Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call`+in `mkSelCo`. See #23018 for a concrete example.  (In this context it's+important that TYPE and CONSTRAINT have the same arity and kind, not+merely that they are not-apart; otherwise SelCo would not make sense.)+-}++isReflCoVar_maybe :: Var -> Maybe Coercion+-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)+-- Works on all kinds of Vars, not just CoVars+isReflCoVar_maybe cv+  | isCoVar cv+  , Pair ty1 ty2 <- coVarTypes cv+  , ty1 `eqType` ty2+  = Just (mkReflCo (coVarRole cv) ty1)+  | otherwise+  = Nothing++-- | Tests if this coercion is obviously a generalized reflexive coercion.+-- Guaranteed to work very quickly.+isGReflCo :: Coercion -> Bool+isGReflCo (GRefl{}) = True+isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl+isGReflCo _         = False++-- | Tests if this coercion is obviously reflexive. Guaranteed to work+-- very quickly. Sometimes a coercion can be reflexive, but not obviously+-- so. c.f. 'isReflexiveCo'+isReflCo :: Coercion -> Bool+isReflCo (Refl{}) = True+isReflCo (GRefl _ _ mco) | isGReflMCo mco = True+isReflCo _ = False++-- | Returns the type coerced if this coercion is a generalized reflexive+-- coercion. Guaranteed to work very quickly.+isGReflCo_maybe :: Coercion -> Maybe (Type, Role)+isGReflCo_maybe (GRefl r ty _) = Just (ty, r)+isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)+isGReflCo_maybe _ = Nothing++-- | Returns the type coerced if this coercion is reflexive. Guaranteed+-- to work very quickly. Sometimes a coercion can be reflexive, but not+-- obviously so. c.f. 'isReflexiveCo_maybe'+isReflCo_maybe :: Coercion -> Maybe (Type, Role)+isReflCo_maybe (Refl ty) = Just (ty, Nominal)+isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflCo_maybe _ = Nothing++-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,+-- as it walks over the entire coercion.+isReflexiveCo :: Coercion -> Bool+isReflexiveCo = isJust . isReflexiveCo_maybe++-- | Extracts the coerced type from a reflexive coercion. This potentially+-- walks over the entire coercion, so avoid doing this in a loop.+isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)+isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)+isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflexiveCo_maybe co+  | ty1 `eqType` ty2+  = Just (ty1, r)+  | otherwise+  = Nothing+  where (Pair ty1 ty2, r) = coercionKindRole co+++{-+%************************************************************************+%*                                                                      *+            Building coercions+%*                                                                      *+%************************************************************************++These "smart constructors" maintain the invariants listed in the definition+of Coercion, and they perform very basic optimizations.++Note [Role twiddling functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a plethora of functions for twiddling roles:++mkSubCo: Requires a nominal input coercion and always produces a+representational output. This is used when you (the programmer) are sure you+know exactly that role you have and what you want.++downgradeRole_maybe: This function takes both the input role and the output role+as parameters. (The *output* role comes first!) It can only *downgrade* a+role -- that is, change it from N to R or P, or from R to P. This one-way+behavior is why there is the "_maybe". If an upgrade is requested, this+function produces Nothing. This is used when you need to change the role of a+coercion, but you're not sure (as you're writing the code) of which roles are+involved.++This function could have been written using coercionRole to ascertain the role+of the input. But, that function is recursive, and the caller of downgradeRole_maybe+often knows the input role. So, this is more efficient.++downgradeRole: This is just like downgradeRole_maybe, but it panics if the+conversion isn't a downgrade.++setNominalRole_maybe: This is the only function that can *upgrade* a coercion.+The result (if it exists) is always Nominal. The input can be at any role. It+works on a "best effort" basis, as it should never be strictly necessary to+upgrade a coercion during compilation. It is currently only used within GHC in+splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second+coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable+that splitAppCo_maybe is operating over a TyConAppCo that uses a+representational coercion. Hence the need for setNominalRole_maybe.+splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,+it is not absolutely critical that setNominalRole_maybe be complete.++Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom+UnivCos are perfectly type-safe, whereas representational and nominal ones are+not. (Nominal ones are no worse than representational ones, so this function *will*+change a UnivCo Representational to a UnivCo Nominal.)++Conal Elliott also came across a need for this function while working with the+GHC API, as he was decomposing Core casts. The Core casts use representational+coercions, as they must, but his use case required nominal coercions (he was+building a GADT). So, that's why this function is exported from this module.++One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as+appropriate? I (Richard E.) have decided not to do this, because upgrading a+role is bizarre and a caller should have to ask for this behavior explicitly.++-}++-- | Make a reflexive coercion+mkReflCo :: Role -> Type -> Coercion+mkReflCo Nominal ty = Refl ty+mkReflCo r       ty = GRefl r ty MRefl++-- | Make a representational reflexive coercion+mkRepReflCo :: Type -> Coercion+mkRepReflCo ty = GRefl Representational ty MRefl++-- | Make a nominal reflexive coercion+mkNomReflCo :: Type -> Coercion+mkNomReflCo = Refl++-- | Apply a type constructor to a list of coercions. It is the+-- caller's responsibility to get the roles correct on argument coercions.+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkTyConAppCo r tc cos+  | Just co <- tyConAppFunCo_maybe r tc cos+  = co++  -- Expand type synonyms+  | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos+  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos++  | Just tys_roles <- traverse isReflCo_maybe cos+  = mkReflCo r (mkTyConApp tc (map fst tys_roles))+  -- See Note [Refl invariant]++  | otherwise = TyConAppCo r tc cos++mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo takes no FunTyFlags; it works them out+mkFunCoNoFTF r w arg_co res_co+  = mkFunCo2 r afl afr w arg_co res_co+  where+    afl = chooseFunTyFlag argl_ty resl_ty+    afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++-- | Build a function 'Coercion' from two other 'Coercion's. That is,+-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@+-- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@.+-- This (most common) version takes a single FunTyFlag, which is used+--   for both fco_afl and ftf_afr of the FunCo+mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo r af w arg_co res_co+  = mkFunCo2 r af af w arg_co res_co++mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo does not check FunCo invariants (checkFunCo)+-- It's a historical vestige; See Note [No assertion check on mkFunCo]+mkNakedFunCo = mkFunCo++mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag+         -> CoercionN -> Coercion -> Coercion -> Coercion+-- This is the smart constructor for FunCo; it checks invariants+mkFunCo2 r afl afr w arg_co res_co+  -- See Note [No assertion check on mkFunCo]+  | Just (ty1, _) <- isReflCo_maybe arg_co+  , Just (ty2, _) <- isReflCo_maybe res_co+  , Just (w, _)   <- isReflCo_maybe w+  = mkReflCo r (mkFunTy afl w ty1 ty2)  -- See Note [Refl invariant]++  | otherwise+  = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+          , fco_mult = w, fco_arg = arg_co, fco_res = res_co }+++{- Note [No assertion check on mkFunCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have a checkFunCo assertion on mkFunCo, but during typechecking+we can (legitimately) have not-full-zonked types or coercion variables, so+the assertion spuriously fails (test T11480b is a case in point).  Lint+checks all these things anyway.++We used to get around the problem by calling mkNakedFunCo from within the+typechecker, which dodged the assertion check.  But then mkAppCo calls+mkTyConAppCo, which calls tyConAppFunCo_maybe, which calls mkFunCo.+Duplicating this stack of calls with "naked" versions of each seems too much.++-- Commented out: see Note [No assertion check on mkFunCo]+checkFunCo :: Role -> FunTyFlag -> FunTyFlag+           -> CoercionN -> Coercion -> Coercion+           -> Maybe SDoc+-- Checks well-formed-ness for FunCo+-- Used only in assertions and Lint+{-# NOINLINE checkFunCo #-}+checkFunCo _r afl afr _w arg_co res_co+  | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty)+  = Just (hang (text "Bad arg or res types") 2 pp_inputs)++  | afl == computed_afl+  , afr == computed_afr+  = Nothing+  | otherwise+  = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl+               , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr+               , pp_inputs ])+  where+    computed_afl = chooseFunTyFlag argl_ty resl_ty+    computed_afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++    pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty+                     , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty+                     , text "arg_co:" <+> ppr arg_co+                     , text "res_co:" <+> ppr res_co ]++    ok ty = isTYPEorCONSTRAINT (typeKind ty)+    pp_ty str ty = text str <> colon <+> hang (ppr ty)+                                            2 (dcolon <+> ppr (typeKind ty))+-}++-- | Apply a 'Coercion' to another 'Coercion'.+-- The second coercion must be Nominal, unless the first is Phantom.+-- If the first is Phantom, then the second can be either Phantom or Nominal.+mkAppCo :: Coercion     -- ^ :: t1 ~r t2+        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2+        -> Coercion     -- ^ :: t1 s1 ~r t2 s2+mkAppCo co arg+  | Just (ty1, r) <- isReflCo_maybe co+  , Just (ty2, _) <- isReflCo_maybe arg+  = mkReflCo r (mkAppTy ty1 ty2)++  | Just (ty1, r) <- isReflCo_maybe co+  , Just (tc, tys) <- splitTyConApp_maybe ty1+    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)+  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)+  where+    zip_roles (Inf r1 _)  []            = [downgradeRole r1 Nominal arg]+    zip_roles (Inf r1 rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys++mkAppCo (TyConAppCo r tc args) arg+  = case r of+      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])+      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])+        where new_role = tyConRolesRepresentational tc Inf.!! length args+              arg'     = downgradeRole new_role Nominal arg+      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])+mkAppCo co arg = AppCo co  arg+-- Note, mkAppCo is careful to maintain invariants regarding+-- where Refl constructors appear; see the comments in the definition+-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep.++-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.+-- See also 'mkAppCo'.+mkAppCos :: Coercion+         -> [Coercion]+         -> Coercion+mkAppCos co1 cos = foldl' mkAppCo co1 cos+++-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo v visL visR kind_co co+  | Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkTyCoForAllTy v visL ty)++  | 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+mkHomoForAllCos vs orig_co+  | Just (ty, r) <- isReflCo_maybe orig_co+  = mkReflCo r (mkTyCoForAllTys vs ty)+  | otherwise+  = foldr go orig_co vs+  where+    go (Bndr var vis) co+      = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co++-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;+--   the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)+-- The kind of the tycovar should be the left-hand kind of the kind coercion.+mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo_NoRefl tcv visL visR kind_co co+  = assertGoodForAllCo tcv visL visR kind_co co $+    assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $+    ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co }++assertGoodForAllCo :: HasDebugCallStack+                   =>  TyCoVar -> ForAllTyFlag -> ForAllTyFlag+                   -> CoercionN -> Coercion -> a -> a+-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep+assertGoodForAllCo tcv visL visR kind_co co+  | isTyVar tcv+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc++  | otherwise+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc+        -- The kind of the tycovar should be the left-hand kind of the kind coercion.+  . assertPpr (almostDevoidCoVarOfCo tcv co) doc+        -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  . assertPpr (visL == coreTyLamForAllTyFlag+            && visR == coreTyLamForAllTyFlag) doc+        -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  where+    tcv_type      = varType tcv+    kind_co_lkind = coercionLKind kind_co++    doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type+               , text "Vis:" <+> ppr visL <+> ppr visR+               , text "kind_co:" <+> ppr kind_co+               , text "kind_co_lkind" <+> ppr kind_co_lkind+               , text "body_co" <+> ppr co ]+++mkNakedForAllCo :: TyVar    -- Never a CoVar+                -> ForAllTyFlag -> ForAllTyFlag+                -> CoercionN -> Coercion -> Coercion+-- This version lacks the assertion checks.+-- Used during type checking when the arguments may (legitimately) not be zonked+-- and so the assertions might (bogusly) fail+-- NB: since the coercions are un-zonked, we can't really deal with+--     (FC6) and (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep.+--     Fortunately we don't have to: this function is needed only for /type/ variables.+mkNakedForAllCo tv visL visR kind_co co+  | assertPpr (isTyVar tv) (ppr tv) True+  , Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkForAllTy (Bndr tv visL) ty)+  | otherwise+  = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co }+++mkCoVarCo :: CoVar -> Coercion+-- cv :: s ~# t+-- See Note [mkCoVarCo]+mkCoVarCo cv = CoVarCo cv++mkCoVarCos :: [CoVar] -> [Coercion]+mkCoVarCos = map mkCoVarCo++{- Note [mkCoVarCo]+~~~~~~~~~~~~~~~~~~~+In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is+valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but+it's a relatively expensive test and perhaps better done in+optCoercion.  Not a big deal either way.+-}++mkAxInstCo :: Role+           -> CoAxiomRule   -- Always BranchedAxiom or UnbranchedAxiom+           -> [Type] -> [Coercion]+           -> Coercion+-- mkAxInstCo can legitimately be called over-saturated;+-- i.e. with more type arguments than the coercion requires+-- Only called with BranchedAxiom or UnbranchedAxiom+mkAxInstCo role axr tys cos+  | arity == n_tys = downgradeRole role ax_role $+                     AxiomCo axr (rtys `chkAppend` cos)+  | otherwise      = assert (arity < n_tys) $+                     downgradeRole role ax_role $+                     mkAppCos (AxiomCo axr (ax_args `chkAppend` cos))+                              leftover_args+  where+    (ax_role, branch)        = case coAxiomRuleBranch_maybe axr of+                                  Just (_tc, ax_role, branch) -> (ax_role, branch)+                                  Nothing -> pprPanic "mkAxInstCo" (ppr axr)+    n_tys                    = length tys+    arity                    = length (coAxBranchTyVars branch)+    arg_roles                = coAxBranchRoles branch+    rtys                     = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys+    (ax_args, leftover_args) = splitAt arity rtys++-- worker function+mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion+mkAxiomCo = AxiomCo++-- to be used only with unbranched axioms+mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched+                     -> [Type] -> [Coercion] -> Coercion+mkUnbranchedAxInstCo role ax tys cos+  = mkAxInstCo role (UnbranchedAxiom ax) tys cos++mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+-- Instantiate the axiom with specified types,+-- returning the instantiated RHS+-- A companion to mkAxInstCo:+--    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))+mkAxInstRHS ax index tys cos+  = assert (tvs `equalLength` tys1) $+    mkAppTys rhs' tys2+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    rhs'         = substTyWith tvs tys1 $+                   substTyWithCoVars cvs cos $+                   coAxBranchRHS branch++mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0++-- | Return the left-hand type of the axiom, when the axiom is instantiated+-- at the types given.+mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+mkAxInstLHS ax index tys cos+  = assert (tvs `equalLength` tys1) $+    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    lhs_tys      = substTysWith tvs tys1 $+                   substTysWithCoVars cvs cos $+                   coAxBranchLHS branch+    fam_tc       = coAxiomTyCon ax++-- | Instantiate the left-hand side of an unbranched axiom+mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0++-- | Make a coercion from a coercion hole+mkHoleCo :: CoercionHole -> Coercion+mkHoleCo h = HoleCo h++-- | Make a universal coercion between two arbitrary types.+mkUnivCo :: UnivCoProvenance+         -> [Coercion] -- ^ Coercions on which this depends+         -> Role       -- ^ role of the built coercion, "r"+         -> Type       -- ^ t1 :: k1+         -> Type       -- ^ t2 :: k2+         -> Coercion   -- ^ :: t1 ~r t2+mkUnivCo prov deps role ty1 ty2+  | ty1 `eqType` ty2 = mkReflCo role ty1+  | otherwise        = UnivCo { uco_prov = prov, uco_role = role+                              , uco_lty = ty1, uco_rty = ty2+                              , uco_deps = deps }++-- | Create a symmetric version of the given 'Coercion' that asserts+--   equality between the same types but in the other "direction", so+--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.+mkSymCo :: Coercion -> Coercion++-- Do a few simple optimizations, mainly to expose the underlying+-- constructors to other 'mk' functions.  E.g.+--   mkInstCo (mkSymCo (ForAllCo ...)) ty+-- We want to push the SymCo inside the ForallCo, so that we can instantiate+-- This can make a big difference.  E.g without coercion optimisation, GHC.Read+-- totally explodes; but when we push Sym inside ForAll, it's fine.+mkSymCo co | isReflCo co   = co+mkSymCo (SymCo co)         = co+mkSymCo (SubCo (SymCo co)) = SubCo co+mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co })+  | isReflCo kco           = co { fco_body = mkSymCo body_co }+mkSymCo co                 = SymCo co++-- | mkTransCo creates a new 'Coercion' by composing the two+--   given 'Coercion's transitively: (co1 ; co2)+mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion+mkTransCo co1 co2+   | isReflCo co1 = co2+   | isReflCo co2 = co1++   | GRefl r t1 (MCo kco1) <- co1+   , GRefl _ _  (MCo kco2) <- co2+   = GRefl r t1 (MCo $ mkTransCo kco1 kco2)++   | otherwise+   = TransCo co1 co2++--------------------+{- Note [mkSelCo precondition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To satisfy the Purely Kinded Type Invariant (PKTI), we require that+  in any call (mkSelCo cs co)+  * selectFromType cs (coercionLKind co) works+  * selectFromType cs (coercionRKind co) works+  * and hence coercionKind (SelCo cs co) works (PKTI)+-}++mkSelCo :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Coercion+-- See Note [mkSelCo precondition]+mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co++mkSelCo_maybe :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Maybe Coercion+-- Note [mkSelCo precondition]+mkSelCo_maybe cs co+  = assertPpr (good_call cs) bad_call_msg $+    go cs co+  where++    go SelForAll (ForAllCo { fco_kind = kind_co })+      = Just kind_co+      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)+      -- then (nth SelForAll co :: k1 ~N k2)+      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)+      -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4))++    go (SelFun fs) (FunCo _ _ _ w arg res)+      = Just (getNthFun fs w arg res)++    go (SelTyCon i r) (TyConAppCo r0 tc arg_cos)+      = assertPpr (r == tyConRole r0 tc i)+                  (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $+        Just (arg_cos `getNth` i)++    go cs (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo+      = do { co' <- go cs co; return (mkSymCo co') }++    go cs co+      | Just (ty, co_role) <- isReflCo_maybe co+      = Just (mkReflCo (mkSelCoResRole cs co_role) (selectFromType cs ty))+        -- mkSelCoreResRole: The role of the result may not be+        -- be equal to co_role, the role of co, per Note [SelCo].+        -- This was revealed by #23938.++      | Pair ty1 ty2 <- coercionKind co+      , let sty1    = selectFromType cs ty1+            sty2    = selectFromType cs ty2+            co_role = coercionRole co+      , sty1 `eqType` sty2+      = Just (mkReflCo (mkSelCoResRole cs co_role) sty1)+            -- Checking for fully reflexive-ness (by seeing if sty1=sty2)+            -- is worthwhile, because a non-Refl coercion `co` may well have a+            -- reflexive (SelCo cs co).+            -- E.g. co :: Either a b ~ Either a c+            --      Then (SubCo (SelTyCon 0) co) is reflexive++      | otherwise = Nothing++    ----------- Assertion checking --------------+    -- NB: using coercionKind requires Note [mkSelCo precondition]+    Pair ty1 ty2 = coercionKind co+    bad_call_msg = vcat [ text "Coercion =" <+> ppr co+                        , text "LHS ty =" <+> ppr ty1+                        , text "RHS ty =" <+> ppr ty2+                        , text "cs =" <+> ppr cs+                        , text "coercion role =" <+> ppr (coercionRole co) ]++    -- good_call checks the typing rules given in Note [SelCo]+    good_call SelForAll+      | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1+      , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2+      =  True++    good_call (SelFun {})+       = isFunTy ty1 && isFunTy ty2++    good_call (SelTyCon n r)+       | Just (tc1, tys1) <- splitTyConApp_maybe ty1+       , Just (tc2, tys2) <- splitTyConApp_maybe ty2+       , let { len1 = length tys1+             ; len2 = length tys2 }+       =  (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2))+                      -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo]+       && len1 == len2+       && n < len1+       && r == tyConRole (coercionRole co) tc1 n++    good_call _ = False++mkSelCoResRole :: CoSel -> Role -> Role+-- What is the role of (SelCo cs co), if co has role 'r'?+-- It is not just 'r'!+-- c.f. the SelCo case of coercionRole+mkSelCoResRole SelForAll       _ = Nominal+mkSelCoResRole (SelTyCon _ r') _ = r'+mkSelCoResRole (SelFun fs)     r = funRole r fs++-- | Extract the nth field of a FunCo+getNthFun :: FunSel+          -> a    -- ^ multiplicity+          -> a    -- ^ argument+          -> a    -- ^ result+          -> a    -- ^ One of the above three+getNthFun SelMult mult _   _   = mult+getNthFun SelArg _     arg _   = arg+getNthFun SelRes _     _   res = res++selectFromType :: HasDebugCallStack => CoSel -> Type -> Type+selectFromType (SelFun fs) ty+  | Just (_af, mult, arg, res) <- splitFunTy_maybe ty+  = getNthFun fs mult arg res++selectFromType (SelTyCon n _) ty+  | Just args <- tyConAppArgs_maybe ty+  = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $+    args `getNth` n++selectFromType SelForAll ty       -- Works for both tyvar and covar+  | Just (tv,_) <- splitForAllTyCoVar_maybe ty+  = tyVarKind tv++selectFromType cs ty+  = pprPanic "selectFromType" (ppr cs $$ ppr ty)++--------------------+mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkLRCo lr co+  | Just (ty, eq) <- isReflCo_maybe co+  = mkReflCo eq (pickLR lr (splitAppTy ty))+  | otherwise+  = LRCo lr co++-- | Instantiates a 'Coercion'.+-- Works for both tyvar and covar+mkInstCo :: Coercion -> CoercionN -> Coercion+mkInstCo co_fun co_arg+  | Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun+  , Just (arg, _) <- isReflCo_maybe co_arg+  = assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $+       -- If the arg is Refl, then kind_co must be reflexive too+    substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co+mkInstCo co arg = InstCo co arg++-- | Given @ty :: k1@, @co :: k1 ~ k2@,+-- produces @co' :: ty ~r (ty |> co)@+mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion+mkGReflRightCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise = mkGReflMCo r ty co++-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@,+-- produces @co' :: (ty |> co) ~r ty@+mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion+mkGReflLeftCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise    = mkSymCo $ mkGReflMCo r ty co++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,+-- produces @co' :: (ty |> co) ~r ty'+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceLeftCo r ty co co2+  | isGReflCo co = co2+  | otherwise    = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,+-- produces @co' :: ty' ~r (ty |> co)+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceRightCo r ty co co2+  | isGReflCo co = co2+  | otherwise    = co2 `mkTransCo` mkGReflMCo r ty co++-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.+mkKindCo :: Coercion -> Coercion+mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)+mkKindCo (GRefl _ _ (MCo co)) = co+mkKindCo co+  | Pair ty1 ty2 <- coercionKind co+       -- Generally, calling coercionKind during coercion creation is a bad idea,+       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,+       -- so it's OK here.+  , let tk1 = typeKind ty1+        tk2 = typeKind ty2+  , tk1 `eqType` tk2+  = Refl tk1+  | otherwise+  = KindCo co++mkSubCo :: HasDebugCallStack => Coercion -> Coercion+-- Input coercion is Nominal, result is Representational+-- see also Note [Role twiddling functions]+mkSubCo (Refl ty) = GRefl Representational ty MRefl+mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co+mkSubCo (TyConAppCo Nominal tc cos)+  = TyConAppCo Representational tc (applyRoles tc cos)+mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })+  = co { fco_role = Representational+       , fco_arg = downgradeRole Representational Nominal arg+       , fco_res = downgradeRole Representational Nominal res }+mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $+             SubCo co++-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]+downgradeRole_maybe :: Role   -- ^ desired role+                    -> Role   -- ^ current role+                    -> Coercion -> Maybe Coercion+-- In (downgradeRole_maybe dr cr co) it's a precondition that+--                                   cr = coercionRole co++downgradeRole_maybe Nominal          Nominal          co = Just co+downgradeRole_maybe Nominal          _                _  = Nothing++downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)+downgradeRole_maybe Representational Representational co = Just co+downgradeRole_maybe Representational Phantom          _  = Nothing++downgradeRole_maybe Phantom          Phantom          co = Just co+downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)++-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.+-- See Note [Role twiddling functions]+downgradeRole :: Role  -- desired role+              -> Role  -- current role+              -> Coercion -> Coercion+downgradeRole r1 r2 co+  = case downgradeRole_maybe r1 r2 co of+      Just co' -> co'+      Nothing  -> pprPanic "downgradeRole" (ppr co)++-- | Make a "coercion between coercions".+mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"+               -> CoercionN  -- ^ :: phi1 ~N phi2+               -> Coercion   -- ^ g1 :: phi1+               -> Coercion   -- ^ g2 :: phi2+               -> Coercion   -- ^ :: g1 ~r g2++-- if the two coercion prove the same fact, I just don't care what+-- the individual coercions are.+mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)+  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@+mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r+                                      (mkCoercionTy g1) (mkCoercionTy g2)++{-+%************************************************************************+%*                                                                      *+   Roles+%*                                                                      *+%************************************************************************+-}++-- | Converts a coercion to be nominal, if possible.+-- See Note [Role twiddling functions]+setNominalRole_maybe :: Role -- of input coercion+                     -> Coercion -> Maybe CoercionN+setNominalRole_maybe r co+  | r == Nominal = Just co+  | otherwise = setNominalRole_maybe_helper co+  where+    setNominalRole_maybe_helper (SubCo co)  = Just co+    setNominalRole_maybe_helper co@(Refl _) = Just co+    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co+    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos+           ; return $ TyConAppCo Nominal tc cos' }+    setNominalRole_maybe_helper co@(FunCo { fco_role = Representational+                                          , fco_arg = co1, fco_res = co2 })+      = do { co1' <- setNominalRole_maybe Representational co1+           ; co2' <- setNominalRole_maybe Representational co2+           ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' }+           }+    setNominalRole_maybe_helper (SymCo co)+      = SymCo <$> setNominalRole_maybe_helper co+    setNominalRole_maybe_helper (TransCo co1 co2)+      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2+    setNominalRole_maybe_helper (AppCo co1 co2)+      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2+    setNominalRole_maybe_helper co@(ForAllCo { fco_visL = visL, fco_visR = visR, fco_body = body_co })+      | visL `eqForAllVis` visR -- See (FC3) in Note [ForAllCo] in GHC.Core.TyCo.Rep+      = do { body_co' <- setNominalRole_maybe_helper body_co+           ; return (co { fco_body = body_co' }) }+    setNominalRole_maybe_helper (SelCo cs co) =+      -- NB, this case recurses via setNominalRole_maybe, not+      -- setNominalRole_maybe_helper!+      case cs of+        SelTyCon n _r ->+          -- Remember to update the role in SelTyCon to nominal;+          -- not doing this caused #23362.+          -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.+          SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co+        SelFun fs ->+          SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co+        SelForAll ->+          pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)+    setNominalRole_maybe_helper (InstCo co arg)+      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg+    setNominalRole_maybe_helper co@(UnivCo { uco_prov = prov })+      | case prov of PhantomProv {}    -> False  -- should always be phantom+                     ProofIrrelProv {} -> True   -- it's always safe+                     PluginProv {}     -> False  -- who knows? This choice is conservative.+      = Just $ co { uco_role = Nominal }+    setNominalRole_maybe_helper _ = Nothing++-- | Make a phantom coercion between two types. The coercion passed+-- in must be a nominal coercion between the kinds of the+-- types.+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkPhantomCo h t1 t2+  = mkUnivCo PhantomProv [h] Phantom t1 t2++-- takes any coercion and turns it into a Phantom coercion+toPhantomCo :: Coercion -> Coercion+toPhantomCo co+  = mkPhantomCo (mkKindCo co) ty1 ty2+  where Pair ty1 ty2 = coercionKind co++-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational+applyRoles :: TyCon -> [Coercion] -> [Coercion]+applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational++-- The Role parameter is the Role of the TyConAppCo+-- defined here because this is intimately concerned with the implementation+-- of TyConAppCo+-- Always returns an infinite list (with a infinite tail of Nominal)+tyConRolesX :: Role -> TyCon -> Infinite Role+tyConRolesX Representational tc = tyConRolesRepresentational tc+tyConRolesX role             _  = Inf.repeat role++tyConRoleListX :: Role -> TyCon -> [Role]+tyConRoleListX role = Inf.toList . tyConRolesX role++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRolesRepresentational :: TyCon -> Infinite Role+tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRoleListRepresentational :: TyCon -> [Role]+tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational++tyConRole :: Role -> TyCon -> Int -> Role+tyConRole Nominal          _  _ = Nominal+tyConRole Phantom          _  _ = Phantom+tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n++funRole :: Role -> FunSel -> Role+funRole Nominal          _  = Nominal+funRole Phantom          _  = Phantom+funRole Representational fs = funRoleRepresentational fs++funRoleRepresentational :: FunSel -> Role+funRoleRepresentational SelMult = Nominal+funRoleRepresentational SelArg  = Representational+funRoleRepresentational SelRes  = Representational++ltRole :: Role -> Role -> Bool+-- Is one role "less" than another?+--     Nominal < Representational < Phantom+ltRole Phantom          _       = False+ltRole Representational Phantom = True+ltRole Representational _       = False+ltRole Nominal          Nominal = False+ltRole Nominal          _       = True++-------------------------------++-- | like mkKindCo, but aggressively & recursively optimizes to avoid using+-- a KindCo constructor. The output role is nominal.+promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN++-- First cases handles anything that should yield refl.+promoteCoercion co = case co of++    Refl _ -> mkNomReflCo ki1++    GRefl _ _ MRefl -> mkNomReflCo ki1++    GRefl _ _ (MCo co) -> co++    _ | ki1 `eqType` ki2+      -> mkNomReflCo (typeKind ty1)+     -- No later branch should return refl+     -- The assert (False )s throughout+     -- are these cases explicitly, but they should never fire.++    TyConAppCo _ tc args+      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args+      -> co'+      | otherwise+      -> mkKindCo co++    AppCo co1 arg+      | Just co' <- instCoercion (coercionKind (mkKindCo co1))+                                 (promoteCoercion co1) arg+      -> co'+      | otherwise+      -> mkKindCo co++    ForAllCo { fco_tcv = tv, fco_body = g }+      | isTyVar tv+      -> promoteCoercion g++    ForAllCo {}+      -> assert False $+            -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2)+            -- The tyvar case is handled above, so the bound var is a+            -- a coercion variable. So both sides have kind Type+            -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep).+            -- So the result is Refl, and that should have been caught by+            -- the first equation above.  Hence `assert False`+         mkNomReflCo liftedTypeKind++    FunCo {} -> mkKindCo co+       -- We can get Type~Constraint or Constraint~Type+       -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint))++    CoVarCo {} -> mkKindCo co+    HoleCo {}  -> mkKindCo co+    AxiomCo {} -> mkKindCo co+    UnivCo {}  -> mkKindCo co  -- We could instead return the (single) `uco_deps` coercion in+                               -- the `ProofIrrelProv` and `PhantomProv` cases, but it doesn't+                               -- quite seem worth doing.++    SymCo g+      -> mkSymCo (promoteCoercion g)++    TransCo co1 co2+      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)++    SelCo n co1+      | Just co' <- mkSelCo_maybe n co1+      -> promoteCoercion co'++      | otherwise+      -> mkKindCo co++    LRCo lr co1+      | Just (lco, rco) <- splitAppCo_maybe co1+      -> case lr of+           CLeft  -> promoteCoercion lco+           CRight -> promoteCoercion rco++      | otherwise+      -> mkKindCo co++    InstCo g _+      | isForAllTy_ty ty1+      -> assert (isForAllTy_ty ty2) $+         promoteCoercion g+      | otherwise+      -> assert False $+         mkNomReflCo liftedTypeKind+           -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep++    KindCo _+      -> assert False $ -- See the first equation above+         mkNomReflCo liftedTypeKind++    SubCo g+      -> promoteCoercion g++  where+    Pair ty1 ty2 = coercionKind co+    ki1 = typeKind ty1+    ki2 = typeKind ty2++-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,+-- where @g' = promoteCoercion (h w)@.+-- fails if this is not possible, if @g@ coerces between a forall and an ->+-- or if second parameter has a representational role and can't be used+-- with an InstCo.+instCoercion :: Pair Type -- g :: lty ~ rty+             -> CoercionN  -- ^  must be nominal+             -> Coercion+             -> Maybe CoercionN+instCoercion (Pair lty rty) g w+  | (isForAllTy_ty lty && isForAllTy_ty rty)+  || (isForAllTy_co lty && isForAllTy_co rty)+  , Just w' <- setNominalRole_maybe (coercionRole w) w+    -- g :: (forall t1. t2) ~ (forall t1. t3)+    -- w :: s1 ~ s2+    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]+  = Just $ mkInstCo g w'++  | isFunTy lty && isFunTy rty+    -- g :: (t1 -> t2) ~ (t3 -> t4)+    -- returns t2 ~ t4+  = Just $ mkSelCo (SelFun SelRes) g -- extract result type++  | otherwise -- one forall, one funty...+  = Nothing++-- | Repeated use of 'instCoercion'+instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN+instCoercions g ws+  = let arg_ty_pairs = map coercionKind ws in+    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)+  where+    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)+       -> Maybe (Pair Type, Coercion)+    go (g_tys, g) (w_tys, w)+      = do { g' <- instCoercion g_tys g w+           ; return (piResultTy <$> g_tys <*> w_tys, g') }++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+castCoercionKind2 :: Coercion -> Role -> Type -> Type+                 -> CoercionN -> CoercionN -> Coercion+castCoercionKind2 g r t1 t2 h1 h2+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)++-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@+-- That is, it's a specialised form of castCoercionKind, where the two+--          kind coercions are identical+-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h) ~r (t2 |> h)@.+-- @h@ must be nominal.+-- See Note [castCoercionKind1]+castCoercionKind1 :: Coercion -> Role -> Type -> Type+                  -> CoercionN -> Coercion+castCoercionKind1 g r t1 t2 h+  = case g of+      Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal+                 mkNomReflCo (mkCastTy t2 h)+      GRefl _ _ mco -> case mco of+           MRefl       -> mkReflCo r (mkCastTy t2 h)+           MCo kind_co -> mkGReflMCo r (mkCastTy t1 h)+                               (mkSymCo h `mkTransCo` kind_co `mkTransCo` h)+      _ -> castCoercionKind2 g r t1 t2 h h++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)+-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand.+castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion+castCoercionKind g h1 h2+  = castCoercionKind2 g r t1 t2 h1 h2+  where+    (Pair t1 t2, r) = coercionKindRole g++mkPiCos :: Role -> [Var] -> Coercion -> Coercion+mkPiCos r vs co = foldr (mkPiCo r) co vs++-- | Make a forall 'Coercion', where both types related by the coercion+-- are quantified over the same variable.+mkPiCo  :: Role -> Var -> Coercion -> Coercion+mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co+              | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $+                  -- We didn't call mkForAllCo here because if v does not appear+                  -- in co, the argument coercion will be nominal. But here we+                  -- want it to be r. It is only called in 'mkPiCos', which is+                  -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for+                  -- now (Aug 2018) v won't occur in co.+                            mkFunResCo r v co+              | otherwise = mkFunResCo r v co++mkFunResCo :: Role -> Id -> Coercion -> Coercion+-- Given res_co :: res1 ~ res2,+--   mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2)+-- Reflexive in the multiplicity argument+mkFunResCo role id res_co+  = mkFunCoNoFTF role mult arg_co res_co+  where+    arg_co = mkReflCo role (varType 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+-- Lifted and unlifted equalities take different numbers of arguments,+-- so we have to make sure to supply the right parameter to decomposeCo.+-- Also, note that the role of the first coercion is the same as the role of+-- the equalities related by the second coercion. The second coercion is+-- itself always representational.+mkCoCast :: Coercion -> CoercionR -> Coercion+mkCoCast c g+  | (g2:g1:_) <- reverse co_list+  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2++  | otherwise+  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))+  where+    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)+    -- g1 :: s1 ~# s2+    -- g2 :: t1 ~# t2+    (tc, _) = splitTyConApp (coercionLKind g)+    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)++{- Note [castCoercionKind1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+castCoercionKind1 deals with the very important special case of castCoercionKind2+where the two kind coercions are identical.  In that case we can exploit the+situation where the main coercion is reflexive, via the special cases for Refl+and GRefl.++This is important when rewriting  (ty |> co). We rewrite ty, yielding+   fco :: ty ~ ty'+and now we want a coercion xco between+   xco :: (ty |> co) ~ (ty' |> co)+That's exactly what castCoercionKind1 does.  And it's very very common for+fco to be Refl.  In that case we do NOT want to get some terrible composition+of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2+has to do in its full generality.  See #18413.+-}++{-+%************************************************************************+%*                                                                      *+            Newtypes+%*                                                                      *+%************************************************************************+-}++-- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)`+--   then `co :: T ts ~R# rep_ty`+--+-- Checks for a newtype, and for being saturated+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)+instNewTyCon_maybe tc tys+  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype+  , tvs `leLength` tys                                    -- Check saturated enough+  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+         Type normalisation+*                                                                      *+************************************************************************+-}++-- | A function to check if we can reduce a type by one step. Used+-- with 'topNormaliseTypeX'.+type NormaliseStepper ev = RecTcChecker+                         -> TyCon     -- tc+                         -> [Type]    -- tys+                         -> NormaliseStepResult ev++-- | The result of stepping in a normalisation function.+-- See 'topNormaliseTypeX'.+data NormaliseStepResult ev+  = NS_Done   -- ^ Nothing more to do+  | NS_Abort  -- ^ Utter failure. The outer function should fail too.+  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;+                                    -- ^ ev is evidence;+                                    -- Usually a co :: old type ~ new type+  deriving (Functor)++instance Outputable ev => Outputable (NormaliseStepResult ev) where+  ppr NS_Done           = text "NS_Done"+  ppr NS_Abort          = text "NS_Abort"+  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]++-- | Try one stepper and then try the next, if the first doesn't make+-- progress.+-- So if it returns NS_Done, it means that both steppers are satisfied+composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev+                -> NormaliseStepper ev+composeSteppers step1 step2 rec_nts tc tys+  = case step1 rec_nts tc tys of+      success@(NS_Step {}) -> success+      NS_Done              -> step2 rec_nts tc tys+      NS_Abort             -> NS_Abort++-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+-- a loop. If it would fall into a loop, it produces 'NS_Abort'.+unwrapNewTypeStepper :: NormaliseStepper Coercion+unwrapNewTypeStepper rec_nts tc tys+  | Just (ty', co) <- instNewTyCon_maybe tc tys+  = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $+    case checkRecTc rec_nts tc of+      Just rec_nts' -> NS_Step rec_nts' ty' co+      Nothing       -> NS_Abort++  | otherwise+  = NS_Done++-- | A general function for normalising the top-level of a type. It continues+-- to use the provided 'NormaliseStepper' until that function fails, and then+-- this function returns. The roles of the coercions produced by the+-- 'NormaliseStepper' must all be the same, which is the role returned from+-- the call to 'topNormaliseTypeX'.+--+-- Typically ev is Coercion.+--+-- If topNormaliseTypeX step plus ty = Just (ev, ty')+-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'+-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn+-- If it returns Nothing then no newtype unwrapping could happen+topNormaliseTypeX :: NormaliseStepper ev+                  -> (ev -> ev -> ev)+                  -> Type -> Maybe (ev, Type)+topNormaliseTypeX stepper plus ty+ | Just (tc, tys) <- splitTyConApp_maybe ty+ -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous+ --      for certain type synonyms, we should think about reducing it (see #20990)+ , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys+ = go rec_nts ev ty'+ | otherwise+ = Nothing+ where+    go rec_nts ev ty+      | Just (tc, tys) <- splitTyConApp_maybe ty+      = case stepper rec_nts tc tys of+          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'+          NS_Done  -> Just (ev, ty)+          NS_Abort -> Nothing++      | otherwise+      = Just (ev, ty)++topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)+-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.+-- This function strips off @newtype@ layers enough to reveal something that isn't+-- a @newtype@.  Specifically, here's the invariant:+--+-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')+--+-- then (a)  @co : ty ~R ty'@.+--      (b)  ty' is not a newtype.+--+-- The function returns @Nothing@ for non-@newtypes@,+-- or unsaturated applications+--+-- This function does *not* look through type families, because it has no access to+-- the type family environment. If you do have that at hand, consider to use+-- topNormaliseType_maybe, which should be a drop-in replacement for+-- topNormaliseNewType_maybe+-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'+topNormaliseNewType_maybe ty+  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty++{-+%************************************************************************+%*                                                                      *+                   Comparison of coercions+%*                                                                      *+%************************************************************************+-}++-- | Syntactic equality of coercions+eqCoercion :: Coercion -> Coercion -> Bool+eqCoercion = eqType `on` coercionType++-- | Compare two 'Coercion's, with respect to an RnEnv2+eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool+eqCoercionX env = eqTypeX env `on` coercionType++{-+%************************************************************************+%*                                                                      *+                   "Lifting" substitution+           [(TyCoVar,Coercion)] -> Type -> Coercion+%*                                                                      *+%************************************************************************++Note [Lifting coercions over types: liftCoSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The KPUSH rule deals with this situation+   data T a = K (a -> Maybe a)+   g :: T t1 ~ T t2+   x :: t1 -> Maybe t1++   case (K @t1 x) |> g of+     K (y:t2 -> Maybe t2) -> rhs++We want to push the coercion inside the constructor application.+So we do this++   g' :: t1~t2  =  SelCo (SelTyCon 0) g++   case K @t2 (x |> g' -> Maybe g') of+     K (y:t2 -> Maybe t2) -> rhs++The crucial operation is that we+  * take the type of K's argument: a -> Maybe a+  * and substitute g' for a+thus giving *coercion*.  This is what liftCoSubst does.++In the presence of kind coercions, this is a bit+of a hairy operation. So, we refer you to the paper introducing kind coercions,+available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf++Note [extendLiftingContextEx]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we have datatype+  K :: /\k. /\a::k. P -> T k  -- P be some type+  g :: T k1 ~ T k2++  case (K @k1 @t1 x) |> g of+    K y -> rhs++We want to push the coercion inside the constructor application.+We first get the coercion mapped by the universal type variable k:+   lc = k |-> SelCo (SelTyCon 0) g :: k1~k2++Here, the important point is that the kind of a is coerced, and P might be+dependent on the existential type variable a.+Thus we first get the coercion of a's kind+   g2 = liftCoSubst lc k :: k1 ~ k2++Then we store a new mapping into the lifting context+   lc2 = a |-> (t1 ~ t1 |> g2), lc++So later when we can correctly deal with the argument type P+   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]++This is exactly what extendLiftingContextEx does.+* For each (tyvar:k, ty) pair, we product the mapping+    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))+* For each (covar:s1~s2, ty) pair, we produce the mapping+    covar |-> (co ~ co')+    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'++This follows the lifting context extension definition in the+"FC with Explicit Kind Equality" paper.+-}++-- ----------------------------------------------------+-- See Note [Lifting coercions over types: liftCoSubst]+-- ----------------------------------------------------++data LiftingContext = LC Subst LiftCoEnv+  -- in optCoercion, we need to lift when optimizing InstCo.+  -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt+  -- We thus propagate the substitution from GHC.Core.Coercion.Opt here.++instance Outputable LiftingContext where+  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)++type LiftCoEnv = VarEnv Coercion+     -- Maps *type variables* to *coercions*.+     -- That's the whole point of this function!+     -- Also maps coercion variables to ProofIrrelCos.++-- like liftCoSubstWith, but allows for existentially-bound types as well+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 -> 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 tvs cos) ty++-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)+-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where+-- @lc_left@ is a substitution mapping type variables to the left-hand+-- types of the mapped coercions in @lc@, and similar for @lc_right@.+liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion+{-# INLINE liftCoSubst #-}+-- Inlining this function is worth 2% of allocation in T9872d,+liftCoSubst r lc@(LC subst env) ty+  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)+  | otherwise         = ty_co_subst lc r ty++emptyLiftingContext :: InScopeSet -> LiftingContext+emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv++mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext+mkLiftingContext pairs+  = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))+       (mkVarEnv pairs)++mkSubstLiftingContext :: Subst -> LiftingContext+mkSubstLiftingContext subst = LC subst emptyVarEnv++liftingContextSubst :: LiftingContext -> Subst+liftingContextSubst (LC subst _) = subst++-- | Extend a lifting context with a new mapping.+extendLiftingContext :: LiftingContext  -- ^ original LC+                     -> TyCoVar         -- ^ new variable to map...+                     -> Coercion        -- ^ ...to this lifted version+                     -> LiftingContext+    -- mappings to reflexive coercions are just substitutions+extendLiftingContext (LC subst env) tv arg+  | Just (ty, _) <- isReflCo_maybe arg+  = LC (extendTCvSubst subst tv ty) env+  | otherwise+  = LC subst (extendVarEnv env tv arg)++-- | Extend the substitution component of a lifting context with+-- a new binding for a coercion variable. Used during coercion optimisation.+extendLiftingContextCvSubst :: LiftingContext+                            -> CoVar+                            -> Coercion+                            -> LiftingContext+extendLiftingContextCvSubst (LC subst env) cv co+  = LC (extendCvSubst subst cv co) env++-- | Extend a lifting context with a new mapping, and extend the in-scope set+extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC+                               -> TyCoVar         -- ^ new variable to map...+                               -> Coercion        -- ^ to this coercion+                               -> LiftingContext+extendLiftingContextAndInScope (LC subst env) tv co+  = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co++-- | Extend a lifting context with existential-variable bindings.+-- See Note [extendLiftingContextEx]+extendLiftingContextEx :: LiftingContext    -- ^ original lifting context+                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs+                       -> LiftingContext+-- Note that this is more involved than extendLiftingContext. That function+-- takes a coercion to extend with, so it's assumed that the caller has taken+-- into account any of the kind-changing stuff worried about here.+extendLiftingContextEx lc [] = lc+extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)+-- This function adds bindings for *Nominal* coercions. Why? Because it+-- works with existentially bound variables, which are considered to have+-- nominal roles.+  | isTyVar v+  = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty)+                 (extendVarEnv env v $+                  mkGReflRightCo Nominal+                                 ty+                                 (ty_co_subst lc Nominal (tyVarKind v)))+    in extendLiftingContextEx lc' rest+  | CoercionTy co <- ty+  = -- co      :: s1 ~r s2+    -- lift_s1 :: s1 ~r s1'+    -- lift_s2 :: s2 ~r s2'+    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')+    assert (isCoVar v) $+    let (s1, s2, r) = coVarTypesRole v+        lift_s1 = ty_co_subst lc r s1+        lift_s2 = ty_co_subst lc r s2+        kco     = mkTyConAppCo Nominal (equalityTyCon r)+                               [ mkKindCo lift_s1, mkKindCo lift_s2+                               , lift_s1         , lift_s2          ]+        lc'     = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co)+                     (extendVarEnv env v+                        (mkProofIrrelCo Nominal kco co $+                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))+    in extendLiftingContextEx lc' rest+  | otherwise+  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)+++-- | Erase the environments in a lifting context+zapLiftingContext :: LiftingContext -> LiftingContext+zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv++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', res) = upd subst++-- | The \"lifting\" operation which substitutes coercions for type+--   variables in a type to produce a coercion.+--+--   For the inverse operation, see 'liftCoMatch'+ty_co_subst :: LiftingContext -> Role -> Type -> Coercion+ty_co_subst !lc role ty+    -- !lc: making this function strict in lc allows callers to+    -- pass its two components separately, rather than boxing them.+    -- Unfortunately, Boxity Analysis concludes that we need lc boxed+    -- because it's used that way in liftCoSubstTyVarBndrUsing.+  = go role ty+  where+    go :: Role -> Type -> Coercion+    go r ty                 | Just ty' <- coreView ty+                            = go r ty'+    go Phantom ty           = lift_phantom ty+    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)+    go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2)+    go r t@(ForAllTy (Bndr v vis) ty)+       = let (lc', v', h) = liftCoSubstVarBndr lc v+             body_co = ty_co_subst lc' r ty in+         if isTyVar v' || almostDevoidCoVarOfCo v' body_co+           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo+           -- imposes an extra restriction on where a covar can appear. See+           -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep+            -- We specifically check for this and panic because we know that+           -- there's a hole in the type system here (see (FC6), and we'd rather+           -- panic than fall into it.+         then mkForAllCo v' vis vis h body_co+         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)+    go r ty@(LitTy {})     = assert (r == Nominal) $+                             mkNomReflCo ty+    go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)+                                                        (substRightCo lc co)+    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)+                                                  (substRightCo lc co)+      where kco = go Nominal (coercionType co)++    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))+                                  (substTy (lcSubstLeft  lc) ty)+                                  (substTy (lcSubstRight lc) ty)++{-+Note [liftCoSubstTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~+This function can fail if a coercion in the environment is of too low a role.++liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and+also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting+lemma guarantees that the roles work out. If we fail in this+case, we really should panic -- something is deeply wrong. But, in matchAxiom,+failing is fine. matchAxiom is trying to find a set of coercions+that match, but it may fail, and this is healthy behavior.+-}++-- See Note [liftCoSubstTyVar]+liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion+liftCoSubstTyVar (LC subst env) r v+  | Just co_arg <- lookupVarEnv env v+  = downgradeRole_maybe r (coercionRole co_arg) co_arg++  | otherwise+  = Just $ mkReflCo r (substTyVar subst v)++{- Note [liftCoSubstVarBndr]+   ~~~~~~~~~~~~~~~~~~~~~~~~~+callback:+  'liftCoSubstVarBndrUsing' needs to be general enough to work in two+  situations:++    - in this module, which manipulates 'Coercion's, and+    - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain+      a coercion as well as a type.++  To achieve this, we require that the return type of the 'callback' function+  contain a coercion within it. This is witnessed by the first argument+  to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve+  the coercion inside the return type. Thus:++    - in this module, we simply pass 'id' as the getter,+    - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter.++liftCoSubstTyVarBndrUsing:+  Given+    forall tv:k. t+  We want to get+    forall (tv:k1) (kind_co :: k1 ~ k2) body_co++  We lift the kind k to get the kind_co+    kind_co = ty_co_subst k :: k1 ~ k2++  Now in the LiftingContext, we add the new mapping+    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)++liftCoSubstCoVarBndrUsing:+  Given+    forall cv:(s1 ~ s2). t+  We want to get+    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co++  We lift s1 and s2 respectively to get+    eta1 :: s1' ~ t1+    eta2 :: s2' ~ t2+  And+    kind_co = TyConAppCo Nominal (~#) eta1 eta2++  Now in the liftingContext, we add the new mapping+    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)+-}++-- See Note [liftCoSubstVarBndr]+liftCoSubstVarBndr :: LiftingContext -> TyCoVar+                   -> (LiftingContext, TyCoVar, Coercion)+liftCoSubstVarBndr lc tv+  = liftCoSubstVarBndrUsing id callback lc tv+  where+    callback lc' ty' = ty_co_subst lc' Nominal ty'++-- the callback must produce a nominal coercion+liftCoSubstVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                        -> (LiftingContext -> Type -> r) -- ^ callback+                        -> LiftingContext -> TyCoVar+                        -> (LiftingContext, TyCoVar, r)+liftCoSubstVarBndrUsing view_co fun lc old_var+  | isTyVar old_var+  = liftCoSubstTyVarBndrUsing view_co fun lc old_var+  | otherwise+  = liftCoSubstCoVarBndrUsing view_co fun lc old_var++-- Works for tyvar binder+liftCoSubstTyVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                          -> (LiftingContext -> Type -> r) -- ^ callback+                          -> LiftingContext -> TyVar+                          -> (LiftingContext, TyVar, r)+liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var+  = assert (isTyVar old_var) $+    ( LC (subst `extendSubstInScope` new_var) new_cenv+    , new_var, stuff )+  where+    old_kind = tyVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)++    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta+               -- :: new_var ~ new_var |> eta+    new_cenv = extendVarEnv cenv old_var lifted++-- Works for covar binder+liftCoSubstCoVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                          -> (LiftingContext -> Type -> r) -- ^ callback+                          -> LiftingContext -> CoVar+                          -> (LiftingContext, CoVar, r)+liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var+  = assert (isCoVar old_var) $+    ( LC (subst `extendSubstInScope` new_var) new_cenv+    , new_var, stuff )+  where+    old_kind = coVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)++    -- old_var :: s1  ~r s2+    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)+    -- eta1    :: s1' ~r t1+    -- eta2    :: s2' ~r t2+    -- co1     :: s1' ~r s2'+    -- co2     :: t1  ~r t2+    -- lifted  :: co1 ~N co2++    role   = coVarRole old_var+    eta'   = downgradeRole role Nominal eta+    eta1   = mkSelCo (SelTyCon 2 role) eta'+    eta2   = mkSelCo (SelTyCon 3 role) eta'++    co1     = mkCoVarCo new_var+    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2+    lifted  = mkProofIrrelCo Nominal eta co1 co2++    new_cenv = extendVarEnv cenv old_var lifted++-- | Is a var in the domain of a lifting context?+isMappedByLC :: TyCoVar -> LiftingContext -> Bool+isMappedByLC tv (LC _ env) = tv `elemVarEnv` env++-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1+-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1+substLeftCo :: LiftingContext -> Coercion -> Coercion+substLeftCo lc co+  = substCo (lcSubstLeft lc) co++-- Ditto, but for t2 and g2+substRightCo :: LiftingContext -> Coercion -> Coercion+substRightCo lc co+  = substCo (lcSubstRight lc) co++-- | Apply "sym" to all coercions in a 'LiftCoEnv'+swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv+swapLiftCoEnv = mapVarEnv mkSymCo++lcSubstLeft :: LiftingContext -> Subst+lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env++lcSubstRight :: LiftingContext -> Subst+lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env++liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst+liftEnvSubstLeft = liftEnvSubst pFst++liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst+liftEnvSubstRight = liftEnvSubst pSnd++liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst+liftEnvSubst selector subst lc_env+  = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst+  where+    pairs            = nonDetUFMToList lc_env+                       -- It's OK to use nonDetUFMToList here because we+                       -- immediately forget the ordering by creating+                       -- a VarEnv+    (tpairs, cpairs) = partitionWith ty_or_co pairs+    -- Make sure the in-scope set is wide enough to cover the range of the+    -- substitution (#22235).+    in_scope         = mkInScopeSet $+                       tyCoVarsOfTypes (map snd tpairs) `unionVarSet`+                       tyCoVarsOfCos (map snd cpairs)+    tenv             = mkVarEnv_Directly tpairs+    cenv             = mkVarEnv_Directly cpairs++    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)+    ty_or_co (u, co)+      | Just equality_co <- isCoercionTy_maybe equality_ty+      = Right (u, equality_co)+      | otherwise+      = Left (u, equality_ty)+      where+        equality_ty = selector (coercionKind co)++-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext'+lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion+lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv++-- | Get the 'InScopeSet' from a 'LiftingContext'+lcInScopeSet :: LiftingContext -> InScopeSet+lcInScopeSet (LC subst _) = substInScopeSet subst++{-+%************************************************************************+%*                                                                      *+            Sequencing on coercions+%*                                                                      *+%************************************************************************+-}++seqMCo :: MCoercion -> ()+seqMCo MRefl    = ()+seqMCo (MCo co) = seqCo co++seqCo :: Coercion -> ()+seqCo (Refl ty)             = seqType ty+seqCo (GRefl r ty mco)      = r `seq` seqType ty `seq` seqMCo mco+seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos+seqCo (AppCo co1 co2)       = seqCo co1 `seq` seqCo co2+seqCo (CoVarCo cv)          = cv `seq` ()+seqCo (HoleCo h)            = coHoleCoVar h `seq` ()+seqCo (SymCo co)            = seqCo co+seqCo (TransCo co1 co2)     = seqCo co1 `seq` seqCo co2+seqCo (SelCo n co)          = n `seq` seqCo co+seqCo (LRCo lr co)          = lr `seq` seqCo co+seqCo (InstCo co arg)       = seqCo co `seq` seqCo arg+seqCo (KindCo co)           = seqCo co+seqCo (SubCo co)            = seqCo co+seqCo (AxiomCo _ cs)        = seqCos cs+seqCo (ForAllCo tv visL visR k co)+  = seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq`+    seqCo k `seq` seqCo co+seqCo (FunCo r af1 af2 w co1 co2)+  = r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2+seqCo (UnivCo { uco_prov = p, uco_role = r+              , uco_lty = t1, uco_rty = t2, uco_deps = deps })+  = p `seq` r `seq` seqType t1 `seq` seqType t2 `seq` seqCos deps++seqCos :: [Coercion] -> ()+seqCos []       = ()+seqCos (co:cos) = seqCo co `seq` seqCos cos++{-+%************************************************************************+%*                                                                      *+             The kind of a type, and of a coercion+%*                                                                      *+%************************************************************************+-}++{- Note [coercionKind performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+coercionKind, coercionLKind, and coercionRKind are very "hot" functions; in some+coercion-heavy programs they can have a material effect on compile time/allocation.++Hence+* Rather than making one function which returns a pair (lots of allocation and+  de-allocation) we have two functions, coercionLKind and coercionRKind, which+  return the left and right kind respectively.++* Both are defined by a single worker function `coercion_lr_kind`, which takes a+  flag of type `LeftOrRight`.  This worker function is marked INLINE, and inlined+  at its precisely-two call-sites in coercionLKind and coercionRKind.++Take care when making changes here... it's easy to accidentally add allocation!+-}++-- | Apply 'coercionKind' to multiple 'Coercion's+coercionKinds :: [Coercion] -> Pair [Type]+coercionKinds tys = sequenceA $ map coercionKind tys++-- | Get a coercion's kind and role.+coercionKindRole :: Coercion -> (Pair Type, Role)+coercionKindRole co = (coercionKind co, coercionRole co)++coercionType :: Coercion -> Type+coercionType co = case coercionKindRole co of+  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2++------------------+-- | If it is the case that+--+-- > c :: (t1 ~ t2)+--+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.++coercionKind :: HasDebugCallStack => Coercion -> Pair Type+-- See Note [coercionKind performance]+coercionKind co = Pair (coercionLKind co) (coercionRKind co)++coercionLKind, coercionRKind :: HasDebugCallStack => Coercion -> Type+-- See Note [coercionKind performance]+coercionLKind co = coercion_lr_kind CLeft  co+coercionRKind co = coercion_lr_kind CRight co++coercion_lr_kind :: HasDebugCallStack => LeftOrRight -> Coercion -> Type+{-# INLINE coercion_lr_kind #-}+-- See Note [coercionKind performance]+coercion_lr_kind which orig_co+  = go orig_co+  where+    go (Refl ty)              = ty+    go (GRefl _ ty MRefl)     = ty+    go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty co1)+    go (TyConAppCo _ tc cos)  = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)        = mkAppTy (go co1) (go co2)+    go (CoVarCo cv)           = go_covar cv+    go (HoleCo h)             = go_covar (coHoleCoVar h)+    go (SymCo co)             = pickLR which (coercionRKind co, coercionLKind co)+    go (TransCo co1 co2)      = pickLR which (go co1,           go co2)+    go (LRCo lr co)           = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)       = go_app aco [go arg]+    go (KindCo co)            = typeKind (go co)+    go (SubCo co)             = go co+    go (SelCo d co)           = selectFromType d (go co)+    go (AxiomCo ax cos)       = go_ax ax cos++    go (UnivCo { uco_lty = lty, uco_rty = rty})+      = pickLR which (lty, rty)+    go (FunCo { fco_afl = afl, fco_afr = afr, fco_mult = mult+              , fco_arg = arg, fco_res = res})+      = -- See Note [FunCo]+        FunTy { ft_af = pickLR which (afl, afr), ft_mult = go mult+              , ft_arg = go arg, ft_res = go res }++    go co@(ForAllCo { fco_tcv = tv1, fco_visL = visL, fco_visR = visR+                    , fco_kind = k_co, fco_body = co1 })+      = case which of+          CLeft  -> mkTyCoForAllTy tv1 visL (go co1)+          CRight | isGReflCo k_co  -- kind_co always has kind `Type`, thus `isGReflCo`+                 -> mkTyCoForAllTy tv1 visR (go co1)+                 | otherwise+                 -> go_forall_right empty_subst co+      where+         empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co)++    -------------+    go_covar cv = pickLR which (coVarLType cv, coVarRType cv)++    -------------+    go_app :: Coercion -> [Type] -> Type+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (go arg:args)+    go_app co              args = piResultTys (go co) args++    -------------+    go_ax axr@(BuiltInFamRew  bif) cos  = check_bif_res axr (bifrw_proves  bif (map coercionKind cos))+    go_ax axr@(BuiltInFamInj bif) [co]  = check_bif_res axr (bifinj_proves bif (coercionKind co))+    go_ax axr@(BuiltInFamInj {})  _     = crash axr+    go_ax     (UnbranchedAxiom ax) cos  = go_branch ax (coAxiomSingleBranch ax) cos+    go_ax     (BranchedAxiom ax i) cos  = go_branch ax (coAxiomNthBranch ax i)  cos++    -------------+    check_bif_res _   (Just (Pair lhs rhs)) = pickLR which (lhs,rhs)+    check_bif_res axr Nothing               = crash axr++    crash :: CoAxiomRule -> Type+    crash axr = pprPanic "coercionKind" (ppr axr)++    -------------+    go_branch :: CoAxiom br -> CoAxBranch -> [Coercion] -> Type+    go_branch ax (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                             , cab_lhs = lhs_tys, cab_rhs = rhs_ty }) cos+      = assert (cos `equalLength` tcvs) $+                  -- Invariant of AxiomRuleCo: cos should+                  -- exactly saturate the axiom branch+        let (tys1, cotys1) = splitAtList tvs tys+            cos1           = map stripCoercionTy cotys1+        in+        -- You might think to use+        --        substTy (zipTCvSubst tcvs ltys) (pickLR ...)+        -- but #25066 makes it much less efficient than the silly calls below+        substTyWith tvs tys1       $+        substTyWithCoVars cvs cos1 $+        pickLR which (mkTyConApp tc lhs_tys, rhs_ty)+     where+       tc   = coAxiomTyCon ax+       tcvs | null cvs  = tvs  -- Very common case (currently always!)+            | otherwise = tvs ++ cvs+       tys = map go cos++    -------------+    go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR+                                    , fco_kind = k_co, fco_body = co })+      -- See Note [Nested ForAllCos]+      | isTyVar tv1+      = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)+      where+        k2  = coercionRKind k_co+        tv2 = setTyVarKind tv1 (substTy subst k2)+        subst' | isGReflCo k_co = extendSubstInScope subst tv1+                 -- kind_co always has kind @Type@, thus @isGReflCo@+               | otherwise      = extendTvSubst (extendSubstInScope subst tv2) tv1 $+                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co++    go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR+                                    , fco_kind = k_co, fco_body = co })+      | isCoVar cv1+      = mkTyCoForAllTy cv2 visR (go_forall_right subst' co)+      where+        k2    = coercionRKind k_co+        r     = coVarRole cv1+        k_co' = downgradeRole r Nominal k_co+        eta1  = mkSelCo (SelTyCon 2 r) k_co'+        eta2  = mkSelCo (SelTyCon 3 r) k_co'++        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)+        -- k1    = t1 ~r t2+        -- k2    = s1 ~r s2+        -- cv1  :: t1 ~r t2+        -- cv2  :: s1 ~r s2+        -- eta1 :: t1 ~r s1+        -- eta2 :: t2 ~r s2+        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2++        cv2     = setVarType cv1 (substTy subst k2)+        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)+        subst'  | isReflCo k_co = extendSubstInScope subst cv1+                | otherwise     = extendCvSubst (extendSubstInScope subst cv2)+                                                cv1 n_subst++    go_forall_right subst other_co+      -- when other_co is not a ForAllCo+      = substTy subst (go other_co)++{- Note [Nested ForAllCos]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an co)...) )`.+We do not want to perform `n` single-type-variable substitutions over the kind+of `co`; rather we want to do one substitution which substitutes for all of+`a1`, `a2` ... simultaneously.  If we do one at a time we get the performance+hole reported in #11735.++Solution: gather up the type variables for nested `ForAllCos`, and+substitute for them all at once.  Remarkably, for #11735 this single+change reduces /total/ compile time by a factor of more than ten.++Note [Nested InstCos]+~~~~~~~~~~~~~~~~~~~~~+In #5631 we found that 70% of the entire compilation time was+being spent in coercionKind!  The reason was that we had+   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos+where+   g :: forall a1 a2 .. a100. phi+If we deal with the InstCos one at a time, we'll do this:+   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'+   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst+But this is a *quadratic* algorithm, and the blew up #5631.+So it's very important to do the substitution simultaneously;+cf Type.piResultTys (which in fact we call here).+-}++-- | Retrieve the role from a coercion.+coercionRole :: Coercion -> Role+coercionRole = go+  where+    go (Refl _)                     = Nominal+    go (GRefl r _ _)                = r+    go (TyConAppCo r _ _)           = r+    go (AppCo co1 _)                = go co1+    go (ForAllCo { fco_body = co }) = go co+    go (FunCo { fco_role = r })     = r+    go (CoVarCo cv)                 = coVarRole cv+    go (HoleCo h)                   = coVarRole (coHoleCoVar h)+    go (UnivCo { uco_role = r })    = r+    go (SymCo co)                   = go co+    go (TransCo co1 _co2)           = go co1+    go (SelCo cs co)                = mkSelCoResRole cs (coercionRole co)+    go (LRCo {})                    = Nominal+    go (InstCo co _)                = go co+    go (KindCo {})                  = Nominal+    go (SubCo _)                    = Representational+    go (AxiomCo ax _)               = coAxiomRuleRole ax++-- | Makes a coercion type from two types: the types whose equality+-- is proven by the relevant 'Coercion'+mkCoercionType :: Role -> Type -> Type -> Type+mkCoercionType Nominal          = mkNomEqPred+mkCoercionType Representational = mkReprEqPred+mkCoercionType Phantom          = \ty1 ty2 ->+  let ki1 = typeKind ty1+      ki2 = typeKind ty2+  in+  TyConApp eqPhantPrimTyCon [ki1, ki2, 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+-- AppCos might yield different kinds. See Note [EtaAppCo] in+-- "GHC.Core.Coercion.Opt".+buildCoercion :: HasDebugCallStack => Type -> Type -> CoercionN+buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2+               | Just ty2' <- coreView ty2 = go ty1 ty2'++    go (CastTy ty1 co) ty2+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceLeftCo r ty1 co co'++    go ty1 (CastTy ty2 co)+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceRightCo r ty2 co co'++    go ty1@(TyVarTy tv1) _tyvarty+      = assert (case _tyvarty of+                  { TyVarTy tv2 -> tv1 == tv2+                  ; _           -> False      }) $+        mkNomReflCo ty1++    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })+       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })+      = assert (af1 == af2) $+        mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2)++    go (TyConApp tc1 args1) (TyConApp tc2 args2)+      = assertPpr (tc1 == tc2) (vcat [ ppr tc1 <+> ppr tc2+                                     , text "orig_ty1:" <+> ppr orig_ty1+                                     , text "orig_ty2:" <+> ppr orig_ty2+                                     ]) $+        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)++    go (AppTy ty1a ty1b) ty2+      | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go ty1 (AppTy ty2a ty2b)+      | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2)+      | isTyVar tv1+      = assert (isTyVar tv2) $+        mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2')+      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)+            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'     = substTyWithInScope in_scope [tv2]+                         [mkTyVarTy tv1 `mkCastTy` kind_co]+                         ty2++    go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)+      = assert (isCoVar cv1 && isCoVar cv2) $+        mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2')+      where s1 = varType cv1+            s2 = varType cv2+            kind_co = go s1 s2++            -- s1 = t1 ~r t2+            -- s2 = t3 ~r t4+            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)+            -- eta1 :: t1 ~r t3+            -- eta2 :: t2 ~r t4++            r    = coVarRole cv1+            kind_co' = downgradeRole r Nominal kind_co+            eta1 = mkSelCo (SelTyCon 2 r) kind_co'+            eta2 = mkSelCo (SelTyCon 3 r) kind_co'++            subst = mkEmptySubst $ mkInScopeSet $+                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`+                                                       mkCoVarCo cv1 `mkTransCo`+                                                       eta2)+                            ty2++    go ty1@(LitTy lit1) _lit2+      = assert (case _lit2 of+                  { LitTy lit2 -> lit1 == lit2+                  ; _          -> False        }) $+        mkNomReflCo ty1++    go (CoercionTy co1) (CoercionTy co2)+      = mkProofIrrelCo Nominal kind_co co1 co2+      where+        kind_co = go (coercionType co1) (coercionType co2)++    go ty1 ty2+      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2+                                           , ppr ty1, ppr ty2 ])+++{-+%************************************************************************+%*                                                                      *+       Coercion holes+%*                                                                      *+%************************************************************************+-}++has_co_hole_ty :: Type -> Monoid.Any+(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  = \_ _ -> Monoid.Any True+                        , 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.hs-boot view
@@ -16,16 +16,15 @@ mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion-mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion-mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion-mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion-mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion+mkFunCo      :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo2     :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkCoVarCo :: CoVar -> Coercion-mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion-mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion+mkUnivCo :: UnivCoProvenance -> [Coercion] -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion-mkTransCo :: Coercion -> Coercion -> Coercion+mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion mkLRCo :: LeftOrRight -> Coercion -> Coercion mkInstCo :: Coercion -> Coercion -> Coercion@@ -34,24 +33,24 @@ mkKindCo :: Coercion -> Coercion mkSubCo :: HasDebugCallStack => Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion-mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion+mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion +funRole :: Role -> FunSel -> Role+ isGReflCo :: Coercion -> Bool isReflCo :: Coercion -> Bool isReflexiveCo :: Coercion -> Bool decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)-coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role)+coVarTypesRole :: HasDebugCallStack => CoVar -> (Type, Type, Role) coVarRole :: CoVar -> Role  mkCoercionType :: Role -> Type -> Type -> Type -data LiftingContext-liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion seqCo :: Coercion -> () -coercionKind :: Coercion -> Pair Type-coercionLKind :: Coercion -> Type-coercionRKind :: Coercion -> Type+coercionKind  :: HasDebugCallStack => Coercion -> Pair Type+coercionLKind :: HasDebugCallStack => Coercion -> Type+coercionRKind :: HasDebugCallStack => Coercion -> Type coercionType :: Coercion -> Type  topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -30,7 +30,9 @@         Role(..), fsFromRole, -       CoAxiomRule(..), TypeEqn,+       CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn,+       coAxiomRuleArgRoles, coAxiomRuleRole,+       coAxiomRuleBranch_maybe, isNewtypeAxiomRule_maybe,        BuiltInSynFamily(..), trivialBuiltInFamily        ) where @@ -40,7 +42,7 @@  import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar )-import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon, isNewTyCon ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Name@@ -49,7 +51,6 @@ import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable )@@ -57,6 +58,7 @@ import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL )+import Control.DeepSeq  {- Note [Coercion axiom branches]@@ -80,12 +82,12 @@        ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char        } -The axiom is used with the AxiomInstCo constructor of Coercion. If we wish+The axiom is used with the AxiomCo constructor of Coercion. If we wish to have a coercion showing that F (Maybe Int) ~ Char, it will look like  axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char -- or, written using concrete-ish syntax ---AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int]+AxiomRuleCo axF 2 [Refl *, Refl Maybe, Refl Int]  Note that the index is 0-based. @@ -128,9 +130,22 @@ ************************************************************************ -} -type BranchIndex = Int  -- The index of the branch in the list of branches-                        -- Counting from zero+{- Note [BranchIndex]+~~~~~~~~~~~~~~~~~~~~+A CoAxiom has 1 or more branches. Each branch has contains a list+of the free type variables in that branch, the LHS type patterns,+and the RHS type for that branch. When we apply an axiom to a list+of coercions, we must choose which branch of the axiom we wish to+use, as the different branches may have different numbers of free+type variables. (The number of type patterns is always the same+among branches, but that doesn't quite concern us here.)+-} ++type BranchIndex = Int         -- Counting from zero+      -- The index of the branch in the list of branches+      -- See Note [BranchIndex]+ -- promoted data type data BranchFlag = Branched | Unbranched type Branched = 'Branched@@ -236,43 +251,49 @@          -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.     } +-- | A branch of a coercion axiom, which provides the evidence for+-- unwrapping a newtype or a type-family reduction step using a single equation. data CoAxBranch   = CoAxBranch-    { cab_loc      :: SrcSpan       -- Location of the defining equation-                                    -- See Note [CoAxiom locations]-    , cab_tvs      :: [TyVar]       -- Bound type variables; not necessarily fresh-                                    -- See Note [CoAxBranch type variables]-    , cab_eta_tvs  :: [TyVar]       -- Eta-reduced tyvars-                                    -- cab_tvs and cab_lhs may be eta-reduced; see-                                    -- Note [Eta reduction for data families]-    , cab_cvs      :: [CoVar]       -- Bound coercion variables-                                    -- Always empty, for now.-                                    -- See Note [Constraints in patterns]-                                    -- in GHC.Tc.TyCl-    , cab_roles    :: [Role]        -- See Note [CoAxBranch roles]-    , cab_lhs      :: [Type]        -- Type patterns to match against-    , cab_rhs      :: Type          -- Right-hand side of the equality-                                    -- See Note [CoAxioms are homogeneous]-    , cab_incomps  :: [CoAxBranch]  -- The previous incompatible branches-                                    -- See Note [Storing compatibility]+    { cab_loc      :: SrcSpan+        -- ^ Location of the defining equation+        -- See Note [CoAxiom locations]+    , cab_tvs      :: [TyVar]+       -- ^ Bound type variables; not necessarily fresh+       -- See Note [CoAxBranch type variables]+    , cab_eta_tvs  :: [TyVar]+       -- ^ Eta-reduced tyvars+       -- cab_tvs and cab_lhs may be eta-reduced; see+       -- Note [Eta reduction for data families]+    , cab_cvs      :: [CoVar]+      -- ^ Bound coercion variables+       -- Always empty, for now.+       -- See Note [Constraints in patterns]+       -- in GHC.Tc.TyCl+    , cab_roles    :: [Role]+       -- ^ See Note [CoAxBranch roles]+    , cab_lhs      :: [Type]+       -- ^ Type patterns to match against+    , cab_rhs      :: Type+       -- ^ Right-hand side of the equality+       -- See Note [CoAxioms are homogeneous]+    , cab_incomps  :: [CoAxBranch]+       -- ^ The previous incompatible branches+       -- See Note [Storing compatibility]     }   deriving Data.Data  toBranchedAxiom :: CoAxiom br -> CoAxiom Branched-toBranchedAxiom (CoAxiom unique name role tc branches implicit)-  = CoAxiom unique name role tc (toBranched branches) implicit+toBranchedAxiom ax@(CoAxiom { co_ax_branches = branches })+  = ax { co_ax_branches = toBranched branches }  toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched-toUnbranchedAxiom (CoAxiom unique name role tc branches implicit)-  = CoAxiom unique name role tc (toUnbranched branches) implicit+toUnbranchedAxiom ax@(CoAxiom { co_ax_branches = branches })+  = ax { co_ax_branches = toUnbranched branches }  coAxiomNumPats :: CoAxiom br -> Int coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) -coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch-coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index-  = branchesNth bs index- coAxiomArity :: CoAxiom br -> BranchIndex -> Arity coAxiomArity ax index   = length tvs + length cvs@@ -287,6 +308,14 @@ coAxiomBranches :: CoAxiom br -> Branches br coAxiomBranches = co_ax_branches +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch+coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index+  = branchesNth bs index++coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch+coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })+  = arr ! 0+ coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr })   | snd (bounds arr) == 0@@ -294,10 +323,6 @@   | otherwise   = Nothing -coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch-coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })-  = arr ! 0- coAxiomTyCon :: CoAxiom br -> TyCon coAxiomTyCon = co_ax_tc @@ -535,6 +560,11 @@                           3 -> return Phantom                           _ -> panic ("get Role " ++ show tag) +instance NFData Role where+  rnf Nominal = ()+  rnf Representational = ()+  rnf Phantom = ()+ {- ************************************************************************ *                                                                      *@@ -543,76 +573,177 @@ *                                                                      * ************************************************************************ -Conditional axioms.  The general idea is that a `CoAxiomRule` looks like this:+Note [CoAxiomRule]+~~~~~~~~~~~~~~~~~~+A CoAxiomRule is a built-in axiom, one that we assume to be true:+CoAxiomRules come in four flavours: -    forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2+* BuiltInFamRew: provides evidence for, say+      (ax1)    3+4 ----> 7+      (ax2)    s+0 ----> s+  The evidence looks like+      AxiomCo ax1 [3,4] :: 3+4 ~ 7+      AxiomCo ax2 [s]   :: s+0 ~ s+  The arguments in the AxiomCo are the /instantiating types/, or+  more generally coercions (see Note [Coercion axioms applied to coercions]+  in GHC.Core.TyCo.Rep). -My intention is to reuse these for both (~) and (~#).-The short-term plan is to use this datatype to represent the type-nat axioms.-In the longer run, it may be good to unify this and `CoAxiom`,-as `CoAxiom` is the special case when there are no assumptions.+* BuiltInFamInj: provides evidence for the injectivity of type families+  For example+      (ax3)   g1: a+b ~ 0        --->  a~0+      (ax4)   g2: a+b ~ 0        --->  b~0+      (ax5)   g3: a+b1 ~ a~b2    --->  b1~b2+  The argument to the AxiomCo is the full coercion (always just one).+  So then:+      AxiomCo ax3 [g1] :: a ~ 0+      AxiomCo ax4 [g2] :: b ~ 0+      AxiomCo ax5 [g3] :: b1 ~ b2++* BranchedAxiom: used for closed type families+      type family F a where+        F Int  = Bool+        F Bool = Char+        F a    = a -> Int+  We get one (CoAxiom Branched) for the entire family; when used in an+  AxiomCo we pair it with the BranchIndex to say which branch to pick.++* UnbranchedAxiom: used for several purposes;+    - Newtypes+    - Data family instances+    - Open type family instances++Note [Avoiding allocating lots of CoAxiomRules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CoAxiomRule is a sum type of four alternatives, which is very nice. But+there is a danger of allocating lots of (BuiltInFamRew bif) objects, every+time we (say) need a type-family rewrite.++To avoid this allocation, we cache the appropraite CoAxiomRule inside each+   BuiltInFamRewrite, BuiltInFamInjectivity+making a little circular data structure.  See the `bifrw_axr` field of+BuiltInFamRewrite, and similarly the others.++It's simple to do this, and saves a percent or two of allocation in programs+that do a lot of type-family work. -} --- | A more explicit representation for `t1 ~ t2`.-type TypeEqn = Pair Type+-- | CoAxiomRule describes a built-in axiom, one that we assume to be true+-- See Note [CoAxiomRule]+data CoAxiomRule+  = BuiltInFamRew  BuiltInFamRewrite                   -- Built-in type-family rewrites+                                                       --    e.g.  3+5 ~ 7 --- | For now, we work only with nominal equality.-data CoAxiomRule = CoAxiomRule-  { coaxrName      :: FastString-  , coaxrAsmpRoles :: [Role]    -- roles of parameter equations-  , coaxrRole      :: Role      -- role of resulting equation-  , coaxrProves    :: [TypeEqn] -> Maybe TypeEqn-        -- ^ coaxrProves returns @Nothing@ when it doesn't like-        -- the supplied arguments.  When this happens in a coercion-        -- that means that the coercion is ill-formed, and Core Lint-        -- checks for that.-  }+  | BuiltInFamInj  BuiltInFamInjectivity               -- Built-in type-family deductions+                                                       --    e.g.  a+b~0 ==>  a~0+                                                       -- Always unary +  | BranchedAxiom      (CoAxiom Branched) BranchIndex  -- Closed type family++  | UnbranchedAxiom    (CoAxiom Unbranched)            -- Open type family instance,+                                                       --    data family instances+                                                       --    and newtypes++instance Eq CoAxiomRule where+  (BuiltInFamRew  bif1)  == (BuiltInFamRew  bif2)  = bifrw_name  bif1 == bifrw_name bif2+  (BuiltInFamInj bif1)   == (BuiltInFamInj bif2)   = bifinj_name bif1 == bifinj_name bif2+  (UnbranchedAxiom ax1)  == (UnbranchedAxiom ax2)  = getUnique ax1 == getUnique ax2+  (BranchedAxiom ax1 i1) == (BranchedAxiom ax2 i2) = getUnique ax1 == getUnique ax2 && i1 == i2+  _ == _ = False++coAxiomRuleRole :: CoAxiomRule -> Role+coAxiomRuleRole (BuiltInFamRew  {})  = Nominal+coAxiomRuleRole (BuiltInFamInj {})   = Nominal+coAxiomRuleRole (UnbranchedAxiom ax) = coAxiomRole ax+coAxiomRuleRole (BranchedAxiom ax _) = coAxiomRole ax++coAxiomRuleArgRoles :: CoAxiomRule -> [Role]+coAxiomRuleArgRoles (BuiltInFamRew  bif) = replicate (bifrw_arity bif) Nominal+coAxiomRuleArgRoles (BuiltInFamInj {})   = [Nominal]+coAxiomRuleArgRoles (UnbranchedAxiom ax) = coAxBranchRoles (coAxiomSingleBranch ax)+coAxiomRuleArgRoles (BranchedAxiom ax i) = coAxBranchRoles (coAxiomNthBranch ax i)++coAxiomRuleBranch_maybe :: CoAxiomRule -> Maybe (TyCon, Role, CoAxBranch)+coAxiomRuleBranch_maybe (UnbranchedAxiom ax) = Just (co_ax_tc ax, co_ax_role ax, coAxiomSingleBranch ax)+coAxiomRuleBranch_maybe (BranchedAxiom ax i) = Just (co_ax_tc ax, co_ax_role ax, coAxiomNthBranch ax i)+coAxiomRuleBranch_maybe _                    = Nothing++isNewtypeAxiomRule_maybe :: CoAxiomRule -> Maybe (TyCon, CoAxBranch)+isNewtypeAxiomRule_maybe (UnbranchedAxiom ax)+  | let tc = coAxiomTyCon ax, isNewTyCon tc = Just (tc, coAxiomSingleBranch ax)+isNewtypeAxiomRule_maybe _                  = Nothing+ instance Data.Data CoAxiomRule where   -- don't traverse?   toConstr _   = abstractConstr "CoAxiomRule"   gunfold _ _  = error "gunfold"   dataTypeOf _ = mkNoRepType "CoAxiomRule" -instance Uniquable CoAxiomRule where-  getUnique = getUnique . coaxrName+instance Outputable CoAxiomRule where+  ppr (BuiltInFamRew  bif) = ppr (bifrw_name bif)+  ppr (BuiltInFamInj bif)  = ppr (bifinj_name bif)+  ppr (UnbranchedAxiom ax) = ppr (coAxiomName ax)+  ppr (BranchedAxiom ax i) = ppr (coAxiomName ax) <> brackets (int i) -instance Eq CoAxiomRule where-  x == y = coaxrName x == coaxrName y+{- *********************************************************************+*                                                                      *+                    Built-in families+*                                                                      *+********************************************************************* -} -instance Ord CoAxiomRule where-  -- we compare lexically to avoid non-deterministic output when sets of rules-  -- are printed-  compare x y = lexicalCompareFS (coaxrName x) (coaxrName y) -instance Outputable CoAxiomRule where-  ppr = ppr . coaxrName-+-- | A more explicit representation for `t1 ~ t2`.+type TypeEqn = Pair Type  -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily-  { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-    -- Does this reduce on the given arguments?-    -- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)-    -- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)-    --              :: F tys ~r rhs,-    -- where the r in the output is coaxrRole of the rule. It is up to the-    -- caller to ensure that this role is appropriate.--  , sfInteractTop   :: [Type] -> Type -> [TypeEqn]+  { sfMatchFam :: [BuiltInFamRewrite]+  , sfInteract :: [BuiltInFamInjectivity]     -- If given these type arguments and RHS, returns the equalities that-    -- are guaranteed to hold.--  , sfInteractInert :: [Type] -> Type ->-                       [Type] -> Type -> [TypeEqn]-    -- If given one set of arguments and result, and another set of arguments-    -- and result, returns the equalities that are guaranteed to hold.+    -- are guaranteed to hold.  That is, if+    --     (ar, Pair s1 s2)  is an element of  (sfInteract tys ty)+    -- then  AxiomRule ar [co :: F tys ~ ty]  ::  s1~s2   } +data BuiltInFamInjectivity  -- Argument and result role are always Nominal+  = BIF_Interact+      { bifinj_name :: FastString+      , bifinj_axr  :: CoAxiomRule -- Cached copy of (BuiltInFamINj this-bif)+                                   -- See Note [Avoiding allocating lots of CoAxiomRules]++      , bifinj_proves :: TypeEqn -> Maybe TypeEqn+            -- ^ Always unary: just one TypeEqn argument+            -- Returns @Nothing@ when it doesn't like the supplied argument.+            -- When this happens in a coercion that means that the coercion is+            -- ill-formed, and Core Lint checks for that.+      }++data BuiltInFamRewrite  -- Argument roles and result role are always Nominal+  = BIF_Rewrite+      { bifrw_name   :: FastString+      , bifrw_axr    :: CoAxiomRule -- Cached copy of (BuiltInFamRew this-bif)+                                    -- See Note [Avoiding allocating lots of CoAxiomRules]++      , bifrw_fam_tc :: TyCon       -- Needed for tyConsOfType++      , bifrw_arity  :: Arity       -- Number of type arguments needed+                                    -- to instantiate this axiom++      , bifrw_match :: [Type] -> Maybe ([Type], Type)+           -- coaxrMatch: does this reduce on the given arguments?+           -- If it does, returns (types to instantiate the rule at, rhs type)+           -- That is: mkAxiomCo ax (zipWith mkReflCo coAxiomRuleArgRoles ts)+           --              :: F tys ~N rhs,++      , bifrw_proves :: [TypeEqn] -> Maybe TypeEqn }+           -- length(inst_tys) = bifrw_arity++      -- INVARIANT: bifrw_match and bifrw_proves are related as follows:+      -- If    Just (inst_tys, res_ty) = bifrw_match ax arg_tys+      -- then  * length arg_tys = tyConArity fam_tc+      --       * length inst_tys = bifrw_arity+       --      * bifrw_proves (map (return @Pair) inst_tys) = Just (return @Pair res_ty)++ -- Provides default implementations that do nothing. trivialBuiltInFamily :: BuiltInSynFamily-trivialBuiltInFamily = BuiltInSynFamily-  { sfMatchFam      = \_ -> Nothing-  , sfInteractTop   = \_ _ -> []-  , sfInteractInert = \_ _ _ _ -> []-  }+trivialBuiltInFamily = BuiltInSynFamily { sfMatchFam = [], sfInteract = [] }
compiler/GHC/Core/Coercion/Opt.hs view
@@ -4,1273 +4,1510 @@  module GHC.Core.Coercion.Opt    ( optCoercion-   , checkAxInstCo-   , OptCoercionOpts (..)-   )-where--import GHC.Prelude--import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType )--import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.Compare( eqType )-import GHC.Core.Coercion-import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )-import GHC.Core.TyCon-import GHC.Core.Coercion.Axiom-import GHC.Core.Unify--import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Unique.Set--import GHC.Data.Pair-import GHC.Data.List.SetOps ( getNth )--import GHC.Utils.Outputable-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain--import Control.Monad   ( zipWithM )--{--%************************************************************************-%*                                                                      *-                 Optimising coercions-%*                                                                      *-%************************************************************************--This module does coercion optimisation.  See the paper--   Evidence normalization in Systtem FV (RTA'13)-   https://simon.peytonjones.org/evidence-normalization/--The paper is also in the GHC repo, in docs/opt-coercion.--Note [Optimising coercion optimisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Looking up a coercion's role or kind is linear in the size of the-coercion. Thus, doing this repeatedly during the recursive descent-of coercion optimisation is disastrous. We must be careful to avoid-doing this if at all possible.--Because it is generally easy to know a coercion's components' roles-from the role of the outer coercion, we pass down the known role of-the input in the algorithm below. We also keep functions opt_co2-and opt_co3 separate from opt_co4, so that the former two do Phantom-checks that opt_co4 can avoid. This is a big win because Phantom coercions-rarely appear within non-phantom coercions -- only in some TyConAppCos-and some AxiomInstCos. We handle these cases specially by calling-opt_co2.--Note [Optimising InstCo]-~~~~~~~~~~~~~~~~~~~~~~~~-(1) tv is a type variable-When we have (InstCo (ForAllCo tv h g) g2), we want to optimise.--Let's look at the typing rules.--h : k1 ~ k2-tv:k1 |- g : t1 ~ t2-------------------------------ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h])--g1 : (all tv:k1.t1') ~ (all tv:k2.t2')-g2 : s1 ~ s2----------------------InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]--We thus want some coercion proving this:--  (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h])--If we substitute the *type* tv for the *coercion*-(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly.-This is bizarre,-though, because we're substituting a type variable with a coercion. However,-this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion.-We just need to enhance the lifting operation to be able to deal with-an ambient substitution, which is why a LiftingContext stores a TCvSubst.--(2) cv is a coercion variable-Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.--h : (t1 ~r t2) ~N (t3 ~r t4)-cv : t1 ~r t2 |- g : t1' ~r2 t2'-n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3-n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4--------------------------------------------------ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2-                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])--g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')-g2 : h1 ~N h2-h1 : t1 ~r t2-h2 : t3 ~r t4--------------------------------------------------InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]--We thus want some coercion proving this:--  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]--So we substitute the coercion variable c for the coercion-(h1 ~N (n1; h2; sym n2)) in g.--}---- | Coercion optimisation options-newtype OptCoercionOpts = OptCoercionOpts-   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)-   }--optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo--- ^ optCoercion applies a substitution to a coercion,---   *and* optimises it to reduce its size-optCoercion opts env co-  | optCoercionEnabled opts-  = optCoercion' env co-{--  = pprTrace "optCoercion {" (text "Co:" <+> ppr co) $-    let result = optCoercion' env co in-    pprTrace "optCoercion }" (vcat [ text "Co:" <+> ppr co-                                   , text "Optco:" <+> ppr result ]) $-    result--}--  | otherwise-  = substCo env co---optCoercion' :: Subst -> Coercion -> NormalCo-optCoercion' env co-  | debugIsOn-  = let out_co = opt_co1 lc False co-        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co-        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co-    in-    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 (vcat [ text "in_co:" <+> ppr co-                          , text "in_ty1:" <+> ppr in_ty1-                          , text "in_ty2:" <+> ppr in_ty2-                          , text "out_co:" <+> ppr out_co-                          , text "out_ty1:" <+> ppr out_ty1-                          , text "out_ty2:" <+> ppr out_ty2-                          , text "in_role:" <+> ppr in_role-                          , text "out_role:" <+> ppr out_role-                          , vcat $ map ppr_one $ nonDetEltsUniqSet $ coVarsOfCo co-                          , text "subst:" <+> ppr env ]))-               out_co--  | otherwise         = opt_co1 lc False co-  where-    lc = mkSubstLiftingContext env-    ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv)---type NormalCo    = Coercion-  -- Invariants:-  --  * The substitution has been fully applied-  --  * For trans coercions (co1 `trans` co2)-  --       co1 is not a trans, and neither co1 nor co2 is identity--type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity---- | Do we apply a @sym@ to the result?-type SymFlag = Bool---- | Do we force the result to be representational?-type ReprFlag = Bool---- | Optimize a coercion, making no assumptions. All coercions in--- the lifting context are already optimized (and sym'd if nec'y)-opt_co1 :: LiftingContext-        -> SymFlag-        -> Coercion -> NormalCo-opt_co1 env sym co = opt_co2 env sym (coercionRole co) co---- See Note [Optimising coercion optimisation]--- | Optimize a coercion, knowing the coercion's role. No other assumptions.-opt_co2 :: LiftingContext-        -> SymFlag-        -> Role   -- ^ The role of the input coercion-        -> Coercion -> NormalCo-opt_co2 env sym Phantom co = opt_phantom env sym co-opt_co2 env sym r       co = opt_co3 env sym Nothing r co---- See Note [Optimising coercion optimisation]--- | Optimize a coercion, knowing the coercion's non-Phantom role.-opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo-opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co-opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True  r co-  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore-opt_co3 env sym _                       r co = opt_co4_wrap env sym False r co---- See Note [Optimising coercion optimisation]--- | Optimize a non-phantom coercion.-opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag-                      -> Role -> Coercion -> NormalCo--- Precondition: In every call (opt_co4 lc sym rep role co)---               we should have role = coercionRole co-opt_co4_wrap = opt_co4--{--opt_co4_wrap env sym rep r co-  = pprTrace "opt_co4_wrap {"-    ( vcat [ text "Sym:" <+> ppr sym-           , text "Rep:" <+> ppr rep-           , text "Role:" <+> ppr r-           , text "Co:" <+> ppr co ]) $-    assert (r == coercionRole co )    $-    let result = opt_co4 env sym rep r co in-    pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $-    result--}---opt_co4 env _   rep r (Refl ty)-  = assertPpr (r == Nominal)-              (text "Expected role:" <+> ppr r    $$-               text "Found role:" <+> ppr Nominal $$-               text "Type:" <+> ppr ty) $-    liftCoSubst (chooseRole rep r) env ty--opt_co4 env _   rep r (GRefl _r ty MRefl)-  = assertPpr (r == _r)-              (text "Expected role:" <+> ppr r $$-               text "Found role:" <+> ppr _r   $$-               text "Type:" <+> ppr ty) $-    liftCoSubst (chooseRole rep r) env ty--opt_co4 env sym  rep r (GRefl _r ty (MCo co))-  = assertPpr (r == _r)-              (text "Expected role:" <+> ppr r $$-               text "Found role:" <+> ppr _r   $$-               text "Type:" <+> ppr ty) $-    if isGReflCo co || isGReflCo co'-    then liftCoSubst r' env ty-    else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)-  where-    r'  = chooseRole rep r-    ty' = substTy (lcSubstLeft env) ty-    co' = opt_co4 env False False Nominal co--opt_co4 env sym rep r (SymCo co)  = opt_co4_wrap env (not sym) rep r co-  -- surprisingly, we don't have to do anything to the env here. This is-  -- because any "lifting" substitutions in the env are tied to ForAllCos,-  -- which treat their left and right sides differently. We don't want to-  -- exchange them.--opt_co4 env sym rep r g@(TyConAppCo _r tc cos)-  = assert (r == _r) $-    case (rep, r) of-      (True, Nominal) ->-        mkTyConAppCo Representational tc-                     (zipWith3 (opt_co3 env sym)-                               (map Just (tyConRoleListRepresentational tc))-                               (repeat Nominal)-                               cos)-      (False, Nominal) ->-        mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos)-      (_, Representational) ->-                      -- must use opt_co2 here, because some roles may be P-                      -- See Note [Optimising coercion optimisation]-        mkTyConAppCo r tc (zipWith (opt_co2 env sym)-                                   (tyConRoleListRepresentational tc)  -- the current roles-                                   cos)-      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)--opt_co4 env sym rep r (AppCo co1 co2)-  = mkAppCo (opt_co4_wrap env sym rep r co1)-            (opt_co4_wrap env sym False Nominal co2)--opt_co4 env sym rep r (ForAllCo tv k_co co)-  = case optForAllCoBndr env sym tv k_co of-      (env', tv', k_co') -> mkForAllCo tv' k_co' $-                            opt_co4_wrap env' sym rep r co-     -- Use the "mk" functions to check for nested Refls--opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2)-  = assert (r == _r) $-    mkFunCo2 r' afl' afr' cow' co1' co2'-  where-    co1' = opt_co4_wrap env sym rep r co1-    co2' = opt_co4_wrap env sym rep r co2-    cow' = opt_co1 env sym cow-    !r' | rep       = Representational-        | otherwise = r-    !(afl', afr') | sym       = (afr,afl)-                  | otherwise = (afl,afr)--opt_co4 env sym rep r (CoVarCo cv)-  | Just co <- lookupCoVar (lcSubst env) cv-  = opt_co4_wrap (zapLiftingContext env) sym rep r co--  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]-  = mkReflCo (chooseRole rep r) ty1--  | otherwise-  = assert (isCoVar cv1 )-    wrapRole rep r $ wrapSym sym $-    CoVarCo cv1--  where-    Pair ty1 ty2 = coVarTypes cv1--    cv1 = case lookupInScope (lcInScopeSet env) cv of-             Just cv1 -> cv1-             Nothing  -> warnPprTrace True-                          "opt_co: not in scope"-                          (ppr cv $$ ppr env)-                          cv-          -- cv1 might have a substituted kind!--opt_co4 _ _ _ _ (HoleCo h)-  = pprPanic "opt_univ fell into a hole" (ppr h)--opt_co4 env sym rep r (AxiomInstCo con ind cos)-    -- Do *not* push sym inside top-level axioms-    -- e.g. if g is a top-level axiom-    --   g a : f a ~ a-    -- then (sym (g ty)) /= g (sym ty) !!-  = assert (r == coAxiomRole con )-    wrapRole rep (coAxiomRole con) $-    wrapSym sym $-                       -- some sub-cos might be P: use opt_co2-                       -- See Note [Optimising coercion optimisation]-    AxiomInstCo con ind (zipWith (opt_co2 env False)-                                 (coAxBranchRoles (coAxiomNthBranch con ind))-                                 cos)-      -- Note that the_co does *not* have sym pushed into it--opt_co4 env sym rep r (UnivCo prov _r t1 t2)-  = assert (r == _r )-    opt_univ env sym prov (chooseRole rep r) t1 t2--opt_co4 env sym rep r (TransCo co1 co2)-                      -- sym (g `o` h) = sym h `o` sym g-  | sym       = opt_trans in_scope co2' co1'-  | otherwise = opt_trans in_scope co1' co2'-  where-    co1' = opt_co4_wrap env sym rep r co1-    co2' = opt_co4_wrap env sym rep r co2-    in_scope = lcInScopeSet env--opt_co4 env _sym rep r (SelCo n co)-  | Just (ty, _co_role) <- isReflCo_maybe co-  = liftCoSubst (chooseRole rep r) env (getNthFromType n ty)-    -- NB: it is /not/ true that r = _co_role-    --     Rather, r = coercionRole (SelCo n co)--opt_co4 env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos))-  = assert (r == r1 )-    opt_co4_wrap env sym rep r (cos `getNth` n)---- see the definition of GHC.Builtin.Types.Prim.funTyCon-opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2))-  = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2)--opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _))-      -- works for both tyvar and covar-  = opt_co4_wrap env sym rep Nominal eta--opt_co4 env sym rep r (SelCo n co)-  | Just nth_co <- case (co', n) of-      (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n)-      (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2)-      (ForAllCo _ eta _, SelForAll)      -> Just eta-      _                  -> Nothing-  = if rep && (r == Nominal)-      -- keep propagating the SubCo-    then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co-    else nth_co--  | otherwise-  = wrapRole rep r $ SelCo n co'-  where-    co' = opt_co1 env sym co--opt_co4 env sym rep r (LRCo lr co)-  | Just pr_co <- splitAppCo_maybe co-  = assert (r == Nominal )-    opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)-  | Just pr_co <- splitAppCo_maybe co'-  = assert (r == Nominal) $-    if rep-    then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)-    else pick_lr lr pr_co-  | otherwise-  = wrapRole rep Nominal $ LRCo lr co'-  where-    co' = opt_co4_wrap env sym False Nominal co--    pick_lr CLeft  (l, _) = l-    pick_lr CRight (_, r) = r---- See Note [Optimising InstCo]-opt_co4 env sym rep r (InstCo co1 arg)-    -- forall over type...-  | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1-  = opt_co4_wrap (extendLiftingContext env tv-                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))-                   -- mkSymCo kind_co :: k1 ~ k2-                   -- sym_arg :: (t1 :: k1) ~ (t2 :: k2)-                   -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)-                 sym rep r co_body--    -- forall over coercion...-  | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1-  , CoercionTy h1 <- t1-  , CoercionTy h2 <- t2-  = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2-    in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body--    -- See if it is a forall after optimization-    -- If so, do an inefficient one-variable substitution, then re-optimize--    -- forall over type...-  | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1'-  = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'-                    (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))-            False False r' co_body'--    -- forall over coercion...-  | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1'-  , CoercionTy h1' <- t1'-  , CoercionTy h2' <- t2'-  = let new_co = mk_new_co cv' kind_co' h1' h2'-    in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co)-                    False False r' co_body'--  | otherwise = InstCo co1' arg'-  where-    co1'    = opt_co4_wrap env sym rep r co1-    r'      = chooseRole rep r-    arg'    = opt_co4_wrap env sym False Nominal arg-    sym_arg = wrapSym sym arg'--    -- Performance note: don't be alarmed by the two calls to coercionKind-    -- here, as only one call to coercionKind is actually demanded per guard.-    -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used-    -- when checking if co1' (i.e., co1 post-optimization) is a forall.-    ---    -- t1/t2 must come from sym_arg, not arg', since it's possible that arg'-    -- might have an extra Sym at the front (after being optimized) that co1-    -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725)-    Pair t1  t2  = coercionKind sym_arg-    Pair t1' t2' = coercionKind arg'--    mk_new_co cv kind_co h1 h2-      = let -- h1 :: (t1 ~ t2)-            -- h2 :: (t3 ~ t4)-            -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)-            -- n1 :: t1 ~ t3-            -- n2 :: t2 ~ t4-            -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)-            r2  = coVarRole cv-            kind_co' = downgradeRole r2 Nominal kind_co-            n1 = mkSelCo (SelTyCon 2 r2) kind_co'-            n2 = mkSelCo (SelTyCon 3 r2) kind_co'-         in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1-                           (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))--opt_co4 env sym _rep r (KindCo co)-  = assert (r == Nominal) $-    let kco' = promoteCoercion co in-    case kco' of-      KindCo co' -> promoteCoercion (opt_co1 env sym co')-      _          -> opt_co4_wrap env sym False Nominal kco'-  -- This might be able to be optimized more to do the promotion-  -- and substitution/optimization at the same time--opt_co4 env sym _ r (SubCo co)-  = assert (r == Representational) $-    opt_co4_wrap env sym True Nominal co---- This could perhaps be optimized more.-opt_co4 env sym rep r (AxiomRuleCo co cs)-  = assert (r == coaxrRole co) $-    wrapRole rep r $-    wrapSym sym $-    AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)--{- Note [Optimise CoVarCo to Refl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have (c :: t~t) we can optimise it to Refl. That increases the-chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)--We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]-in GHC.Core.Coercion.--}------------------ | Optimize a phantom coercion. The input coercion may not necessarily--- be a phantom, but the output sure will be.-opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo-opt_phantom env sym co-  = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2-  where-    Pair ty1 ty2 = coercionKind co--{- Note [Differing kinds]-   ~~~~~~~~~~~~~~~~~~~~~~-The two types may not have the same kind (although that would be very unusual).-But even if they have the same kind, and the same type constructor, the number-of arguments in a `CoTyConApp` can differ. Consider--  Any :: forall k. k--  Any * Int                      :: *-  Any (*->*) Maybe Int  :: *--Hence the need to compare argument lengths; see #13658--Note [opt_univ needs injectivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it-by producing a TyConAppCo for T, and pushing the UnivCo into the arguments.  But-this works only if T is injective. Otherwise we can have something like--  type family F x where-    F Int  = Int-    F Bool = Int--where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an-alternative representation for a couple of uses of AxiomInstCos) but we do not-want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly-inconsistent.  Hence the opt_univ case for TyConApps checks isInjectiveTyCon.-See #19509.-- -}--opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role-         -> Type -> Type -> Coercion-opt_univ env sym (PhantomProv h) _r ty1 ty2-  | sym       = mkPhantomCo h' ty2' ty1'-  | otherwise = mkPhantomCo h' ty1' ty2'-  where-    h' = opt_co4 env sym False Nominal h-    ty1' = substTy (lcSubstLeft  env) ty1-    ty2' = substTy (lcSubstRight env) ty2--opt_univ env sym prov role oty1 oty2-  | Just (tc1, tys1) <- splitTyConApp_maybe oty1-  , Just (tc2, tys2) <- splitTyConApp_maybe oty2-  , tc1 == tc2-  , isInjectiveTyCon tc1 role  -- see Note [opt_univ needs injectivity]-  , equalLength tys1 tys2 -- see Note [Differing kinds]-      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);-      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps-  = let roles    = tyConRoleListX role tc1-        arg_cos  = zipWith3 (mkUnivCo prov') roles tys1 tys2-        arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos-    in-    mkTyConAppCo role tc1 arg_cos'--  -- can't optimize the AppTy case because we can't build the kind coercions.--  | Just (tv1, ty1) <- splitForAllTyVar_maybe oty1-  , Just (tv2, ty2) <- splitForAllTyVar_maybe oty2-      -- NB: prov isn't interesting here either-  = let k1   = tyVarKind tv1-        k2   = tyVarKind tv2-        eta  = mkUnivCo prov' Nominal k1 k2-          -- eta gets opt'ed soon, but not yet.-        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2--        (env', tv1', eta') = optForAllCoBndr env sym tv1 eta-    in-    mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2')--  | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1-  , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2-      -- NB: prov isn't interesting here either-  = let k1    = varType cv1-        k2    = varType cv2-        r'    = coVarRole cv1-        eta   = mkUnivCo prov' Nominal k1 k2-        eta_d = downgradeRole r' Nominal eta-          -- eta gets opt'ed soon, but not yet.-        n_co  = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo`-                (mkCoVarCo cv1) `mkTransCo`-                (mkSelCo (SelTyCon 3 r') eta_d)-        ty2'  = substTyWithCoVars [cv2] [n_co] ty2--        (env', cv1', eta') = optForAllCoBndr env sym cv1 eta-    in-    mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2')--  | otherwise-  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1-        ty2 = substTyUnchecked (lcSubstRight env) oty2-        (a, b) | sym       = (ty2, ty1)-               | otherwise = (ty1, ty2)-    in-    mkUnivCo prov' role a b--  where-    prov' = case prov of-#if __GLASGOW_HASKELL__ < 901--- This alt is redundant with the first match of the FunDef-      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco-#endif-      ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco-      PluginProv _       -> prov-      CorePrepProv _     -> prov----------------opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]-opt_transList is = zipWithEqual "opt_transList" (opt_trans is)-  -- The input lists must have identical length.--opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo-opt_trans is co1 co2-  | isReflCo co1 = co2-    -- optimize when co1 is a Refl Co-  | otherwise    = opt_trans1 is co1 co2--opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo--- First arg is not the identity-opt_trans1 is co1 co2-  | isReflCo co2 = co1-    -- optimize when co2 is a Refl Co-  | otherwise    = opt_trans2 is co1 co2--opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo--- Neither arg is the identity-opt_trans2 is (TransCo co1a co1b) co2-    -- Don't know whether the sub-coercions are the identity-  = opt_trans is co1a (opt_trans is co1b co2)--opt_trans2 is co1 co2-  | Just co <- opt_trans_rule is co1 co2-  = co--opt_trans2 is co1 (TransCo co2a co2b)-  | Just co1_2a <- opt_trans_rule is co1 co2a-  = if isReflCo co1_2a-    then co2b-    else opt_trans1 is co1_2a co2b--opt_trans2 _ co1 co2-  = mkTransCo co1 co2----------- Optimize coercions with a top-level use of transitivity.-opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo--opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))-  = assert (r1 == r2) $-    fireTransRule "GRefl" in_co1 in_co2 $-    mkGReflRightCo r1 t1 (opt_trans is co1 co2)---- Push transitivity through matching destructors-opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)-  | d1 == d2-  , coercionRole co1 == coercionRole co2-  , co1 `compatible_co` co2-  = fireTransRule "PushNth" in_co1 in_co2 $-    mkSelCo d1 (opt_trans is co1 co2)--opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)-  | d1 == d2-  , co1 `compatible_co` co2-  = fireTransRule "PushLR" in_co1 in_co2 $-    mkLRCo d1 (opt_trans is co1 co2)---- Push transitivity inside instantiation-opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)-  | ty1 `eqCoercion` ty2-  , co1 `compatible_co` co2-  = fireTransRule "TrPushInst" in_co1 in_co2 $-    mkInstCo (opt_trans is co1 co2) ty1--opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)-                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)-  | Just prov' <- opt_trans_prov p1 p2-  = assert (r1 == r2) $-    fireTransRule "UnivCo" in_co1 in_co2 $-    mkUnivCo prov' r1 tyl1 tyr2-  where-    -- if the provenances are different, opt'ing will be very confusing-    opt_trans_prov (PhantomProv kco1)    (PhantomProv kco2)-      = Just $ PhantomProv $ opt_trans is kco1 kco2-    opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)-      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2-    opt_trans_prov (PluginProv str1)     (PluginProv str2)     | str1 == str2 = Just p1-    opt_trans_prov _ _ = Nothing---- Push transitivity down through matching top-level constructors.-opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)-  | tc1 == tc2-  = assert (r1 == r2) $-    fireTransRule "PushTyConApp" in_co1 in_co2 $-    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)--opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)-                  in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)-  = assert (r1 == r2)     $     -- Just like the TyConAppCo/TyConAppCo case-    assert (afr1 == afl2) $-    fireTransRule "PushFun" in_co1 in_co2 $-    mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2)-                          (opt_trans is co1a co2a)-                          (opt_trans is co1b co2b)--opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)-  -- Must call opt_trans_rule_app; see Note [EtaAppCo]-  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]---- Eta rules-opt_trans_rule is co1@(TyConAppCo r tc cos1) co2-  | Just cos2 <- etaTyConAppCo_maybe tc co2-  = fireTransRule "EtaCompL" co1 co2 $-    mkTyConAppCo r tc (opt_transList is cos1 cos2)--opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)-  | Just cos1 <- etaTyConAppCo_maybe tc co1-  = fireTransRule "EtaCompR" co1 co2 $-    mkTyConAppCo r tc (opt_transList is cos1 cos2)--opt_trans_rule is co1@(AppCo co1a co1b) co2-  | Just (co2a,co2b) <- etaAppCo_maybe co2-  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]--opt_trans_rule is co1 co2@(AppCo co2a co2b)-  | Just (co1a,co1b) <- etaAppCo_maybe co1-  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]---- Push transitivity inside forall--- forall over types.-opt_trans_rule is co1 co2-  | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1-  , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2-  = push_trans tv1 eta1 r1 tv2 eta2 r2--  | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2-  , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1-  = push_trans tv1 eta1 r1 tv2 eta2 r2--  where-  push_trans tv1 eta1 r1 tv2 eta2 r2-    -- Given:-    --   co1 = /\ tv1 : eta1. r1-    --   co2 = /\ tv2 : eta2. r2-    -- Wanted:-    --   /\tv1 : (eta1;eta2).  (r1; r2[tv2 |-> tv1 |> eta1])-    = fireTransRule "EtaAllTy_ty" co1 co2 $-      mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')-    where-      is' = is `extendInScopeSet` tv1-      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2---- Push transitivity inside forall--- forall over coercions.-opt_trans_rule is co1 co2-  | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1-  , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2-  = push_trans cv1 eta1 r1 cv2 eta2 r2--  | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2-  , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1-  = push_trans cv1 eta1 r1 cv2 eta2 r2--  where-  push_trans cv1 eta1 r1 cv2 eta2 r2-    -- Given:-    --   co1 = /\ cv1 : eta1. r1-    --   co2 = /\ cv2 : eta2. r2-    -- Wanted:-    --   n1 = nth 2 eta1-    --   n2 = nth 3 eta1-    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])-    = fireTransRule "EtaAllTy_co" co1 co2 $-      mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')-    where-      is'  = is `extendInScopeSet` cv1-      role = coVarRole cv1-      eta1' = downgradeRole role Nominal eta1-      n1   = mkSelCo (SelTyCon 2 role) eta1'-      n2   = mkSelCo (SelTyCon 3 role) eta1'-      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo`-                                        (mkCoVarCo cv1) `mkTransCo` n2])-                    r2---- Push transitivity inside axioms-opt_trans_rule is co1 co2--  -- See Note [Why call checkAxInstCo during optimisation]-  -- TrPushSymAxR-  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe-  , True <- sym-  , Just cos2 <- matchAxiom sym con ind co2-  , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst--  -- TrPushAxR-  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe-  , False <- sym-  , Just cos2 <- matchAxiom sym con ind co2-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushAxR" co1 co2 newAxInst--  -- TrPushSymAxL-  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe-  , True <- sym-  , Just cos1 <- matchAxiom (not sym) con ind co1-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst--  -- TrPushAxL-  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe-  , False <- sym-  , Just cos1 <- matchAxiom (not sym) con ind co1-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)-  , Nothing <- checkAxInstCo newAxInst-  = fireTransRule "TrPushAxL" co1 co2 newAxInst--  -- TrPushAxSym/TrPushSymAx-  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe-  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe-  , con1 == con2-  , ind1 == ind2-  , sym1 == not sym2-  , let branch = coAxiomNthBranch con1 ind1-        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch-        lhs  = coAxNthLHS con1 ind1-        rhs  = coAxBranchRHS branch-        pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)-  , all (`elemVarSet` pivot_tvs) qtvs-  = fireTransRule "TrPushAxSym" co1 co2 $-    if sym2-       -- TrPushAxSym-    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs-       -- TrPushSymAx-    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs-  where-    co1_is_axiom_maybe = isAxiom_maybe co1-    co2_is_axiom_maybe = isAxiom_maybe co2-    role = coercionRole co1 -- should be the same as coercionRole co2!--opt_trans_rule _ co1 co2        -- Identity rule-  | let ty1 = coercionLKind co1-        r   = coercionRole co1-        ty2 = coercionRKind co2-  , ty1 `eqType` ty2-  = fireTransRule "RedTypeDirRefl" co1 co2 $-    mkReflCo r ty2--opt_trans_rule _ _ _ = Nothing---- See Note [EtaAppCo]-opt_trans_rule_app :: InScopeSet-                   -> Coercion   -- original left-hand coercion (printing only)-                   -> Coercion   -- original right-hand coercion (printing only)-                   -> Coercion   -- left-hand coercion "function"-                   -> [Coercion] -- left-hand coercion "args"-                   -> Coercion   -- right-hand coercion "function"-                   -> [Coercion] -- right-hand coercion "args"-                   -> Maybe Coercion-opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs-  | AppCo co1aa co1ab <- co1a-  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a-  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)--  | AppCo co2aa co2ab <- co2a-  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a-  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)--  | otherwise-  = assert (co1bs `equalLength` co2bs) $-    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $-    let rt1a = coercionRKind co1a--        lt2a = coercionLKind co2a-        rt2a = coercionRole  co2a--        rt1bs = map coercionRKind co1bs-        lt2bs = map coercionLKind co2bs-        rt2bs = map coercionRole co2bs--        kcoa = mkKindCo $ buildCoercion lt2a rt1a-        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs--        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a-        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs-        co2bs'' = zipWith mkTransCo co2bs' co2bs-    in-    mkAppCos (opt_trans is co1a co2a')-             (zipWith (opt_trans is) co1bs co2bs'')--fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion-fireTransRule _rule _co1 _co2 res-  = Just res--{--Note [Conflict checking with AxiomInstCo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 }--We wish to disallow (axEqual[1] <*> <Int> <Int). (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".--Note [Why call checkAxInstCo during optimisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is possible that otherwise-good-looking optimisations meet with disaster-in the presence of axioms with multiple equations. Consider--type family Equal (a :: *) (b :: *) :: Bool where-  Equal a a = True-  Equal a b = False-type family Id (a :: *) :: * where-  Id a = a--axEq :: { [a::*].       Equal a a ~ True-        ; [a::*, b::*]. Equal a b ~ False }-axId :: [a::*]. Id a ~ a--co1 = Equal (axId[0] Int) (axId[0] Bool)-  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool-co2 = axEq[1] <Int> <Bool>-  :: Equal Int Bool ~ False--We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that-co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what-happens when we push the coercions inside? We get--co3 = axEq[1] (axId[0] Int) (axId[0] Bool)-  :: 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-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.--Note [EtaAppCo]-~~~~~~~~~~~~~~~-Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd-like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that-the resultant coercions might not be well kinded. Here is an example (things-labeled with x don't matter in this example):--  k1 :: Type-  k2 :: Type--  a :: k1 -> Type-  b :: k1--  h :: k1 ~ k2--  co1a :: x1 ~ (a |> (h -> <Type>)-  co1b :: x2 ~ (b |> h)--  co2a :: a ~ x3-  co2b :: b ~ x4--First, convince yourself of the following:--  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)-  co2a co2b :: a b   ~ x3 x4--  (a |> (h -> <Type>)) (b |> h) `eqType` a b--That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,-where we ignore coercions in types as long as two types' kinds are the same.-In our case, we meet this last condition, because--  (a |> (h -> <Type>)) (b |> h) :: Type-    and-  a b :: Type--So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the-suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the-kinds don't match up.--The solution here is to twiddle the kinds in the output coercions. First, we-need to find coercions--  ak :: kind(a |> (h -> <Type>)) ~ kind(a)-  bk :: kind(b |> h)             ~ kind(b)--This can be done with mkKindCo and buildCoercion. The latter assumes two-types are identical modulo casts and builds a coercion between them.--Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the-output coercions. These are well-kinded.--Also, note that all of this is done after accumulated any nested AppCo-parameters. This step is to avoid quadratic behavior in calling coercionKind.--The problem described here was first found in dependent/should_compile/dynamic-paper.---}---- | Check to make sure that an AxInstCo is internally consistent.--- Returns the conflicting branch, if it exists--- See Note [Conflict checking with AxiomInstCo]-checkAxInstCo :: Coercion -> Maybe CoAxBranch--- 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-checkAxInstCo (AxiomInstCo ax ind cos)-  = let branch       = coAxiomNthBranch ax ind-        tvs          = coAxBranchTyVars branch-        cvs          = coAxBranchCoVars branch-        incomps      = coAxBranchIncomps branch-        (tys, cotys) = splitAtList tvs (map coercionLKind cos)-        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 in-    check_no_conflict flattened_target incomps-  where-    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-checkAxInstCo _ = Nothing---------------wrapSym :: SymFlag -> Coercion -> Coercion-wrapSym sym co | sym       = mkSymCo co-               | otherwise = co---- | Conditionally set a role to be representational-wrapRole :: ReprFlag-         -> Role         -- ^ current role-         -> Coercion -> Coercion-wrapRole False _       = id-wrapRole True  current = downgradeRole Representational current---- | If we require a representational role, return that. Otherwise,--- return the "default" role provided.-chooseRole :: ReprFlag-           -> Role    -- ^ "default" role-           -> Role-chooseRole True _ = Representational-chooseRole _    r = r--------------isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])-isAxiom_maybe (SymCo co)-  | Just (sym, con, ind, cos) <- isAxiom_maybe co-  = Just (not sym, con, ind, cos)-isAxiom_maybe (AxiomInstCo con ind cos)-  = Just (False, con, ind, cos)-isAxiom_maybe _ = Nothing--matchAxiom :: Bool -- True = match LHS, False = match RHS-           -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion]-matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co-  | CoAxBranch { cab_tvs = qtvs-               , cab_cvs = []   -- can't infer these, so fail if there are any-               , cab_roles = roles-               , cab_lhs = lhs-               , cab_rhs = rhs } <- coAxiomNthBranch ax ind-  , Just subst <- liftCoMatch (mkVarSet qtvs)-                              (if sym then (mkTyConApp tc lhs) else rhs)-                              co-  , all (`isMappedByLC` subst) qtvs-  = zipWithM (liftCoSubstTyVar subst) roles qtvs--  | otherwise-  = Nothing----------------compatible_co :: Coercion -> Coercion -> Bool--- Check whether (co1 . co2) will be well-kinded-compatible_co co1 co2-  = x1 `eqType` x2-  where-    x1 = coercionRKind co1-    x2 = coercionLKind co2----------------{--etaForAllCo-~~~~~~~~~~~~~~~~~-(1) etaForAllCo_ty_maybe-Suppose we have--  g : all a1:k1.t1  ~  all a2:k2.t2--but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:--  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))--Call the kind coercion h1 and the body coercion h2. We can see that--  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]--According to the typing rule for ForAllCo, we get that--  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])--or--  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])--as desired.--(2) etaForAllCo_co_maybe-Suppose we have--  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2--Similarly, we do this--  g' = all c1:h1. h2-     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]-                                              [c1 |-> eta1;c1;sym eta2]--Here,--  h1   = mkSelCo Nominal 0 g       :: (s1~s2)~(s3~s4)-  eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3)-  eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)-  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))--}-etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)--- Try to make the coercion be of form (forall tv:kind_co. co)-etaForAllCo_ty_maybe co-  | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co-  = Just (tv, kind_co, r)--  | Pair ty1 ty2  <- coercionKind co-  , Just (tv1, _) <- splitForAllTyVar_maybe ty1-  , isForAllTy_ty ty2-  , let kind_co = mkSelCo SelForAll co-  = Just ( tv1, kind_co-         , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co))--  | otherwise-  = Nothing--etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)--- Try to make the coercion be of form (forall cv:kind_co. co)-etaForAllCo_co_maybe co-  | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co-  = Just (cv, kind_co, r)--  | Pair ty1 ty2  <- coercionKind co-  , Just (cv1, _) <- splitForAllCoVar_maybe ty1-  , isForAllTy_co ty2-  = let kind_co  = mkSelCo SelForAll co-        r        = coVarRole cv1-        l_co     = mkCoVarCo cv1-        kind_co' = downgradeRole r Nominal kind_co-        r_co     = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co')-                   `mkTransCo` l_co-                   `mkTransCo` mkSelCo (SelTyCon 3 r) kind_co'-    in Just ( cv1, kind_co-            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))--  | otherwise-  = Nothing--etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)--- If possible, split a coercion---   g :: t1a t1b ~ t2a t2b--- into a pair of coercions (left g, right g)-etaAppCo_maybe co-  | Just (co1,co2) <- splitAppCo_maybe co-  = Just (co1,co2)-  | (Pair ty1 ty2, Nominal) <- coercionKindRole co-  , Just (_,t1) <- splitAppTy_maybe ty1-  , Just (_,t2) <- splitAppTy_maybe ty2-  , let isco1 = isCoercionTy t1-  , let isco2 = isCoercionTy t2-  , isco1 == isco2-  = Just (LRCo CLeft co, LRCo CRight co)-  | otherwise-  = Nothing--etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]--- If possible, split a coercion---       g :: T s1 .. sn ~ T t1 .. tn--- into [ SelCo (SelTyCon 0)     g :: s1~t1---      , ...---      , SelCo (SelTyCon (n-1)) g :: sn~tn ]-etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)-  = assert (tc == tc2) $ Just cos2--etaTyConAppCo_maybe tc co-  | not (tyConMustBeSaturated tc)-  , (Pair ty1 ty2, r) <- coercionKindRole co-  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1-  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2-  , tc1 == tc2-  , isInjectiveTyCon tc r  -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep-  , let n = length tys1-  , tys2 `lengthIs` n      -- This can fail in an erroneous program-                           -- E.g. T a ~# T a b-                           -- #14607-  = assert (tc == tc1) $-    Just (decomposeCo n co (tyConRolesX r tc1))-    -- NB: n might be <> tyConArity tc-    -- e.g.   data family T a :: * -> *-    --        g :: T a b ~ T c d--  | otherwise-  = Nothing--{--Note [Eta for AppCo]-~~~~~~~~~~~~~~~~~~~~-Suppose we have-   g :: s1 t1 ~ s2 t2--Then we can't necessarily make-   left  g :: s1 ~ s2-   right g :: t1 ~ t2-because it's possible that-   s1 :: * -> *         t1 :: *-   s2 :: (*->*) -> *    t2 :: * -> *-and in that case (left g) does not have the same-kind on either side.--It's enough to check that-  kind t1 = kind t2-because if g is well-kinded then-  kind (s1 t2) = kind (s2 t2)-and these two imply-  kind s1 = kind s2---}--optForAllCoBndr :: LiftingContext -> Bool-                -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)-optForAllCoBndr env sym-  = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env+   , OptCoercionOpts (..)+   )+where++import GHC.Prelude++import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Compare( eqType, eqForAllVis )+import GHC.Core.Coercion+import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.Unify++import GHC.Types.Basic( SwapFlag(..), flipSwap, isSwapped, pickSwap, notSwapped )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env++import GHC.Data.Pair++import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Panic++import Control.Monad   ( zipWithM )++{-+%************************************************************************+%*                                                                      *+                 Optimising coercions+%*                                                                      *+%************************************************************************++This module does coercion optimisation.  See the paper++   Evidence normalization in Systtem FV (RTA'13)+   https://simon.peytonjones.org/evidence-normalization/++The paper is also in the GHC repo, in docs/opt-coercion.++Note [Optimising coercion optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Looking up a coercion's role or kind is linear in the size of the+coercion. Thus, doing this repeatedly during the recursive descent+of coercion optimisation is disastrous. We must be careful to avoid+doing this if at all possible.++Because it is generally easy to know a coercion's components' roles+from the role of the outer coercion, we pass down the known role of+the input in the algorithm below. We also keep functions opt_co2+and opt_co3 separate from opt_co4, so that the former two do Phantom+checks that opt_co4 can avoid. This is a big win because Phantom coercions+rarely appear within non-phantom coercions -- only in some TyConAppCos+and some AxiomInstCos. We handle these cases specially by calling+opt_co2.++Note [Optimising InstCo]+~~~~~~~~~~~~~~~~~~~~~~~~+Optimising InstCo is pretty subtle: #15725, #25387.++(1) tv is a type variable. We want to optimise++  InstCo (ForAllCo tv kco g) g2  -->   S(g)++where S is some substitution. Let's look at the typing rules.++    kco : k1 ~ k2+    tv:k1 |- g : t1 ~ t2+    -----------------------------+    ForAllCo tv kco g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym kco])++    g1 : (all tv:k1.t1') ~ (all tv:k2.t2')+    g2 : (s1:k1) ~ (s2:k2)+    --------------------+    InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]++Putting these two together++    kco : k1 ~ k2+    tv:k1 |- g : t1 ~ t2+    g2 : (s1:k1) ~ (s2:k2)+    --------------------+    InstCo (ForAllCo tv kco g) g2 : t1[tv |-> s1] ~ t2[tv |-> s2 |> sym kco]++We thus want S(g) to have kind++  S(g) :: (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym kco])++All we need do is to substitute the coercion tv_co for tv:+  S = [tv :-> tv_co]+where+  tv_co : s1 ~ (s2 |> sym kco)+This looks bizarre, because we're substituting a /type variable/ with a+/coercion/. However, this operation already exists: it's called *lifting*, and+defined in GHC.Core.Coercion.  We just need to enhance the lifting operation to+be able to deal with an ambient substitution, which is why a LiftingContext+stores a TCvSubst.++In general if+  S = [tv :-> tv_co]+  tv_co : r1 ~ r2+  g     : t1 ~ t2+then+  S(g) : t1[tv :-> r1] ~ t2[tv :-> r2]++The substitution S is embodied in the LiftingContext argument of `opt_co4`;+See Note [The LiftingContext in optCoercion]++(2) cv is a coercion variable+Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.++h : (t1 ~r t2) ~N (t3 ~r t4)+cv : t1 ~r t2 |- g : t1' ~r2 t2'+n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3+n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4+------------------------------------------------+ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2+                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])++g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')+g2 : h1 ~N h2+h1 : t1 ~r t2+h2 : t3 ~r t4+------------------------------------------------+InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]++We thus want some coercion proving this:++  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]++So we substitute the coercion variable c for the coercion+(h1 ~N (n1; h2; sym n2)) in g.++Note [The LiftingContext in optCoercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To suppport Note [Optimising InstCo] the coercion optimiser carries a+GHC.Core.Coercion.LiftingContext, which comprises+  * An ordinary Subst+  * The `lc_env`: a mapping from /type variables/ to /coercions/++We don't actually have a separate function+   liftCoSubstCo :: LiftingContext -> Coercion -> Coercion+The substitution of a type variable by a coercion is done by the calls to+`liftCoSubst` (on a type) in the Refl and GRefl cases of `opt_co4`.++We use the following invariants:+ (LC1) The coercions in the range of `lc_env` have already had all substitutions+       applied; they are "OutCoercions".  If you re-optimise these coercions, you+       must zap the LiftingContext first.++ (LC2) However they have /not/ had the "ambient sym" (the second argument of+       `opt_co4`) applied.  The ambient sym applies to the entire coercion not+       to the little bits being substituted.+-}++-- | Coercion optimisation options+newtype OptCoercionOpts = OptCoercionOpts+   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)+   }++optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo+-- ^ optCoercion applies a substitution to a coercion,+--   *and* optimises it to reduce its size+optCoercion opts env co+  | optCoercionEnabled opts+  = optCoercion' env co++{-+  = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $+    let result = optCoercion' env co in+    pprTrace "optCoercion }"+       (vcat [ text "Co:"    <+> ppr (coercionSize co)+             , text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)")+                             <+> ppr (coercionSize result) ]) $+    result+-}++  | otherwise+  = substCo env co++optCoercion' :: Subst -> Coercion -> NormalCo+optCoercion' env co+  | debugIsOn+  = let out_co = opt_co1 lc NotSwapped co+        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co+        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co++        details = vcat [ text "in_co:" <+> ppr co+                       , text "in_ty1:" <+> ppr in_ty1+                       , text "in_ty2:" <+> ppr in_ty2+                       , text "out_co:" <+> ppr out_co+                       , text "out_ty1:" <+> ppr out_ty1+                       , text "out_ty2:" <+> ppr out_ty2+                       , text "in_role:" <+> ppr in_role+                       , text "out_role:" <+> ppr out_role+                       ]+    in+    warnPprTrace (not (isReflCo out_co) && isReflexiveCo out_co)+                 "optCoercion: reflexive but not refl" 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+  = opt_co1 lc NotSwapped co+  where+    lc = mkSubstLiftingContext env+--    ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv)+++type NormalCo    = Coercion+  -- Invariants:+  --  * The substitution has been fully applied+  --  * For trans coercions (co1 `trans` co2)+  --       co1 is not a trans, and neither co1 nor co2 is identity++type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity++-- | Do we force the result to be representational?+type ReprFlag = Bool++-- | Optimize a coercion, making no assumptions. All coercions in+-- the lifting context are already optimized (and sym'd if nec'y)+opt_co1 :: LiftingContext+        -> SwapFlag   -- IsSwapped => apply Sym to the result+        -> Coercion -> NormalCo+opt_co1 env sym co = opt_co2 env sym (coercionRole co) co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's role. No other assumptions.+opt_co2 :: LiftingContext+        -> SwapFlag   -- ^IsSwapped => apply Sym to the result+        -> Role       -- ^ The role of the input coercion+        -> Coercion -> NormalCo+opt_co2 env sym Phantom co = opt_phantom env sym co+opt_co2 env sym r       co = opt_co4 env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's non-Phantom role,+--   and with an optional downgrade+opt_co3 :: LiftingContext -> SwapFlag -> Maybe Role -> Role -> Coercion -> NormalCo+opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co+opt_co3 env sym (Just Representational) r co = opt_co4 env sym True  r co+  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore+opt_co3 env sym _                       r co = opt_co4 env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a non-phantom coercion.+opt_co4, opt_co4' :: LiftingContext -> SwapFlag -> ReprFlag+                  -> Role -> Coercion -> NormalCo+-- Precondition:  In every call (opt_co4 lc sym rep role co)+--                we should have role = coercionRole co+-- Precondition:  role is not Phantom+-- Postcondition: The resulting coercion is equivalant to+--                     wrapsub (wrapsym (mksub co)+--                 where wrapsym is SymCo if sym=True+--                       wrapsub is SubCo if rep=True++-- opt_co4 is there just to support tracing, when debugging+-- Usually it just goes straight to opt_co4'+opt_co4 = opt_co4'++{-+opt_co4 env sym rep r co+  = pprTrace "opt_co4 {"+   ( vcat [ text "Sym:" <+> ppr sym+          , text "Rep:" <+> ppr rep+          , text "Role:" <+> ppr r+          , text "Co:" <+> ppr co ]) $+   assert (r == coercionRole co )    $+   let result = opt_co4' env sym rep r co in+   pprTrace "opt_co4 }" (ppr co $$ text "---" $$ ppr result) $+   assertPpr (res_role == coercionRole result)+             (vcat [ text "Role:" <+> ppr r+                   , text "Result: " <+>  ppr result+                   , text "Result type:" <+> ppr (coercionType result) ]) $+   result++  where+    res_role | rep       = Representational+             | otherwise = r+-}++opt_co4' env sym rep r (Refl ty)+  = assertPpr (r == Nominal)+              (text "Expected role:" <+> ppr r    $$+               text "Found role:" <+> ppr Nominal $$+               text "Type:" <+> ppr ty) $+    wrapSym sym $ liftCoSubst (chooseRole rep r) env ty+        -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion]++opt_co4' env sym rep r (GRefl _r ty MRefl)+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $+    wrapSym sym $ liftCoSubst (chooseRole rep r) env ty+        -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion]++opt_co4' env sym  rep r (GRefl _r ty (MCo kco))+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $+    if isGReflCo kco || isGReflCo kco'+    then wrapSym sym ty_co+    else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co+            -- ty :: k1+            -- kco :: k1 ~ k2+            -- Desired result coercion:   ty ~ ty |> co+  where+    r'    = chooseRole rep r+    ty_co = liftCoSubst r' env ty+    kco'  = opt_co4 env NotSwapped False Nominal kco++opt_co4' env sym rep r (SymCo co)  = opt_co4 env (flipSwap sym) rep r co+  -- surprisingly, we don't have to do anything to the env here. This is+  -- because any "lifting" substitutions in the env are tied to ForAllCos,+  -- which treat their left and right sides differently. We don't want to+  -- exchange them.++opt_co4' env sym rep r g@(TyConAppCo _r tc cos)+  = assert (r == _r) $+    case (rep, r) of+      (True, Nominal) ->+        mkTyConAppCo Representational tc+                     (zipWith3 (opt_co3 env sym)+                               (map Just (tyConRoleListRepresentational tc))+                               (repeat Nominal)+                               cos)+      (False, Nominal) ->+        mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos)+      (_, Representational) ->+                      -- must use opt_co2 here, because some roles may be P+                      -- See Note [Optimising coercion optimisation]+        mkTyConAppCo r tc (zipWith (opt_co2 env sym)+                                   (tyConRoleListRepresentational tc)  -- the current roles+                                   cos)+      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)++opt_co4' env sym rep r (AppCo co1 co2)+  = mkAppCo (opt_co4 env sym rep r co1)+            (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 })+  = 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)+  = assert (r == _r) $+    mkFunCo2 r' afl' afr' cow' co1' co2'+  where+    co1' = opt_co4 env sym rep r co1+    co2' = opt_co4 env sym rep r co2+    cow' = opt_co1 env sym cow+    !r' | rep       = Representational+        | otherwise = r+    !(afl', afr') = swapSym sym (afl, afr)++opt_co4' env sym rep r (CoVarCo cv)+  | Just co <- lcLookupCoVar env cv   -- see Note [Forall over coercion] for why+                                      -- this is the right thing here+  = -- pprTrace "CoVarCo" (ppr cv $$ ppr co) $+    opt_co4 (zapLiftingContext env) sym rep r co++  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]+  = mkReflCo (chooseRole rep r) ty1++  | otherwise+  = assert (isCoVar cv1) $+    wrapRole rep r $ wrapSym sym $+    CoVarCo cv1++  where+    Pair ty1 ty2 = coVarTypes cv1++    cv1 = case lookupInScope (lcInScopeSet env) cv of+             Just cv1 -> cv1+             Nothing  -> warnPprTrace True+                          "opt_co: not in scope"+                          (ppr cv $$ ppr env)+                          cv+          -- cv1 might have a substituted kind!++opt_co4' _ _ _ _ (HoleCo h)+  = pprPanic "opt_univ fell into a hole" (ppr h)++opt_co4' env sym rep r (AxiomCo con cos)+    -- Do *not* push sym inside top-level axioms+    -- e.g. if g is a top-level axiom+    --   g a : f a ~ a+    -- then (sym (g ty)) /= g (sym ty) !!+  = assert (r == coAxiomRuleRole con )+    wrapRole rep (coAxiomRuleRole con) $+    wrapSym sym $+                       -- some sub-cos might be P: use opt_co2+                       -- See Note [Optimising coercion optimisation]+    AxiomCo con (zipWith (opt_co2 env NotSwapped)+                         (coAxiomRuleArgRoles con)+                         cos)+      -- Note that the_co does *not* have sym pushed into it++opt_co4' env sym rep r (UnivCo { uco_prov = prov, uco_lty = t1+                              , uco_rty = t2, uco_deps = deps })+  = opt_univ env sym prov deps (chooseRole rep r) t1 t2++opt_co4' env sym rep r (TransCo co1 co2)+  -- sym (g `o` h) = sym h `o` sym g+  | isSwapped sym = opt_trans in_scope co2' co1'+  | otherwise     = opt_trans in_scope co1' co2'+  where+    co1' = opt_co4 env sym rep r co1+    co2' = opt_co4 env sym rep r co2+    in_scope = lcInScopeSet env++opt_co4' env sym rep r (SelCo cs co)+  -- Historical note 1: we used to check `co` for Refl, TyConAppCo etc+  -- before optimising `co`; but actually the SelCo will have been built+  -- with mkSelCo, so these tests always fail.++  -- Historical note 2: if rep=True and r=Nominal, we used to recursively+  -- call opt_co4 to re-optimse the result. But (a) that is inefficient+  -- and (b) wrapRole uses mkSubCo which does much the same job+  = wrapRole rep r $ mkSelCo cs $ opt_co1 env sym co++opt_co4' env sym rep r (LRCo lr co)+  | Just pr_co <- splitAppCo_maybe co+  = assert (r == Nominal )+    opt_co4 env sym rep Nominal (pick_lr lr pr_co)+  | Just pr_co <- splitAppCo_maybe co'+  = assert (r == Nominal) $+    if rep+    then opt_co4 (zapLiftingContext env) NotSwapped True Nominal (pick_lr lr pr_co)+    else pick_lr lr pr_co+  | otherwise+  = wrapRole rep Nominal $ LRCo lr co'+  where+    co' = opt_co4 env sym False Nominal co++    pick_lr CLeft  (l, _) = l+    pick_lr CRight (_, r) = r++{-+Note [Forall over coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example:+  type (:~:) :: forall k. k -> k -> Type+  Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b+  k1,k2,k3,k4 :: Type+  eta :: (k1 ~# k2) ~# (k3 ~# k4)    ==    ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4)+  co1_3 :: k1 ~# k3+  co2_4 :: k2 ~# k4+  nth 2 eta :: k1 ~# k3+  nth 3 eta :: k2 ~# k4+  co11_31 :: <k1> ~# (sym co1_3)+  co22_24 :: <k2> ~# co2_4+  (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) ::+    (forall (cv :: k1 ~# k2). Refl Type k1 k2 (<k1> ;; cv ;; <k2>) ~#+    (forall (cv :: k3 ~# k4). Refl Type k3 k4+       (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))+  co1_2 :: k1 ~# k2+  co3_4 :: k3 ~# k4+  co5 :: co1_2 ~# co3_4+  InstCo (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 ::+   (Refl Type k1 k2 (<k1> ;; cv ;; <k2>))[cv |-> co1_2] ~#+   (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4]+      ==+   (Refl Type k1 k2 (<k1> ;; co1_2 ;; <k2>)) ~#+    (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4))+      ==>+   Refl <Type> co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24)+Conclusion: Because of the way this all works, we want to put in the *left-hand*+coercion in co5's type. (In the code, co5 is called `arg`.)+So we extend the environment binding cv to arg's left-hand type.+-}++-- See Note [Optimising InstCo]+opt_co4' env sym rep r (InstCo fun_co arg_co)+    -- forall over type...+  | Just (tv, _visL, _visR, k_co, body_co) <- splitForAllCo_ty_maybe fun_co+    -- tv      :: k1+    -- k_co    :: k1 ~ k2+    -- body_co :: t1 ~ t2+    -- arg_co  :: (s1:k1) ~ (s2:k2)+  , let arg_co'  = opt_co4 env NotSwapped False Nominal arg_co+                  -- Do /not/ push Sym into the arg_co, hence sym=False+                  -- see (LC2) of Note [The LiftingContext in optCoercion]+        k_co' = opt_co4 env NotSwapped False Nominal k_co+        s2'   = coercionRKind arg_co'+        tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co'+                   -- mkSymCo kind_co :: k2 ~ k1+                   -- tv_co   :: (s1 :: k1) ~ (((s2 :: k2) |> (sym kind_co)) :: k1)+  = opt_co4 (extendLiftingContext env tv tv_co) sym rep r body_co++    -- See Note [Forall over coercion]+  | Just (cv, _visL, _visR, _kind_co, body_co) <- splitForAllCo_co_maybe fun_co+  , CoercionTy h1 <- coercionLKind arg_co+  , let h1' = opt_co4 env NotSwapped False Nominal h1+  = opt_co4 (extendLiftingContextCvSubst env cv h1') sym rep r body_co++  -- OK so those cases didn't work.  See if it is a forall /after/ optimization+  -- If so, do an inefficient one-variable substitution, then re-optimize++    -- forall over type...+  | Just (tv', _visL, _visR, k_co', body_co') <- splitForAllCo_ty_maybe fun_co'+  , let s2'   = coercionRKind arg_co'+        tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co'+        env'  = extendLiftingContext (zapLiftingContext env) tv' tv_co+  = opt_co4 env' NotSwapped False r' body_co'++    -- See Note [Forall over coercion]+  | Just (cv', _visL, _visR, _kind_co', body_co') <- splitForAllCo_co_maybe fun_co'+  , CoercionTy h1' <- coercionLKind arg_co'+  , let env' = extendLiftingContextCvSubst (zapLiftingContext env) cv' h1'+  = opt_co4 env' NotSwapped False r' body_co'++  -- Those cases didn't work either, so rebuild the InstCo+  -- Push Sym into /both/ function /and/ arg_coument+  | otherwise = InstCo fun_co' arg_co'++  where+    -- fun_co' arg_co' are both optimised, /and/ we have pushed `sym` into both+    -- So no more sym'ing on th results of fun_co' arg_co'+    fun_co' = opt_co4 env sym rep r fun_co+    arg_co' = opt_co4 env sym False Nominal arg_co+    r'   = chooseRole rep r++opt_co4' env sym _rep r (KindCo co)+  = assert (r == Nominal) $+    let kco' = promoteCoercion co in+    case kco' of+      KindCo co' -> promoteCoercion (opt_co1 env sym co')+      _          -> opt_co4 env sym False Nominal kco'+  -- This might be able to be optimized more to do the promotion+  -- and substitution/optimization at the same time++opt_co4' env sym _ r (SubCo co)+  = assert (r == Representational) $+    opt_co4 env sym True Nominal co++{- Note [Optimise CoVarCo to Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have (c :: t~t) we can optimise it to Refl. That increases the+chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)++We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]+in GHC.Core.Coercion.+-}++-------------+-- | Optimize a phantom coercion. The input coercion may not necessarily+-- be a phantom, but the output sure will be.+opt_phantom :: LiftingContext -> SwapFlag -> Coercion -> NormalCo+opt_phantom env sym (UnivCo { uco_prov = prov, uco_lty = t1+                            , uco_rty = t2, uco_deps = deps })+  = opt_univ env sym prov deps Phantom t1 t2++opt_phantom env sym co+  = opt_univ env sym PhantomProv [mkKindCo co] Phantom ty1 ty2+  where+    Pair ty1 ty2 = coercionKind co++{- Note [Differing kinds]+   ~~~~~~~~~~~~~~~~~~~~~~+The two types may not have the same kind (although that would be very unusual).+But even if they have the same kind, and the same type constructor, the number+of arguments in a `CoTyConApp` can differ. Consider++  Any :: forall k. k++  Any @Type Int                :: Type+  Any @(Type->Type) Maybe Int  :: Type++Hence the need to compare argument lengths; see #13658++Note [opt_univ needs injectivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it+by producing a TyConAppCo for T, and pushing the UnivCo into the arguments.  But+this works only if T is injective. Otherwise we can have something like++  type family F x where+    F Int  = Int+    F Bool = Int++where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an+alternative representation for a couple of uses of AxiomInstCos) but we do not+want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly+inconsistent.  Hence the opt_univ case for TyConApps checks isInjectiveTyCon.+See #19509.++ -}++opt_univ :: LiftingContext -> SwapFlag -> UnivCoProvenance+         -> [Coercion]+         -> Role -> Type -> Type -> Coercion+opt_univ env sym prov deps role ty1 ty2+  = let ty1'  = substTyUnchecked (lcSubstLeft  env) ty1+        ty2'  = substTyUnchecked (lcSubstRight env) ty2+        deps' = map (opt_co1 env sym) deps+        (ty1'', ty2'') = swapSym sym (ty1', ty2')+    in+    mkUnivCo prov deps' role ty1'' ty2''++{-+opt_univ env PhantomProv cvs _r ty1 ty2+  = mkUnivCo PhantomProv cvs Phantom ty1' ty2'+  where+    ty1' = substTy (lcSubstLeft  env) ty1+    ty2' = substTy (lcSubstRight env) ty2++opt_univ1 env prov cvs' role oty1 oty2+  | Just (tc1, tys1) <- splitTyConApp_maybe oty1+  , Just (tc2, tys2) <- splitTyConApp_maybe oty2+  , tc1 == tc2+  , isInjectiveTyCon tc1 role  -- see Note [opt_univ needs injectivity]+  , equalLength tys1 tys2 -- see Note [Differing kinds]+      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);+      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps+  = let roles    = tyConRoleListX role tc1+        arg_cos  = zipWith3 (mkUnivCo prov cvs') roles tys1 tys2+        arg_cos' = zipWith (opt_co4 env False False) roles arg_cos+    in+    mkTyConAppCo role tc1 arg_cos'++  -- can't optimize the AppTy case because we can't build the kind coercions.++  | Just (Bndr tv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isTyVar tv2+      -- NB: prov isn't interesting here either+  = let k1   = tyVarKind tv1+        k2   = tyVarKind tv2+        eta  = mkUnivCo prov cvs' Nominal k1 k2+          -- eta gets opt'ed soon, but not yet.+        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2++        (env', tv1', eta') = optForAllCoBndr env False tv1 eta+    in+    mkForAllCo tv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2')++  | Just (Bndr cv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isCoVar cv2+      -- NB: prov isn't interesting here either+  = let k1    = varType cv1+        k2    = varType cv2+        r'    = coVarRole cv1+        eta   = mkUnivCo prov cvs' Nominal k1 k2+        eta_d = downgradeRole r' Nominal eta+          -- eta gets opt'ed soon, but not yet.+        n_co  = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo`+                (mkCoVarCo cv1) `mkTransCo`+                (mkSelCo (SelTyCon 3 r') eta_d)+        ty2'  = substTyWithCoVars [cv2] [n_co] ty2++        (env', cv1', eta') = optForAllCoBndr env False cv1 eta+    in+    mkForAllCo cv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2')++  | otherwise+  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1+        ty2 = substTyUnchecked (lcSubstRight env) oty2+    in+    mkUnivCo prov cvs' role ty1 ty2+-}++-------------+opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]+opt_transList is = zipWithEqual (opt_trans is)+  -- The input lists must have identical length.++opt_trans :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo++-- opt_trans just allows us to add some debug tracing+-- Usually it just goes to opt_trans'+opt_trans is co1 co2+  = -- (if coercionRKind co1 `eqType` coercionLKind co2+    --  then (\x -> x) else+    --  pprTrace "opt_trans" (vcat [ text "co1" <+> ppr co1+    --                             , text "co2" <+> ppr co2+    --                             , text "co1 kind" <+> ppr (coercionKind co1)+    --                             , text "co2 kind" <+> ppr (coercionKind co2)+    --                             , callStackDoc ])) $+    opt_trans' is co1 co2++{-+opt_trans is co1 co2+  = assertPpr (r1==r2) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2]) $+    assertPpr (rres == r1) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2, text "res" <+> ppr rres <+> ppr res ]) $+    res+  where+    res = opt_trans' is co1 co2+    rres = coercionRole res+    r1 = coercionRole co1+    r2 = coercionRole co1+-}++opt_trans' :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo+opt_trans' is co1 co2+  | isReflCo co1 = co2+    -- optimize when co1 is a Refl Co+  | otherwise    = opt_trans1 is co1 co2++opt_trans1 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo+-- First arg is not the identity+opt_trans1 is co1 co2+  | isReflCo co2 = co1+    -- optimize when co2 is a Refl Co+  | otherwise    = opt_trans2 is co1 co2++opt_trans2 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo+-- Neither arg is the identity+opt_trans2 is (TransCo co1a co1b) co2+    -- Don't know whether the sub-coercions are the identity+  = opt_trans is co1a (opt_trans is co1b co2)++opt_trans2 is co1 co2+  | Just co <- opt_trans_rule is co1 co2+  = co++opt_trans2 is co1 (TransCo co2a co2b)+  | Just co1_2a <- opt_trans_rule is co1 co2a+  = if isReflCo co1_2a+    then co2b+    else opt_trans1 is co1_2a co2b++opt_trans2 _ co1 co2+  = mk_trans_co co1 co2+++------+-- Optimize coercions with a top-level use of transitivity.+opt_trans_rule :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo++opt_trans_rule _ in_co1 in_co2+  | assertPpr (coercionRKind in_co1 `eqType` coercionLKind in_co2)+              (vcat [ text "in_co1" <+> ppr in_co1+                   , text "in_co2" <+> ppr in_co2+                   , text "in_co1 kind" <+> ppr (coercionKind in_co1)+                   , text "in_co2 kind" <+> ppr (coercionKind in_co2)+                   , callStackDoc ]) $+    False+  = panic "opt_trans_rule"  -- This entire equation is purely assertion checking++opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _t2 (MCo co2))+  = assert (r1 == r2) $+    fireTransRule "GRefl" in_co1 in_co2 $+    mk_grefl_right_co r1 t1 (opt_trans is co1 co2)++-- Push transitivity through matching destructors+opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)+  | d1 == d2+  , coercionRole co1 == coercionRole co2+  , co1 `compatible_co` co2+  = fireTransRule "PushNth" in_co1 in_co2 $+    mkSelCo d1 (opt_trans is co1 co2)++opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)+  | d1 == d2+  , co1 `compatible_co` co2+  = fireTransRule "PushLR" in_co1 in_co2 $+    mkLRCo d1 (opt_trans is co1 co2)++-- Push transitivity inside instantiation+opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)+  | ty1 `eqCoercion` ty2+  , co1 `compatible_co` co2+  = fireTransRule "TrPushInst" in_co1 in_co2 $+    mkInstCo (opt_trans is co1 co2) ty1++opt_trans_rule _+    in_co1@(UnivCo { uco_prov = p1, uco_role = r1, uco_lty = tyl1, uco_deps = deps1 })+    in_co2@(UnivCo { uco_prov = p2, uco_role = r2, uco_rty = tyr2, uco_deps = deps2 })+  | p1 == p2    -- If the provenances are different, opt'ing will be very confusing+  = assert (r1 == r2) $+    fireTransRule "UnivCo" in_co1 in_co2 $+    mkUnivCo p1 (deps1 ++ deps2) r1 tyl1 tyr2++-- Push transitivity down through matching top-level constructors.+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)+  | tc1 == tc2+  = assert (r1 == r2) $+    fireTransRule "PushTyConApp" in_co1 in_co2 $+    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)++opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)+                  in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)+  = assert (r1 == r2)     $     -- Just like the TyConAppCo/TyConAppCo case+    assert (afr1 == afl2) $+    fireTransRule "PushFun" in_co1 in_co2 $+    mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2)+                          (opt_trans is co1a co2a)+                          (opt_trans is co1b co2b)++opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)+  -- Must call opt_trans_rule_app; see Note [EtaAppCo]+  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]++-- Eta rules+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2+  | Just cos2 <- etaTyConAppCo_maybe tc co2+  = fireTransRule "EtaCompL" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)+  | Just cos1 <- etaTyConAppCo_maybe tc co1+  = fireTransRule "EtaCompR" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1@(AppCo co1a co1b) co2+  | Just (co2a,co2b) <- etaAppCo_maybe co2+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++opt_trans_rule is co1 co2@(AppCo co2a co2b)+  | Just (co1a,co1b) <- etaAppCo_maybe co1+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++-- Push transitivity inside forall+-- forall over types.+opt_trans_rule is co1 co2+  | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1+  , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2++  | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2+  , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2++  where+  push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR+    -- Given:+    --   co1 = /\ tv1 : eta1 <visL, visM>. r1+    --   co2 = /\ tv2 : eta2 <visM, visR>. r2+    -- Wanted:+    --   /\tv1 : (eta1;eta2) <visL, visR>.  (r1; r2[tv2 |-> tv1 |> eta1])+    = fireTransRule "EtaAllTy_ty" co1 co2 $+      mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is' = is `extendInScopeSet` tv1+      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2++-- Push transitivity inside forall+-- forall over coercions.+opt_trans_rule is co1 co2+  | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1+  , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2++  | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2+  , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2++  where+  push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR+    -- Given:+    --   co1 = /\ (cv1 : eta1) <visL, visM>. r1+    --   co2 = /\ (cv2 : eta2) <visM, visR>. r2+    -- Wanted:+    --   n1 = nth 2 eta1+    --   n2 = nth 3 eta1+    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])+    = fireTransRule "EtaAllTy_co" co1 co2 $+      mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is'  = is `extendInScopeSet` cv1+      role = coVarRole cv1+      eta1' = downgradeRole role Nominal eta1+      n1   = mkSelCo (SelTyCon 2 role) eta1'+      n2   = mkSelCo (SelTyCon 3 role) eta1'+      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co`+                                        (mkCoVarCo cv1) `mk_trans_co` n2])+                    r2++-- Push transitivity inside axioms+opt_trans_rule is co1 co2++  -- TrPushAxSym/TrPushSymAx+  -- Put this first!  Otherwise (#23619) we get+  --    newtype N a = MkN a+  --    axN :: forall a. N a ~ a+  -- Now consider (axN ty ; sym (axN ty))+  -- If we put TrPushSymAxR first, we'll get+  --    (axN ty ; sym (axN ty)) :: N ty ~ N ty -- Obviously Refl+  --    --> axN (sym (axN ty))  :: N ty ~ N ty -- Very stupid+  | Just (sym1, axr1, cos1) <- isAxiomCo_maybe co1+  , Just (sym2, axr2, cos2) <- isAxiomCo_maybe co2+  , axr1 == axr2+  , sym1 == flipSwap sym2+  , Just (tc, role, branch) <- coAxiomRuleBranch_maybe axr1+  , let qtvs   = coAxBranchTyVars branch ++ coAxBranchCoVars branch+        lhs    = mkTyConApp tc (coAxBranchLHS branch)+        rhs    = coAxBranchRHS branch+        pivot_tvs = exactTyCoVarsOfType (pickSwap sym2 lhs rhs)+  , all (`elemVarSet` pivot_tvs) qtvs+  = fireTransRule "TrPushAxSym" co1 co2 $+    if isSwapped sym2+       -- TrPushAxSym+    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs+       -- TrPushSymAx+    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs++  -- See Note [Push transitivity inside axioms] and+  -- Note [Push transitivity inside newtype axioms only]+  -- TrPushSymAxR+  | Just (sym, axr, cos1) <- isAxiomCo_maybe co1+  , isSwapped sym+  , Just cos2 <- matchNewtypeBranch sym axr co2+  , let newAxInst = AxiomCo axr (opt_transList is (map mkSymCo cos2) cos1)+  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst++  -- TrPushAxR+  | Just (sym, axr, cos1) <- isAxiomCo_maybe co1+  , notSwapped sym+  , Just cos2 <- matchNewtypeBranch sym axr co2+  , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2)+  = fireTransRule "TrPushAxR" co1 co2 newAxInst++  -- TrPushSymAxL+  | Just (sym, axr, cos2) <- isAxiomCo_maybe co2+  , isSwapped sym+  , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1+  , let newAxInst = AxiomCo axr (opt_transList is cos2 (map mkSymCo cos1))+  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst++  -- TrPushAxL+  | Just (sym, axr, cos2) <- isAxiomCo_maybe co2+  , notSwapped sym+  , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1+  , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2)+  = fireTransRule "TrPushAxL" co1 co2 newAxInst+++opt_trans_rule _ co1 co2        -- Identity rule+  | let ty1 = coercionLKind co1+        r   = coercionRole co1+        ty2 = coercionRKind co2+  , ty1 `eqType` ty2+  = fireTransRule "RedTypeDirRefl" co1 co2 $+    mkReflCo r ty2++opt_trans_rule _ _ _ = Nothing++-- See Note [EtaAppCo]+opt_trans_rule_app :: InScopeSet+                   -> Coercion   -- original left-hand coercion (printing only)+                   -> Coercion   -- original right-hand coercion (printing only)+                   -> Coercion   -- left-hand coercion "function"+                   -> [Coercion] -- left-hand coercion "args"+                   -> Coercion   -- right-hand coercion "function"+                   -> [Coercion] -- right-hand coercion "args"+                   -> Maybe Coercion+opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs+  | AppCo co1aa co1ab <- co1a+  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | AppCo co2aa co2ab <- co2a+  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | otherwise+  = assert (co1bs `equalLength` co2bs) $+    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $+    let rt1a = coercionRKind co1a++        lt2a = coercionLKind co2a+        rt2a = coercionRole  co2a++        rt1bs = map coercionRKind co1bs+        lt2bs = map coercionLKind co2bs+        rt2bs = map coercionRole co2bs++        kcoa = mkKindCo $ buildCoercion lt2a rt1a+        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs++        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a+        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs+        co2bs'' = zipWith mk_trans_co co2bs' co2bs+    in+    mkAppCos (opt_trans is co1a co2a')+             (zipWith (opt_trans is) co1bs co2bs'')++fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion+fireTransRule _rule _co1 _co2 res+  = Just res++{-+Note [Push transitivity inside axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+opt_trans_rule tries to push transitivity inside axioms to deal with cases like+the following:++    newtype N a = MkN a++    axN :: N a ~R# a++    covar :: a ~R# b+    co1 = axN <a> :: N a ~R# a+    co2 = axN <b> :: N b ~R# b++    co :: a ~R# b+    co = sym co1 ; N covar ; co2++When we are optimising co, we want to notice that the two axiom instantiations+cancel out. This is implemented by rules such as TrPushSymAxR, which transforms+    sym (axN <a>) ; N covar+into+    sym (axN covar)+so that TrPushSymAx can subsequently transform+    sym (axN covar) ; axN <b>+into+    covar+which is much more compact. In some perf test cases this kind of pattern can be+generated repeatedly during simplification, so it is very important we squash it+to stop coercions growing exponentially.  For more details see the paper:++    Evidence normalisation in System FC+    Dimitrios Vytiniotis and Simon Peyton Jones+    RTA'13, 2013+    https://www.microsoft.com/en-us/research/publication/evidence-normalization-system-fc-2/+++Note [Push transitivity inside newtype axioms only]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The optimization described in Note [Push transitivity inside axioms] is possible+for both newtype and type family axioms.  However, for type family axioms it is+relatively common to have transitive sequences of axioms instantiations, for+example:++    data Nat = Zero | Suc Nat++    type family Index (n :: Nat) (xs :: [Type]) :: Type where+      Index Zero    (x : xs) = x+      Index (Suc n) (x : xs) = Index n xs++    axIndex :: { forall x::Type. forall xs::[Type]. Index Zero (x : xs) ~ x+               ; forall n::Nat. forall x::Type. forall xs::[Type]. Index (Suc n) (x : xs) ~ Index n xs }++    co :: Index (Suc (Suc Zero)) [a, b, c] ~ c+    co = axIndex[1] <Suc Zero> <a> <[b, c]>+       ; axIndex[1] <Zero> <b> <[c]>+       ; axIndex[0] <c> <[]>++Not only are there no cancellation opportunities here, but calling matchAxiom+repeatedly down the transitive chain is very expensive.  Hence we do not attempt+to push transitivity inside type family axioms.  See #8095, !9210 and related tickets.++This is implemented by opt_trans_rule checking that the axiom is for a newtype+constructor (i.e. not a type family).  Adding these guards substantially+improved performance (reduced bytes allocated by more than 10%) for the tests+CoOpt_Singletons, LargeRecord, T12227, T12545, T13386, T15703, T5030, T8095.++A side benefit is that we do not risk accidentally creating an ill-typed+coercion; see Note [Why call checkAxInstCo during optimisation].++There may exist programs that previously relied on pushing transitivity inside+type family axioms to avoid creating huge coercions, which will regress in+compile time performance as a result of this change.  We do not currently know+of any examples, but if any come to light we may need to reconsider this+behaviour.+++Note [Why call checkAxInstCo during optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: The following is no longer relevant, because we no longer push transitivity+into type family axioms (Note [Push transitivity inside newtype axioms only]).+It is retained for reference in case we change this behaviour in the future.++It is possible that otherwise-good-looking optimisations meet with disaster+in the presence of axioms with multiple equations. Consider++type family Equal (a :: *) (b :: *) :: Bool where+  Equal a a = True+  Equal a b = False+type family Id (a :: *) :: * where+  Id a = a++axEq :: { [a::*].       Equal a a ~ True+        ; [a::*, b::*]. Equal a b ~ False }+axId :: [a::*]. Id a ~ a++co1 = Equal (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool+co2 = axEq[1] <Int> <Bool>+  :: Equal Int Bool ~ False++We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that+co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what+happens when we push the coercions inside? We get++co3 = axEq[1] (axId[0] Int) (axId[0] Bool)+  :: 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 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.++Note [EtaAppCo]+~~~~~~~~~~~~~~~+Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd+like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that+the resultant coercions might not be well kinded. Here is an example (things+labeled with x don't matter in this example):++  k1 :: Type+  k2 :: Type++  a :: k1 -> Type+  b :: k1++  h :: k1 ~ k2++  co1a :: x1 ~ (a |> (h -> <Type>)+  co1b :: x2 ~ (b |> h)++  co2a :: a ~ x3+  co2b :: b ~ x4++First, convince yourself of the following:++  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)+  co2a co2b :: a b   ~ x3 x4++  (a |> (h -> <Type>)) (b |> h) `eqType` a b++That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,+where we ignore coercions in types as long as two types' kinds are the same.+In our case, we meet this last condition, because++  (a |> (h -> <Type>)) (b |> h) :: Type+    and+  a b :: Type++So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the+suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the+kinds don't match up.++The solution here is to twiddle the kinds in the output coercions. First, we+need to find coercions++  ak :: kind(a |> (h -> <Type>)) ~ kind(a)+  bk :: kind(b |> h)             ~ kind(b)++This can be done with mkKindCo and buildCoercion. The latter assumes two+types are identical modulo casts and builds a coercion between them.++Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the+output coercions. These are well-kinded.++Also, note that all of this is done after accumulated any nested AppCo+parameters. This step is to avoid quadratic behavior in calling coercionKind.++The problem described here was first found in dependent/should_compile/dynamic-paper.++-}++-----------+swapSym :: SwapFlag -> (a,a) -> (a,a)+swapSym IsSwapped  (x,y) = (y,x)+swapSym NotSwapped (x,y) = (x,y)++wrapSym :: SwapFlag -> Coercion -> Coercion+wrapSym IsSwapped  co = mkSymCo co+wrapSym NotSwapped co = co++-- | Conditionally set a role to be representational+wrapRole :: ReprFlag+         -> Role         -- ^ current role+         -> Coercion -> Coercion+wrapRole False _       = id+wrapRole True  current = downgradeRole Representational current++-- | If we require a representational role, return that. Otherwise,+-- return the "default" role provided.+chooseRole :: ReprFlag+           -> Role    -- ^ "default" role+           -> Role+chooseRole True _ = Representational+chooseRole _    r = r++-----------+isAxiomCo_maybe :: Coercion -> Maybe (SwapFlag, CoAxiomRule, [Coercion])+-- We don't expect to see nested SymCo; and that lets us write a simple,+-- non-recursive function. (If we see a nested SymCo we'll just fail,+-- which is ok.)+isAxiomCo_maybe (SymCo (AxiomCo ax cos)) = Just (IsSwapped,  ax, cos)+isAxiomCo_maybe (AxiomCo ax cos)         = Just (NotSwapped, ax, cos)+isAxiomCo_maybe _                        = Nothing++matchNewtypeBranch :: SwapFlag -- IsSwapped = match LHS, NotSwapped = match RHS+                   -> CoAxiomRule+                   -> Coercion -> Maybe [Coercion]+matchNewtypeBranch sym axr co+  | Just (tc,branch) <- isNewtypeAxiomRule_maybe axr+  , CoAxBranch { cab_tvs = qtvs+               , cab_cvs = []   -- can't infer these, so fail if there are any+               , cab_roles = roles+               , cab_lhs = lhs+               , cab_rhs = rhs } <- branch+  , Just subst <- liftCoMatch (mkVarSet qtvs)+                              (pickSwap sym rhs (mkTyConApp tc lhs))+                              co+  , all (`isMappedByLC` subst) qtvs+  = zipWithM (liftCoSubstTyVar subst) roles qtvs++  | otherwise+  = Nothing++-------------+compatible_co :: Coercion -> Coercion -> Bool+-- Check whether (co1 . co2) will be well-kinded+compatible_co co1 co2+  = x1 `eqType` x2+  where+    x1 = coercionRKind co1+    x2 = coercionLKind co2++-------------+{-+etaForAllCo+~~~~~~~~~~~~~~~~~+(1) etaForAllCo_ty_maybe+Suppose we have++  g : all a1:k1.t1  ~  all a2:k2.t2++but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:++  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))++Call the kind coercion h1 and the body coercion h2. We can see that++  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]++According to the typing rule for ForAllCo, we get that++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])++or++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])++as desired.++(2) etaForAllCo_co_maybe+Suppose we have++  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2++Similarly, we do this++  g' = all c1:h1. h2+     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]+                                              [c1 |-> eta1;c1;sym eta2]++Here,++  h1   = mkSelCo Nominal 0 g       :: (s1~s2)~(s3~s4)+  eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3)+  eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)+  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))+-}+etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+-- Try to make the coercion be of form (forall tv:kind_co. co)+etaForAllCo_ty_maybe co+  | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co+  = Just (tv, visL, visR, kind_co, r)++  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr tv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isTyVar tv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal) || (vis1 `eqForAllVis` vis2)+  , let kind_co = mkSelCo SelForAll co+  = Just ( tv1, vis1, vis2, kind_co+         , mkInstCo co (mk_grefl_right_co Nominal (TyVarTy tv1) kind_co))++  | otherwise+  = Nothing++etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+-- Try to make the coercion be of form (forall cv:kind_co. co)+etaForAllCo_co_maybe co+  | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co+  = Just (cv, visL, visR, kind_co, r)++  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr cv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isCoVar cv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal)+  = let kind_co  = mkSelCo SelForAll co+        r        = coVarRole cv1+        l_co     = mkCoVarCo cv1+        kind_co' = downgradeRole r Nominal kind_co+        r_co     = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co')+                   `mk_trans_co` l_co+                   `mk_trans_co` mkSelCo (SelTyCon 3 r) kind_co'+    in Just ( cv1, vis1, vis2, kind_co+            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))++  | otherwise+  = Nothing++etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)+-- If possible, split a coercion+--   g :: t1a t1b ~ t2a t2b+-- into a pair of coercions (left g, right g)+etaAppCo_maybe co+  | Just (co1,co2) <- splitAppCo_maybe co+  = Just (co1,co2)+  | (Pair ty1 ty2, Nominal) <- coercionKindRole co+  , Just (_,t1) <- splitAppTy_maybe ty1+  , Just (_,t2) <- splitAppTy_maybe ty2+  , let isco1 = isCoercionTy t1+  , let isco2 = isCoercionTy t2+  , isco1 == isco2+  = Just (LRCo CLeft co, LRCo CRight co)+  | otherwise+  = Nothing++etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]+-- If possible, split a coercion+--       g :: T s1 .. sn ~ T t1 .. tn+-- into [ SelCo (SelTyCon 0)     g :: s1~t1+--      , ...+--      , SelCo (SelTyCon (n-1)) g :: sn~tn ]+etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)+  = assert (tc == tc2) $ Just cos2++etaTyConAppCo_maybe tc co+  | not (tyConMustBeSaturated tc)+  , (Pair ty1 ty2, r) <- coercionKindRole co+  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1+  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2+  , tc1 == tc2+  , isInjectiveTyCon tc r  -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep+  , let n = length tys1+  , tys2 `lengthIs` n      -- This can fail in an erroneous program+                           -- E.g. T a ~# T a b+                           -- #14607+  = assert (tc == tc1) $+    Just (decomposeCo n co (tyConRolesX r tc1))+    -- NB: n might be <> tyConArity tc+    -- e.g.   data family T a :: * -> *+    --        g :: T a b ~ T c d++  | otherwise+  = Nothing++{-+Note [Eta for AppCo]+~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: s1 t1 ~ s2 t2++Then we can't necessarily make+   left  g :: s1 ~ s2+   right g :: t1 ~ t2+because it's possible that+   s1 :: * -> *         t1 :: *+   s2 :: (*->*) -> *    t2 :: * -> *+and in that case (left g) does not have the same+kind on either side.++It's enough to check that+  kind t1 = kind t2+because if g is well-kinded then+  kind (s1 t2) = kind (s2 t2)+and these two imply+  kind s1 = kind s2++-}++{- 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)+-- 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+++{- **********************************************************************+%*                                                                      *+       Assertion-checking versions of functions in Coercion.hs+%*                                                                      *+%********************************************************************* -}++-- We can't check the assertions in the "main" functions of these+-- functions, because the assertions don't hold during zonking.+-- But they are fantastically helpful in finding bugs in the coercion+-- optimiser itself, so I have copied them here with assertions.++mk_trans_co :: HasDebugCallStack => Coercion -> Coercion -> Coercion+-- Do assertion checking in mk_trans_co+mk_trans_co co1 co2+  = assertPpr (coercionRKind co1 `eqType` coercionLKind co2)+              (vcat [ text "co1" <+> ppr co1+                    , text "co2" <+> ppr co2+                    , text "co1 kind" <+> ppr (coercionKind co1)+                    , text "co2 kind" <+> ppr (coercionKind co2)+                    , callStackDoc ]) $+    mkTransCo co1 co2++mk_coherence_right_co :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion+mk_coherence_right_co r ty co co2+  = assertGRefl ty co $+    mkCoherenceRightCo r ty co co2++assertGRefl :: HasDebugCallStack => Type -> Coercion -> r -> r+assertGRefl ty co res+  = assertPpr (typeKind ty `eqType` coercionLKind co)+              (vcat [ pp_ty "ty" ty+                    , pp_co "co" co+                    , callStackDoc ]) $+    res++mk_grefl_right_co :: Role -> Type -> CoercionN -> Coercion+mk_grefl_right_co r ty co+  = assertGRefl ty co $+    mkGReflRightCo r ty co++pp_co :: String -> Coercion -> SDoc+pp_co s co = text s <+> hang (ppr co) 2 (dcolon <+> ppr (coercionKind co))++pp_ty :: String -> Type -> SDoc+pp_ty s ty = text s <+> hang (ppr ty) 2 (dcolon <+> ppr (typeKind ty))+
compiler/GHC/Core/ConLike.hs view
@@ -9,9 +9,12 @@  module GHC.Core.ConLike (           ConLike(..)+        , conLikeConLikeName         , isVanillaConLike         , conLikeArity+        , conLikeVisArity         , conLikeFieldLabels+        , conLikeConInfo         , conLikeInstOrigArgTys         , conLikeUserTyVarBinders         , conLikeExTyCoVars@@ -21,7 +24,6 @@         , conLikeFullSig         , conLikeResTy         , conLikeFieldType-        , conLikesWithFields         , conLikeIsInfix         , conLikeHasBuilder     ) where@@ -29,16 +31,20 @@ import GHC.Prelude  import GHC.Core.DataCon+import GHC.Core.Multiplicity import GHC.Core.PatSyn-import GHC.Utils.Outputable+import GHC.Core.TyCo.Rep (Type, ThetaType)+import GHC.Core.TyCon (tyConDataCons)+import GHC.Core.Type(mkTyConApp) import GHC.Types.Unique-import GHC.Utils.Misc import GHC.Types.Name+import GHC.Types.Name.Reader import GHC.Types.Basic-import GHC.Core.TyCo.Rep (Type, ThetaType)++import GHC.Types.GREInfo import GHC.Types.Var-import GHC.Core.Type(mkTyConApp)-import GHC.Core.Multiplicity+import GHC.Utils.Misc+import GHC.Utils.Outputable  import Data.Maybe( isJust ) import qualified Data.Data as Data@@ -61,6 +67,10 @@ isVanillaConLike (RealDataCon con) = isVanillaDataCon con isVanillaConLike (PatSynCon   ps ) = isVanillaPatSyn  ps +conLikeConLikeName :: ConLike -> ConLikeName+conLikeConLikeName (RealDataCon dc) = DataConName (dataConName dc)+conLikeConLikeName (PatSynCon   ps) = PatSynName  (patSynName  ps)+ {- ************************************************************************ *                                                                      *@@ -103,16 +113,33 @@     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 conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn +-- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'.+conLikeConInfo :: ConLike -> ConInfo+conLikeConInfo con =+  mkConInfo (conLikeConLikeInfo con) (conLikeArity con) (conLikeFieldLabels con)++-- | Compute a 'ConLikeInfo' from a 'ConLike'.+conLikeConLikeInfo :: ConLike -> ConLikeInfo+conLikeConLikeInfo (RealDataCon con)+  = ConIsData { conLikeDataCons = getName <$> tyConDataCons (dataConTyCon con) }+conLikeConLikeInfo (PatSynCon {})+  = ConIsPatSyn+ -- | Returns just the instantiated /value/ argument types of a 'ConLike', -- (excluding dictionary args) conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]@@ -126,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`. @@ -207,13 +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]-conLikesWithFields con_likes lbls = filter 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
@@ -22,7 +22,7 @@         eqSpecPair, eqSpecPreds,          -- ** Field labels-        FieldLabel(..), FieldLabelString,+        FieldLabel(..), flLabel, FieldLabelString,          -- ** Type construction         mkDataCon, fIRST_TAG,@@ -35,6 +35,7 @@         dataConNonlinearType,         dataConDisplayType,         dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,+        dataConConcreteTyVars,         dataConUserTyVars, dataConUserTyVarBinders,         dataConTheta,         dataConStupidTheta,@@ -44,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@@ -69,6 +72,7 @@ import GHC.Prelude  import Language.Haskell.Syntax.Basic+import Language.Haskell.Syntax.Module.Name  import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type@@ -76,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@@ -96,10 +100,11 @@ import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) import GHC.Data.Graph.UnVar  -- UnVarSet and operations +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars )+ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB@@ -107,8 +112,7 @@ import qualified Data.Data as Data import Data.Char import Data.List( find )--import Language.Haskell.Syntax.Module.Name+import Control.DeepSeq  {- Note [Data constructor representation]@@ -141,9 +145,21 @@         case e of { T a' b -> let a = I# a' in ... }  To keep ourselves sane, we name the different versions of the data constructor-differently, as follows.+differently, as follows in Note [Data Constructor Naming]. +The `dcRepType` field of a `DataCon` contains the type of the representation of+the constructor /worker/, also called the Core representation. +The Core representation may differ from the type of the constructor /wrapper/+(built by `mkDataConRep`). Besides unpacking (as seen in the example above),+dictionaries and coercions become explict arguments in the Core representation+of a constructor.++Note that this representation is still *different* from runtime+representation. (Which is what STG uses after unarise).+See Note [Constructor applications in STG] in GHC.Stg.Syntax.++ Note [Data Constructor Naming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each data constructor C has two, and possibly up to four, Names associated with it:@@ -209,7 +225,8 @@ * See Note [Data Constructor Naming] for how the worker and wrapper   are named -* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments+* The workers don't take the dcStupidTheta dicts as arguments, while the+  wrappers currently do  * The wrapper (if it exists) takes dcOrigArgTys as its arguments.   The worker takes dataConRepArgTys as its arguments@@ -365,11 +382,6 @@ -}  -- | A data constructor------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',---             'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma'---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data DataCon   = MkData {         dcName    :: Name,      -- This is the name of the *source data con*@@ -437,13 +449,21 @@         -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames         -- Reason: less confusing, and easier to generate Iface syntax +        -- The type variables of this data constructor that must be+        -- instantiated to concrete types. For example: the RuntimeRep+        -- variables of unboxed tuples and unboxed sums.+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Utils.Concrete.+        dcConcreteTyVars :: ConcreteTyVars,+         -- The type/coercion vars in the order the user wrote them [c,y,x,b]         -- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders is         --    exactly the set of tyvars (*not* covars) of dcExTyCoVars unioned         --    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_.@@ -502,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;@@ -528,7 +560,7 @@                                 --      forall a x y. (a~(x,y), x~y, Ord x) =>                                 --        x -> y -> T a                                 -- (this is *not* of the constructor wrapper Id:-                                --  see Note [Data con representation] below)+                                --  see Note [Data constructor representation])         -- Notice that the existential type parameters come *second*.         -- Reason: in a case expression we may find:         --      case (e :: T t) of@@ -548,24 +580,8 @@   }  -{- Note [TyVarBinders in DataCons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the TyVarBinders in a DataCon and PatSyn:-- * Each argument flag is Inferred or Specified.-   None are Required. (A DataCon is a term-level function; see-   Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep.)--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: @@ -586,12 +602,22 @@  Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~-A `DataCon`'s source arity and core representation arity may differ:-`dcSourceArity` does not take constraints into account, but `dcRepArity` does.+A `DataCon`'s source and core representation may differ, meaning the source+arity (`dcSourceArity`) and the core representation arity (`dcRepArity`) may+differ too. -The additional arguments taken into account by `dcRepArity` include quantified-dictionaries and coercion arguments, lifted and unlifted (despite the unlifted-coercion arguments having a zero-width runtime representation).+Note that the source arity isn't exactly the number of arguments the data con+/wrapper/ has, since `dcSourceArity` doesn't count constraints -- which may+appear in the wrapper through `DatatypeContexts`, or if the constructor stores a+dictionary. In this sense, the source arity counts the number of non-constraint+arguments that appear at the source level.+  On the other hand, the Core representation arity is the number of arguments+of the data constructor in its Core representation, which is also the number+of arguments of the data con /worker/.++The arity might differ since `dcRepArity` takes into account arguments such as+quantified dictionaries and coercion arguments, lifted and unlifted (despite+the unlifted coercion arguments having a zero-width runtime representation). For example:    MkT :: Ord a => a -> T a     dcSourceArity = 1@@ -601,31 +627,57 @@     dcSourceArity = 0     dcRepArity    = 1 +The arity might also differ due to unpacking, for example, consider the+following datatype and its wrapper and worker's type:+   data V = MkV !() !Int+   $WMkV :: () -> Int -> V+     MkV :: Int# -> V+As you see, because of unpacking we have both dropped the unit argument and+unboxed the Int. In this case, the source arity (which is the arity of the+wrapper) is 2, while the Core representation arity (the arity of the worker) is 1. + Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 three 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 --- @@ -714,55 +766,6 @@ equation in the dcEqSpec will be in dcUnivTyVars but *not* in dcUserTyVarBinders. ---- Reason (R3): Kind equalities may have been solved -----Consider now this case:--  type family F a where-    F Type = False-    F _    = True-  type T :: forall k. (F k ~ True) => k -> k -> Type-  data T a b where-    MkT :: T Maybe List--The constraint F k ~ True tells us that T does not want to be indexed by, say,-Int. Now let's consider the Core types involved:--  axiom for F: axF[0] :: F Type ~ False-               axF[1] :: forall a. F a ~ True   (a must be apart from Type)-  tycon: T :: forall k. (F k ~ True) -> k -> k -> Type-  wrapper: MkT :: T @(Type -> Type) @(Eq# (axF[1] (Type -> Type)) Maybe List-  worker:  MkT :: forall k (c :: F k ~ True) (a :: k) (b :: k).-                  (k ~# (Type -> Type), a ~# Maybe, b ~# List) =>-                  T @k @c a b--The key observation here is that the worker quantifies over c, while the wrapper-does not. The worker *must* quantify over c, because c is a universal variable,-and the result of the worker must be the type constructor applied to a sequence-of plain type variables. But the wrapper certainly does not need to quantify over-any evidence that F (Type -> Type) ~ True, as no variables are needed there.--(Aside: the c here is a regular type variable, *not* a coercion variable. This-is because F k ~ True is a *lifted* equality, not the unlifted ~#. This is why-we see Eq# in the type of the wrapper: Eq# boxes the unlifted ~# to become a-lifted ~. See also Note [The equality types story] in GHC.Builtin.Types.Prim about-Eq# and Note [Constraints in kinds] in GHC.Core.TyCo.Rep about having this constraint-in the first place.)--In this case, we'll have these fields of the DataCon:--  dcUserTyVarBinders = []    -- the wrapper quantifies over nothing-  dcUnivTyVars = [k, c, a, b]-  dcExTyCoVars = []  -- no existentials here, but a different constructor might have-  dcEqSpec = [k ~# (Type -> Type), a ~# Maybe, b ~# List]--Note that c is in the dcUserTyVars, but mentioned neither in the dcUserTyVarBinders nor-in the dcEqSpec. We thus have Reason (R3): a variable might be missing from the-dcUserTyVarBinders if its type's kind is Constraint.--(At one point, we thought that the dcEqSpec would have to be non-empty. But that-wouldn't account for silly cases like type T :: (True ~ True) => Type.)- --- End of Reasons ---  INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders@@ -836,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@@ -851,17 +847,18 @@  -- | Haskell Source Bang ----- Bangs on data constructor arguments as the user wrote them in the--- source code.+-- Bangs on data constructor arguments as written by the user, including the+-- source code for exact-printing. -- -- @(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)@-data HsSrcBang =-  HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.SourceText-            SrcUnpackedness-            SrcStrictness+--+-- In the AST, the @SourceText@ is hidden inside the extension point+-- 'Language.Haskell.Syntax.Extension.XConDeclField'.+data HsSrcBang+  = HsSrcBang SourceText SrcUnpackedness SrcStrictness -- See Note [Pragma source text] in "GHC.Types.SourceText"   deriving Data.Data  -- | Haskell Implementation Bang@@ -905,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 @@ -973,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]@@ -983,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,@@ -1018,52 +994,6 @@ The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The dcRepType field contains the type of the representation of a constructor-This may differ from the type of the constructor *Id* (built-by MkId.mkDataConId) for two reasons:-        a) the constructor Id may be overloaded, but the dictionary isn't stored-           e.g.    data Eq a => T a = MkT a a--        b) the constructor may store an unboxed version of a strict field.--So whenever this module talks about the representation of a data constructor-what it means is the DataCon with all Unpacking having been applied.-We can think of this as the Core representation.--Here's an example illustrating the Core representation:-        data Ord a => T a = MkT Int! a Void#-Here-        T :: Ord a => Int -> a -> Void# -> T a-but the rep type is-        Trep :: Int# -> a -> Void# -> T a-Actually, the unboxed part isn't implemented yet!--Note that this representation is still *different* from runtime-representation. (Which is what STG uses after unarise).--This is how T would end up being used in STG post-unarise:--  let x = T 1# y-  in ...-      case x of-        T int a -> ...--The Void# argument is dropped and the boxed int is replaced by an unboxed-one. In essence we only generate binders for runtime relevant values.--We also flatten out unboxed tuples in this process. See the unarise-pass for details on how this is done. But as an example consider-`data S = MkS Bool (# Bool | Char #)` which when matched on would-result in an alternative with three binders like this--    MkS bool tag tpl_field ->--See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation]-for the details of this transformation.-- ************************************************************************ *                                                                      * \subsection{Instances}@@ -1151,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@@ -1165,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@@ -1190,16 +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.-          -> [InvisTVBinder]    -- ^ User-written 'TyVarBinder's.-                                --   These must be Inferred/Specified.-                                --   See @Note [TyVarBinders in DataCons]@+          -> 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+          -> [TyVarBinder]      -- ^ User-written 'TyVarBinder's           -> [EqSpec]           -- ^ GADT equalities           -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper           -> [KnotTied (Scaled Type)]    -- ^ Original argument types@@ -1215,9 +1163,11 @@   -- 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 user_tvbs+          univ_tvs ex_tvs conc_tvs user_tvbs           eq_spec theta           orig_arg_tys orig_res_ty rep_info rep_tycon tag           stupid_theta work_id rep@@ -1232,18 +1182,22 @@   = 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,                   dcUnivTyVars = univ_tvs,                   dcExTyCoVars = ex_tvs,+                  dcConcreteTyVars = conc_tvs,                   dcUserTyVarBinders = user_tvbs,                   dcEqSpec = eq_spec,                   dcOtherTheta = theta,                   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,@@ -1272,18 +1226,16 @@                  -- 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       -- clash in name or unique with the universal/existential ones.       -- Tiresome!  And unnecessary because these tyvars are never looked at-    prom_theta_bndrs = [ mkInvisAnonTyConBinder (mkTyVar n t)-     {- Invisible -}   | (n,t) <- fresh_names `zip` theta ]     prom_arg_bndrs   = [ mkAnonTyConBinder (mkTyVar n t)      {- Visible -}     | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ]-    prom_bndrs       = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs+    prom_bndrs       = prom_tv_bndrs ++ prom_arg_bndrs     prom_res_kind    = orig_res_ty     promoted         = mkPromotedDataCon con name prom_info prom_bndrs                                          prom_res_kind roles rep_info@@ -1301,12 +1253,12 @@     , let uniq = mkAlphaTyVarUnique n           occ = mkTyVarOccFS (mkFastString ('x' : show n)) -    , not (uniq `elementOfUniqSet` avoid_uniqs)+    , not (uniq `memberUniqueSet` avoid_uniqs)     , not (occ `elemOccSet` avoid_occs) ]    where-    avoid_uniqs :: UniqSet Unique-    avoid_uniqs = mkUniqSet (map getUnique avoids)+    avoid_uniqs :: UniqueSet+    avoid_uniqs = fromListUniqueSet (map getUnique avoids)      avoid_occs :: OccSet     avoid_occs = mkOccSet (map getOccName avoids)@@ -1357,15 +1309,24 @@ dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs })   = univ_tvs ++ ex_tvs +-- | Which type variables of this data constructor that must be+-- instantiated to concrete types?+-- For example: the RuntimeRep variables of unboxed tuples and unboxed sums.+--+-- See Note [Representation-polymorphism checking built-ins]+-- in GHC.Tc.Utils.Concrete+dataConConcreteTyVars :: DataCon -> ConcreteTyVars+dataConConcreteTyVars (MkData { dcConcreteTyVars = concs }) = concs+ -- See Note [DataCon user type variable binders] -- | The type variables of the constructor, in the order the user wrote them dataConUserTyVars :: DataCon -> [TyVar] 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.@@ -1382,7 +1343,7 @@   = [ EqSpec tv ty     | cv <- ex_tcvs     , isCoVar cv-    , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv+    , let (ty1, ty, _) = coVarTypesRole cv           tv = getTyVar ty1     ] @@ -1452,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@@ -1479,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@@ -1609,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@@ -1621,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@@ -1737,13 +1711,25 @@ -- evidence, after any flattening has been done and without substituting for -- any type variables dataConRepArgTys :: DataCon -> [Scaled Type]-dataConRepArgTys (MkData { dcRep = rep-                         , dcEqSpec = eq_spec+dataConRepArgTys (MkData { dcRep        = rep+                         , dcEqSpec     = eq_spec                          , dcOtherTheta = theta-                         , dcOrigArgTys = orig_arg_tys })+                         , dcOrigArgTys = orig_arg_tys+                         , dcRepTyCon   = tc })   = case rep of-      NoDataConRep -> assert (null eq_spec) $ map unrestricted theta ++ orig_arg_tys       DCR { dcr_arg_tys = arg_tys } -> arg_tys+      NoDataConRep+        | isTypeDataTyCon tc -> assert (null theta)   $+                                orig_arg_tys+          -- `type data` declarations can be GADTs (and hence have an eq_spec)+          -- but no wrapper.  They cannot have a theta.+          -- See Note [Type data declarations] in GHC.Rename.Module+          -- You might wonder why we ever call dataConRepArgTys for `type data`;+          -- I think it's because of the call in mkDataCon, which in turn feeds+          -- into dcRepArity, which in turn is used in mkDataConWorkId.+          -- c.f. #23022+        | otherwise          -> assert (null eq_spec) $+                                map unrestricted theta ++ orig_arg_tys  -- | The string @package:module.name@ identifying a constructor, which is attached -- to its info table and used by the GHCi debugger and the heap profiler@@ -1806,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@@ -1917,36 +1908,63 @@                               , dcExTyCoVars = ex_tvs                               , dcEqSpec = eq_spec })      -- use of sets here: (R1) from the Note-  = mkUnVarSet depleted_worker_vars == mkUnVarSet depleted_wrapper_vars &&+  = mkUnVarSet depleted_worker_vars == mkUnVarSet wrapper_vars &&     all (not . is_eq_spec_var) wrapper_vars   where-    is_constraint_var v = typeTypeOrConstraint (tyVarKind v) == ConstraintLike-      -- implements (R3) from the Note-     worker_vars = univ_tvs ++ ex_tvs     eq_spec_tvs = mkUnVarSet (map eqSpecTyVar eq_spec)     is_eq_spec_var = (`elemUnVarSet` eq_spec_tvs)  -- (R2) from the Note-    depleted_worker_vars = filterOut (is_eq_spec_var <||> is_constraint_var)-                                     worker_vars+    depleted_worker_vars = filterOut is_eq_spec_var worker_vars      wrapper_vars = dataConUserTyVars dc-    depleted_wrapper_vars = filterOut is_constraint_var wrapper_vars -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,12 +36,11 @@         ruleLhsFreeIds, ruleLhsFreeIdsList,         ruleRhsFreeVars, rulesRhsFreeIds, -        exprFVs,+        exprFVs, exprLocalFVs, addBndrFV, addBndrsFV,          -- * Orphan names-        orphNamesOfType, orphNamesOfTypes,-        orphNamesOfCo,  orphNamesOfCoCon, orphNamesOfAxiomLHS,-        exprsOrphNames,+        orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS,+        orphNamesOfExprs,          -- * Core syntax tree annotation with free variables         FVAnn,                  -- annotation, abstract@@ -97,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@@ -145,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@@ -236,108 +232,90 @@ --                          | 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 _ = emptyFV -{--************************************************************************-*                                                                      *-\section{Free names}-*                                                                      *-************************************************************************--}---- | Finds the free /external/ names of an expression, notably--- including the names of type constructors (which of course do not show--- up in 'exprFreeVars').-exprOrphNames :: CoreExpr -> NameSet--- There's no need to delete local binders, because they will all--- be /internal/ names.-exprOrphNames e-  = go e-  where-    go (Var v)-      | isExternalName n    = unitNameSet n-      | otherwise           = emptyNameSet-      where n = idName v-    go (Lit _)              = emptyNameSet-    go (Type ty)            = orphNamesOfType ty        -- Don't need free tyvars-    go (Coercion co)        = orphNamesOfCo co-    go (App e1 e2)          = go e1 `unionNameSet` go e2-    go (Lam v e)            = go e `delFromNameSet` idName v-    go (Tick _ e)           = go e-    go (Cast e co)          = go e `unionNameSet` orphNamesOfCo co-    go (Let (NonRec _ r) e) = go e `unionNameSet` go r-    go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSet` go e-    go (Case e _ ty as)     = go e `unionNameSet` orphNamesOfType ty-                              `unionNameSet` unionNameSets (map go_alt as)--    go_alt (Alt _ _ r)      = go r---- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details-exprsOrphNames :: [CoreExpr] -> NameSet-exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es-- {- ********************************************************************** %*                                                                      *-                    orphNamesXXX-+                    Orphan names %*                                                                      * %********************************************************************* -} +{- Note [Finding orphan names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions here (orphNamesOfType, orphNamesOfExpr etc) traverse a template:+  * the head of an class instance decl+  * the LHS of a type-family instance+  * the arguments of a RULE+to find TyCons or (in the case of a RULE) Ids, that will be matched against when+matching the template. If none of these orphNames are locally defined, the instance+or RULE is an orphan: see Note [Orphans] in GHC.Core++Wrinkles:+ (ON1) We do not need to look inside coercions, because we never match against+       them.  Indeed, it'd be wrong to do so, because it could make an instance+       into a non-orphan, when it really is an orphan.++ (ON2) These orphNames functions are also (rather separately) used by GHCi, to+       implement :info.  When you say ":info Foo", we show all the instances that+       involve `Foo`; that is, all the instances whose oprhNames include `Foo`.++       To support `:info (->)` we need to ensure that (->) is treated as an orphName+       of FunTy, which is a bit messy since the "real" TyCon is `FUN`+-}+ orphNamesOfTyCon :: TyCon -> NameSet orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of     Nothing  -> emptyNameSet@@ -350,6 +328,8 @@ orphNamesOfType (LitTy {})           = emptyNameSet orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderType bndr)                                        `unionNameSet` orphNamesOfType res+orphNamesOfType (AppTy fun arg)      = orphNamesOfType fun `unionNameSet` orphNamesOfType arg+ orphNamesOfType (TyConApp tycon tys) = func                                        `unionNameSet` orphNamesOfTyCon tycon                                        `unionNameSet` orphNamesOfTypes tys@@ -367,9 +347,9 @@                fun_tc = tyConName (funTyFlagTyCon af) -orphNamesOfType (AppTy fun arg)      = orphNamesOfType fun `unionNameSet` orphNamesOfType arg-orphNamesOfType (CastTy ty co)       = orphNamesOfType ty `unionNameSet` orphNamesOfCo co-orphNamesOfType (CoercionTy co)      = orphNamesOfCo co+-- Coercions: see wrinkle (ON1) of Note [Finding orphan names]+orphNamesOfType (CastTy ty _co)  = orphNamesOfType ty+orphNamesOfType (CoercionTy _co) = emptyNameSet  orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet@@ -377,56 +357,6 @@ orphNamesOfTypes :: [Type] -> NameSet orphNamesOfTypes = orphNamesOfThings orphNamesOfType -orphNamesOfMCo :: MCoercion -> NameSet-orphNamesOfMCo MRefl    = emptyNameSet-orphNamesOfMCo (MCo co) = orphNamesOfCo co--orphNamesOfCo :: Coercion -> NameSet-orphNamesOfCo (Refl ty)             = orphNamesOfType ty-orphNamesOfCo (GRefl _ ty mco)      = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco-orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos-orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2-orphNamesOfCo (ForAllCo _ kind_co co)     = orphNamesOfCo kind_co-                                            `unionNameSet` orphNamesOfCo co-orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 })-                                    = orphNamesOfCo co_mult-                                      `unionNameSet` orphNamesOfCo co1-                                      `unionNameSet` orphNamesOfCo co2-orphNamesOfCo (CoVarCo _)           = emptyNameSet-orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos-orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1-                                      `unionNameSet` orphNamesOfType t2-orphNamesOfCo (SymCo co)            = orphNamesOfCo co-orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2-orphNamesOfCo (SelCo _ co)          = orphNamesOfCo co-orphNamesOfCo (LRCo  _ co)          = orphNamesOfCo co-orphNamesOfCo (InstCo co arg)       = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg-orphNamesOfCo (KindCo co)           = orphNamesOfCo co-orphNamesOfCo (SubCo co)            = orphNamesOfCo co-orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs-orphNamesOfCo (HoleCo _)            = emptyNameSet--orphNamesOfProv :: UnivCoProvenance -> NameSet-orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co-orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co-orphNamesOfProv (PluginProv _)      = emptyNameSet-orphNamesOfProv (CorePrepProv _)    = emptyNameSet--orphNamesOfCos :: [Coercion] -> NameSet-orphNamesOfCos = orphNamesOfThings orphNamesOfCo--orphNamesOfCoCon :: CoAxiom br -> NameSet-orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })-  = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches--orphNamesOfCoAxBranches :: Branches br -> NameSet-orphNamesOfCoAxBranches-  = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches--orphNamesOfCoAxBranch :: CoAxBranch -> NameSet-orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })-  = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs- -- | `orphNamesOfAxiomLHS` collects the names of the concrete types and -- type constructors that make up the LHS of a type family instance, -- including the family name itself.@@ -441,12 +371,45 @@   = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)     `extendNameSet` getName (coAxiomTyCon axiom) --- Detect FUN 'Many as an application of (->), so that :i (->) works as expected+-- Detect (FUN 'Many) as an application of (->), so that :i (->) works as expected -- (see #8535) Issue #16475 describes a more robust solution+-- See wrinkle (ON2) of Note [Finding orphan names] orph_names_of_fun_ty_con :: Mult -> NameSet orph_names_of_fun_ty_con ManyTy = unitNameSet unrestrictedFunTyConName orph_names_of_fun_ty_con _      = emptyNameSet +-- | Finds the free /external/ names of an expression, notably+-- including the names of type constructors (which of course do not show+-- up in 'exprFreeVars').+orphNamesOfExpr :: CoreExpr -> NameSet+-- There's no need to delete local binders, because they will all+-- be /internal/ names.+orphNamesOfExpr e+  = go e+  where+    go (Var v)+      | isExternalName n    = unitNameSet n+      | otherwise           = emptyNameSet+      where n = idName v+    go (Lit _)              = emptyNameSet+    go (Type ty)            = orphNamesOfType ty        -- Don't need free tyvars+    go (Coercion _co)       = emptyNameSet -- See wrinkle (ON1) of Note [Finding orphan names]+    go (App e1 e2)          = go e1 `unionNameSet` go e2+    go (Lam v e)            = go e `delFromNameSet` idName v+    go (Tick _ e)           = go e+    go (Cast e _co)         = go e  -- See wrinkle (ON1) of Note [Finding orphan names]+    go (Let (NonRec _ r) e) = go e `unionNameSet` go r+    go (Let (Rec prs) e)    = orphNamesOfExprs (map snd prs) `unionNameSet` go e+    go (Case e _ ty as)     = go e `unionNameSet` orphNamesOfType ty+                              `unionNameSet` unionNameSets (map go_alt as)++    go_alt (Alt _ _ r)      = go r++-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details+orphNamesOfExprs :: [CoreExpr] -> NameSet+orphNamesOfExprs es = foldr (unionNameSet . orphNamesOfExpr) emptyNameSet es++ {- ************************************************************************ *                                                                      *@@ -468,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@@ -687,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 @@ -736,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] @@ -798,4 +761,3 @@      go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)     go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)-
compiler/GHC/Core/FamInstEnv.hs view
@@ -11,7 +11,7 @@         FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,         famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,         pprFamInst, pprFamInsts, orphNamesOfFamInst,-        mkImportedFamInst,+        mkImportedFamInst, mkLocalFamInst,          FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,         unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList,@@ -38,9 +38,11 @@  import GHC.Prelude +import GHC.Core( IsOrphan, chooseOrphanAnchor ) 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@@ -48,27 +50,30 @@ import GHC.Core.Reduction import GHC.Core.RoughMap import GHC.Core.FVs( orphNamesOfAxiomLHS )++import GHC.Builtin.Types.Literals( tryMatchFam )+ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name-import GHC.Data.FastString-import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc-import Control.Monad-import Data.List( mapAccumL )-import Data.Array( Array, assocs )+import GHC.Types.Name.Set  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain -import GHC.Types.Name.Set+import GHC.Data.FastString+import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.List.Infinite (Infinite (..)) import qualified GHC.Data.List.Infinite as Inf +import Control.Monad+import Data.List( mapAccumL )+import Data.Array( Array, assocs )+ {- ************************************************************************ *                                                                      *@@ -126,6 +131,8 @@             -- in GHC.Core.Coercion.Axiom              , fi_rhs :: Type         --   the RHS, with its freshened vars++            , fi_orphan :: IsOrphan             }  data FamFlavor@@ -241,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@@ -254,6 +261,36 @@ pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) +{- *********************************************************************+*                                                                      *+                 Making FamInsts+*                                                                      *+********************************************************************* -}++mkLocalFamInst :: FamFlavor -> CoAxiom Unbranched+               -> [TyVar] -> [CoVar] -> [Type] -> Type+               -> FamInst+mkLocalFamInst flavor axiom tvs cvs lhs rhs+  = FamInst { fi_fam      = fam_tc_name+            , fi_flavor   = flavor+            , fi_tcs      = roughMatchTcs lhs+            , fi_tvs      = tvs+            , fi_cvs      = cvs+            , fi_tys      = lhs+            , fi_rhs      = rhs+            , fi_axiom    = axiom+            , fi_orphan   = chooseOrphanAnchor orph_names }+  where+    mod = assert (isExternalName (coAxiomName axiom)) $+          nameModule (coAxiomName axiom)+    is_local name = nameIsLocalOrFrom mod name++    orph_names = filterNameSet is_local $+                 orphNamesOfAxiomLHS axiom `extendNameSet` fam_tc_name++    fam_tc_name = tyConName (coAxiomTyCon axiom)++ {- Note [Lazy axiom match] ~~~~~~~~~~~~~~~~~~~~~~~@@ -277,8 +314,9 @@ mkImportedFamInst :: Name               -- Name of the family                   -> [RoughMatchTc]     -- Rough match info                   -> CoAxiom Unbranched -- Axiom introduced+                  -> IsOrphan                   -> FamInst            -- Resulting family instance-mkImportedFamInst fam mb_tcs axiom+mkImportedFamInst fam mb_tcs axiom orphan   = FamInst {       fi_fam    = fam,       fi_tcs    = mb_tcs,@@ -287,7 +325,8 @@       fi_tys    = tys,       fi_rhs    = rhs,       fi_axiom  = axiom,-      fi_flavor = flavor }+      fi_flavor = flavor,+      fi_orphan = orphan }   where      -- See Note [Lazy axiom match]      ~(CoAxBranch { cab_lhs = tys@@ -335,7 +374,7 @@  - For finding overlaps and conflicts   - For finding the representation type...see FamInstEnv.topNormaliseType-   and its call site in GHC.Core.Opt.Simplify+   and its call site in GHC.Core.Opt.Simplify.Iteration   - In standalone deriving instance Eq (T [Int]) we need to find the    representation type for T [Int]@@ -449,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] ~~~~~~~~~~~~~~~~~~~~@@ -474,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:@@ -541,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@@ -572,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]@@ -1155,13 +1195,12 @@    | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc   , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys-  = let co = mkAxInstCo role ax ind inst_tys inst_cos+  = let co = mkAxInstCo role (BranchedAxiom ax ind) inst_tys inst_cos     in Just $ coercionRedn co -  | Just ax           <- isBuiltInSynFamTyCon_maybe tc-  , Just (coax,ts,ty) <- sfMatchFam ax tys-  , role == coaxrRole coax-  = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)+  | Just builtin_fam  <- isBuiltInSynFamTyCon_maybe tc+  , Just (rewrite,ts,ty) <- tryMatchFam builtin_fam tys+  = let co = mkAxiomCo rewrite (map mkNomReflCo ts)     in Just $ mkReduction co ty    | otherwise@@ -1191,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@@ -1214,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@@ -1306,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
@@ -7,18 +7,19 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}  module GHC.Core.InstEnv (         DFunId, InstMatch, ClsInstLookupResult,-        PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,+        CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers,         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,-        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances,+        instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,         instanceDFunId, updateClsInstDFuns, updateClsInstDFun,         fuzzyClsInstCmp, orphNamesOfClsInst,          InstEnvs(..), VisibleOrphanModules, InstEnv,+        LookupInstanceErrReason (..),         mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,         filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,         anyInstEnv,@@ -40,8 +41,11 @@ import GHC.Core.RoughMap import GHC.Core.Class import GHC.Core.Unify+import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )+import GHC.Hs.Extension  import GHC.Unit.Module.Env+import GHC.Unit.Module.Warnings import GHC.Unit.Types import GHC.Types.Var import GHC.Types.Unique.DSet@@ -50,14 +54,14 @@ import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Id+import GHC.Generics (Generic) import Data.Data        ( Data ) import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe       ( isJust ) -import GHC.Utils.Outputable+import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import Data.Semigroup  {-@@ -105,6 +109,10 @@              , is_flag :: OverlapFlag   -- See detailed comments with                                         -- the decl of BasicTypes.OverlapFlag              , is_orphan :: IsOrphan+             , is_warn :: Maybe (WarningTxt GhcRn)+                -- Warning emitted when the instance is used+                -- See Note [Implementation of deprecated instances]+                -- in GHC.Tc.Solver.Dict     }   deriving Data @@ -119,10 +127,11 @@     cmp (RM_KnownTc _, RM_WildCard)   = GT     cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y -isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool+isOverlappable, isOverlapping, isIncoherent, isNonCanonical :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i)) isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))+isNonCanonical i = hasNonCanonicalFlag (overlapMode (is_flag i))  {- Note [ClsInst laziness and the rough-match fields]@@ -165,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] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -214,6 +223,16 @@ instance Outputable ClsInst where    ppr = pprInstance +pprDFunId :: DFunId -> SDoc+-- Prints the analogous information to `pprInstance`+-- but with just the DFunId+pprDFunId dfun+  = hang dfun_header+       2 (vcat [ text "--" <+> pprDefinedAt (getName dfun)+               , whenPprDebug (ppr dfun) ])+  where+    dfun_header = ppr_overlap_dfun_hdr empty dfun+ pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec@@ -225,11 +244,18 @@ pprInstanceHdr :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })-  = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)+  = ppr_overlap_dfun_hdr (ppr flag) dfun +ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc+ppr_overlap_dfun_hdr flag_sdoc dfun+  = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun)+ pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) +instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn)+instanceWarning = is_warn+ instanceHead :: ClsInst -> ([TyVar], Class, [Type]) -- Returns the head, using the fresh tyvars from the ClsInst instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys })@@ -255,19 +281,20 @@ -- Decomposes the DFunId instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) -mkLocalInstance :: DFunId -> OverlapFlag-                -> [TyVar] -> Class -> [Type]-                -> ClsInst+mkLocalClsInst :: DFunId -> OverlapFlag+               -> [TyVar] -> Class -> [Type]+               -> Maybe (WarningTxt GhcRn)+               -> ClsInst -- Used for local instances, where we can safely pull on the DFunId. -- Consider using newClsInst instead; this will also warn if -- the instance is an orphan.-mkLocalInstance dfun oflag tvs cls tys+mkLocalClsInst dfun oflag tvs cls tys warn   = ClsInst { is_flag = oflag, is_dfun = dfun             , is_tvs = tvs             , is_dfun_name = dfun_name             , is_cls = cls, is_cls_nm = cls_name             , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys-            , is_orphan = orph+            , is_orphan = orph, is_warn = warn             }   where     cls_name = className cls@@ -298,24 +325,26 @@      choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedInstance :: Name           -- ^ the name of the class-                   -> [RoughMatchTc] -- ^ the rough match signature of the instance-                   -> Name           -- ^ the 'Name' of the dictionary binding-                   -> DFunId         -- ^ the 'Id' of the dictionary.-                   -> OverlapFlag    -- ^ may this instance overlap?-                   -> IsOrphan       -- ^ is this instance an orphan?-                   -> ClsInst+mkImportedClsInst :: Name                     -- ^ the name of the class+                  -> [RoughMatchTc]           -- ^ the rough match signature of the instance+                  -> Name                     -- ^ the 'Name' of the dictionary binding+                  -> DFunId                   -- ^ the 'Id' of the dictionary.+                  -> OverlapFlag              -- ^ may this instance overlap?+                  -> IsOrphan                 -- ^ is this instance an orphan?+                  -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved+                  -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file -- The bound tyvars of the dfun are guaranteed fresh, because -- the dfun has been typechecked out of the same interface file-mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan+mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn   = ClsInst { is_flag = oflag, is_dfun = dfun             , is_tvs = tvs, is_tys = tys             , is_dfun_name = dfun_name             , is_cls_nm = cls_nm, is_cls = cls             , is_tcs = RM_KnownTc cls_nm : mb_tcs-            , is_orphan = orphan }+            , is_orphan = orphan+            , is_warn = warn }   where     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) @@ -570,57 +599,93 @@ manual section on "overlapping instances". At risk of duplication, here are the rules.  If the rules change, change this text and the user manual simultaneously.  The link may be this:-http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap+https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/instances.html#instance-overlap  The willingness to be overlapped or incoherent is a property of the-instance declaration itself, controlled as follows:+instance declaration itself, controlled by its `OverlapMode`, as follows - * An instance is "incoherent"-   if it has an INCOHERENT pragma, or-   if it appears in a module compiled with -XIncoherentInstances.+ * An instance is "incoherent" (OverlapMode = `Incoherent` or `NonCanonical`)+   if it has an `INCOHERENT` pragma, or+   if it appears in a module compiled with `-XIncoherentInstances`.+   In those cases:+      -fspecialise-incoherents on  => Incoherent+      -fspecialise-incoherents off => NonCanonical+   NB: it is on by default - * An instance is "overlappable"-   if it has an OVERLAPPABLE or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or+ * An instance is "overlappable" (OverlapMode = `Overlappable` or `Overlaps`)+   if it has an `OVERLAPPABLE` or `OVERLAPS` pragma, or+   if it appears in a module compiled with `-XOverlappingInstances`, or    if the instance is incoherent. - * An instance is "overlapping"-   if it has an OVERLAPPING or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or+ * An instance is "overlapping" (OverlapMode = `Overlapping` or `Overlaps`)+   if it has an `OVERLAPPING` or `OVERLAPS` pragma, or+   if it appears in a module compiled with `-XOverlappingInstances`, or    if the instance is incoherent.-     compiled with -XOverlappingInstances.  Now suppose that, in some client module, we are searching for an instance of the target constraint (C ty1 .. tyn). The search works like this. -*  Find all instances `I` that *match* the target constraint; that is, the-   target constraint is a substitution instance of `I`. These instance-   declarations are the *candidates*.+(IL0) If there are any local Givens that match (potentially unifying+      any metavariables, even untouchable ones) the target constraint,+      the search fails unless -XIncoherentInstances is enabled. See+      Note [Instance and Given overlap] in GHC.Tc.Solver.Dict.  This is+      implemented by the first guard in matchClassInst. -*  Eliminate any candidate `IX` for which both of the following hold:+(IL1) Find `all_matches` and `all_unifs` in `lookupInstEnv`:+      - all_matches: all instances `I` that *match* the target constraint (that+        is, the target constraint is a substitution instance of `I`). These+        instance declarations are the /candidates/.+      - all_unifs: all non-incoherent instances that *unify with but do not match*+        the target constraint. These are not candidates, but might match later if+        the target constraint is furhter instantiated. See+        `data PotentialUnifiers` for more precise details. -   -  There is another candidate `IY` that is strictly more specific; that-      is, `IY` is a substitution instance of `IX` but not vice versa.+(IL2) If there are no candidates, the search fails+      (lookupInstEnv returns no final_matches). The PotentialUnifiers are returned+      by lookupInstEnv for use in error message generation (mkDictErr). -   -  Either `IX` is *overlappable*, or `IY` is *overlapping*. (This-      "either/or" design, rather than a "both/and" design, allow a-      client to deliberately override an instance from a library,-      without requiring a change to the library.)+(IL3) Eliminate any candidate `IX` for which there is another candidate `IY` such+      that both of the following hold:+      - `IY` is strictly more specific than `IX`. That is, `IY` is a+        substitution instance of `IX` but not vice versa.+      - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This+        "either/or" design, rather than a "both/and" design, allow a+        client to deliberately override an instance from a library,+        without requiring a change to the library.) --  If exactly one non-incoherent candidate remains, select it. If all-   remaining candidates are incoherent, select an arbitrary one.-   Otherwise the search fails (i.e. when more than one surviving-   candidate is not incoherent).+      In addition, provided there is at least one candidate, eliminate any other+      candidates that are *incoherent*. (In particular, if all remaining candidates+      are incoherent, all except an arbitrarily chosen one will be eliminated.) --  If the selected candidate (from the previous step) is incoherent, the-   search succeeds, returning that candidate.+      This is implemented by `pruneOverlappedMatches`, producing final_matches in+      lookupInstEnv.  See Note [Instance overlap and guards] and+      Note [Incoherent instances]. --  If not, find all instances that *unify* with the target constraint,-   but do not *match* it. Such non-candidate instances might match when-   the target constraint is further instantiated. If all of them are-   incoherent, the search succeeds, returning the selected candidate; if-   not, the search fails.+(IL4) If exactly one *incoherent* candidate remains, the search succeeds.+      (By the previous step, there cannot be more than one incoherent candidate+      remaining.) +      In this case, lookupInstEnv returns the successful match, and it returns+      NoUnifiers as the final_unifs, which amounts to skipping the following+      steps.++(IL5) If more than one candidate remains, the search fails. (We have already+      eliminated the incoherent candidates, and we have no way to select+      between non-incoherent candidates.)++(IL6) Otherwise there is exactly one candidate remaining. The all_unifs+      computed at step (IL1) are returned from lookupInstEnv as final_unifs.++      If there are no potential unifiers, the search succeeds (in matchInstEnv).+      If there is at least one (non-incoherent) potential unifier, matchInstEnv+      returns a NotSure result and refrains from committing to the instance.++      Incoherent instances are not returned as part of the potential unifiers. This+      affects error messages: they will not be listed as "potentially matching instances"+      in an "Overlapping instances" or "Ambiguous type variable" error.+      See also Note [Recording coherence information in `PotentialUnifiers`].++ Notice that these rules are not influenced by flag settings in the client module, where the instances are *used*. These rules make it possible for a library author to design a library that relies on@@ -747,6 +812,185 @@ But still x and y might subsequently be unified so they *do* match.  Simple story: unify, don't match.++Note [Coherence and specialisation: overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's specialiser relies on the Coherence Assumption: that if+      d1 :: C tys+      d2 :: C tys+then the dictionary d1 can be used in place of d2 and vice versa; it is as if+(C tys) is a singleton type.  If d1 and d2 are interchangeable, we say that+they constitute /canonical evidence/ for (C tys).  We have a special data type,+`CanonoicalEvidence`, for recording whether evidence is canonical.++Let's use this example+  class C a where { op :: a -> Int }+  instance                     C [a]         where {...}   -- (I1)+  instance {-# OVERLAPPING #-} C [Int]       where {...}   -- (I2)++  instance C a =>              C (Maybe a)   where {...}   -- (I3)+  instance {-# INCOHERENT #-}  C (Maybe Int) where {...}   -- (I4)+  instance                     C Int         where {...}   -- (I5)++* When solving (C tys) from the top-level instances, we generally insist that+  there is a unique, most-specific match.  (Incoherent instances change the+  picture a bit: see Note [Rules for instance lookup].) Example:+     [W] C [Int]    -- Pick (I2)+     [W] C [Char]   -- Pick (I1); does not match (I2)++  Caveat: if different usage sites see different instances (which the+  programmer can contrive, with some effort), all bets are off; we really+  can't make any guarantees at all.++* But what about [W] C [b]? This might arise from+     risky :: b -> Int+     risky x = op [x]+  We can't pick (I2) because `b` is not Int. But if we pick (I1), and later+  the simplifier inlines a call (risky @Int) we'll get a dictionary of type+  (C [Int]) built by (I1), which might be utterly different to the dictionary+  of type (C [Int]) built by (I2).  That breaks the Coherence Assumption.++  So GHC declines to pick either, and rejects `risky`. You have to write a+  different signature+     notRisky :: C [b] => b -> Int+     notRisky x = op [x]+  so that the dictionary is resolved at the call site.++* The INCOHERENT pragma tells GHC to choose an instance anyway: see+  Note [Rules for instance lookup] step (IL6).  Suppose we have+     veryRisky :: C b => b -> Int+     veryRisky x = op (Just x)+   So we have [W] C (Maybe b).  Because (I4) is INCOHERENT, GHC is allowed to+   pick (I3).  Of course, this risks breaking the Coherence Assumption, as+   described above.++* What about the incoherence from step (IL4)? For example+     class D a b where { opD :: a -> b -> String }+     instance {-# INCOHERENT #-} D Int b where {...}  -- (I7)+     instance {-# INCOHERENT #-} D a Int where {...}  -- (I8)++     g (x::Int) = opD x x  -- [W] D Int Int++  Here both (I7) and (I8) match, GHC picks an arbitrary one.++So INCOHERENT may break the Coherence Assumption. But sometimes that+is fine, because the programmer promises that it doesn't matter which+one is chosen.  A good example is in the `optics` library:++  data IxEq i is js where { IxEq :: IxEq i is is }++  class AppendIndices xs ys ks | xs ys -> ks where+    appendIndices :: IxEq i (Curry xs (Curry ys i)) (Curry ks i)++  instance {-# INCOHERENT #-} xs ~ zs => AppendIndices xs '[] zs where+    appendIndices = IxEq++  instance ys ~ zs => AppendIndices '[] ys zs where+    appendIndices = IxEq++Here `xs` and `ys` are type-level lists, and for type inference purposes we want to+solve the `AppendIndices` constraint when /either/ of them are the empty list. The+dictionaries are the same in both cases (indeed the dictionary type is a singleton!),+so we really don't care which is used.  See #23287 for discussion.+++In short, sometimes we want to specialise on these incoherently-selected dictionaries,+and sometimes we don't.  It would be best to have a per-instance pragma, but for now+we have a global flag:++* If an instance has an `{-# INCOHERENT #-}` pragma, we the  `OverlapFlag` of the+  `ClsInst` to label it as either+    * `Incoherent`: meaning incoherent but still specialisable, or+    * `NonCanonical`: meaning incoherent and not specialisable.+  The module-wide `-fspecialise-incoherents` flag (on by default) determines+  which choice is made.++  See GHC.Tc.Utils.Instantiate.getOverlapFlag.++The rest of this note describes what happens for `NonCanonical`+instances, i.e. with `-fno-specialise-incoherents`.++To avoid this incoherence breaking the specialiser,++* We label as "non-canonical" any dictionary constructed by a (potentially)+  incoherent use of an ClsInst.++* We do not specialise a function if there is a non-canonical+  dictionary in the /transistive dependencies/ of its dictionary+  arguments.++To see the transitive closure issue, consider+  deeplyRisky :: C b => b -> Int+  deeplyRisky x = op (Just (Just x))++From (op (Just (Just x))) we get+  [W] d1 : C (Maybe (Maybe b))+which we solve (coherently!) via (I3), giving+  [W] d2 : C (Maybe b)+Now we can only solve this incoherently. So we end up with++  deeplyRisky @b (d1 :: C b)+    = op @(Maybe (Maybe b)) d1+    where+      d1 :: C (Maybe (Maybe b)) = $dfI3 d2   -- Coherent decision+      d2 :: C (Maybe b)         = $sfI3 d1   -- Incoherent decision++So `d2` is incoherent, and hence (transitively) so is `d1`.++Here are the moving parts:++* GHC.Core.InstEnv.lookupInstEnv tells if any incoherent unifiers were discarded+  in step (IL4) or (IL6) of the instance lookup: see+  Note [Recording coherence information in `PotentialUnifiers`] and+  Note [Canonicity for incoherent matches].++* 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.++* 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.+++Note [Canonicity for incoherent matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the selected instance is INCOHERENT at step (IL4) of+Note [Rules for instance lookup], we ignore all unifiers,+whether or not they are marked with INCOHERENT pragmas.+This is implemented by returning NoUnifiers in final_unifs.+NoUnifiers takes an argument indicating whether the match was canonical+as described in Note [Coherence and specialisation: overview] and+Note [Recording coherence information in `PotentialUnifiers`].++To determine whether an incoherent match was canonical, we look *only*+at the OverlapFlag of the instance being matched. For example:++  class C a+  instance {-# INCOHERENT #-} C a -- (1)+  instance C Int   -- (2)++  [W] C tau++Here we match instance (1) and discard instance (2). If (1) is Incoherent+(under -fspecialise-incoherents), it is important that we treat the match+as EvCanonical so that we do not block specialisation (see #25883).++What about the following situation:++  instance {-# INCOHERENT #-} C a    -- (1), in a module with -fspecialise-incoherents (Incoherent)+  instance {-# INCOHERENT #-} C Int  -- (2), in a module with -fno-specialise-incoherents (NonCanonical)++  [W] C tau++Again we match instance (1) and discard instance (2). It is not obvious+whether Incoherent or NonCanonical should "win" here, but it seems more+consistent with the previous example to look only at the flag on instance (1).++What about if the only instance that can match is marked as NonCanonical?+In this case are no unifiers at all, so all_unifs = NoUnifiers EvCanonical.+It is not obvious what -fno-specialise-incoherents should do here, but+currently it returns NoUnifiers EvCanonical.+ -}  type DFunInstType = Maybe Type@@ -826,51 +1070,131 @@ -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs                     -> Class -> [Type]-                    -> Either SDoc (ClsInst, [Type])+                    -> Either LookupInstanceErrReason (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys   = case lookupInstEnv False instEnv cls tys of       ([(inst, inst_tys)], _, _)              | noFlexiVar -> Right (inst, inst_tys')-             | otherwise  -> Left $ text "flexible type variable:" <+>-                                    (ppr $ mkTyConApp (classTyCon cls) tys)+             | otherwise  -> Left $ LookupInstErrFlexiVar              where                inst_tys'  = [ty | Just ty <- inst_tys]                noFlexiVar = all isJust inst_tys-      _other -> Left $ text "instance not found" <+>-                       (ppr $ mkTyConApp (classTyCon cls) tys)+      _other -> Left $ LookupInstErrNotFound -data PotentialUnifiers = NoUnifiers-                       | OneOrMoreUnifiers [ClsInst]-                       -- This list is lazy as we only look at all the unifiers when-                       -- printing an error message. It can be expensive to compute all-                       -- the unifiers because if you are matching something like C a[sk] then-                       -- all instances will unify.+-- | Why a particular typeclass application couldn't be looked up.+data LookupInstanceErrReason =+  -- | Tyvars aren't an exact match.+  LookupInstErrNotExact+  |+  -- | One of the tyvars is flexible.+  LookupInstErrFlexiVar+  |+  -- | No matching instance was found.+  LookupInstErrNotFound+  deriving (Generic) +-- | `CanonicalEvidence` says whether a piece of evidence has a singleton type;+-- For example, given (d1 :: C Int), will any other (d2 :: C Int) do equally well?+-- See Note [Coherence and specialisation: overview] above, and+-- Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds+data CanonicalEvidence+  = EvCanonical+  | EvNonCanonical++andCanEv :: CanonicalEvidence -> CanonicalEvidence -> CanonicalEvidence+-- Only canonical if both are+andCanEv EvCanonical EvCanonical = EvCanonical+andCanEv _           _           = EvNonCanonical++-- See Note [Recording coherence information in `PotentialUnifiers`]+data PotentialUnifiers+  = NoUnifiers CanonicalEvidence+       -- Either there were no unifiers, or all were incoherent+       --+       -- NoUnifiers EvNonCanonical:+       --    We discarded (via INCOHERENT) some instances that unify,+       --    and that are marked NonCanonical; so the matching instance+       --    should be traeated as EvNonCanonical+       -- NoUnifiers EvCanonical:+       --    We discarded no NonCanonical incoherent unifying instances,+       --    so the matching instance can be treated as EvCanonical++  | OneOrMoreUnifiers (NonEmpty ClsInst)+       -- There are some /coherent/ unifiers; here they are+       --+       -- This list is lazy as we only look at all the unifiers when+       -- printing an error message. It can be expensive to compute all+       -- the unifiers because if you are matching something like C a[sk] then+       -- all instances will unify.++{- Note [Recording coherence information in `PotentialUnifiers`]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we find a matching instance, there might be other instances that+could potentially unify with the goal. For `INCOHERENT` instances, we+don't care (see step (IL6) in Note [Rules for instance lookup]).+But if we have potentially unifying coherent instance, we+report these `OneOrMoreUnifiers` so that `matchInstEnv` can go down+the `NotSure` route.++If this hurdle is passed, i.e. we have a unique solution up to+`INCOHERENT` instances, the specialiser needs to know if that unique+solution is canonical or not (see Note [Coherence and specialisation:+overview] for why we care at all). So when the set of potential+unifiers is empty, we record in `NoUnifiers` if the one solution is+`Canonical`.++For example, suppose we have:++  class C x y+  instance C a Bool                   -- (1)+  instance {-# INCOHERENT #-} C Int a -- (2)++  [W] C x Bool++Here instance (1) matches the Wanted, and since instance (2) is INCOHERENT+we want to succeed with the match rather than getting stick at step (IL6).+But if -fno-specialise-incoherents was enabled for (2), the specialiser is+not permitted to specialise this dictionary later, so lookupInstEnv reports+the PotentialUnifiers as NoUnifiers EvNonCanonical.++-}++instance Outputable CanonicalEvidence where+  ppr EvCanonical    = text "canonical"+  ppr EvNonCanonical = text "non-canonical"+ instance Outputable PotentialUnifiers where-  ppr NoUnifiers = text "NoUnifiers"-  ppr xs = ppr (getPotentialUnifiers xs)+  ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c+  ppr xs = ppr (getCoherentUnifiers xs)  instance Semigroup PotentialUnifiers where-  NoUnifiers <> u = u-  u <> NoUnifiers = u-  u1 <> u2 = OneOrMoreUnifiers (getPotentialUnifiers u1 ++ getPotentialUnifiers u2)--instance Monoid PotentialUnifiers where-  mempty = NoUnifiers+  NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 `andCanEv` c2)+  NoUnifiers _ <> u = u+  OneOrMoreUnifiers (unifier :| unifiers) <> u+    = OneOrMoreUnifiers (unifier :| (unifiers <> getCoherentUnifiers u)) -getPotentialUnifiers :: PotentialUnifiers -> [ClsInst]-getPotentialUnifiers NoUnifiers = []-getPotentialUnifiers (OneOrMoreUnifiers cls) = cls+getCoherentUnifiers :: PotentialUnifiers -> [ClsInst]+getCoherentUnifiers NoUnifiers{} = []+getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls +-- | Are there no *coherent* unifiers? nullUnifiers :: PotentialUnifiers -> Bool-nullUnifiers NoUnifiers = True+nullUnifiers NoUnifiers{} = True nullUnifiers _ = False -lookupInstEnv' :: InstEnv          -- InstEnv to look in-               -> VisibleOrphanModules   -- But filter against this-               -> Class -> [Type]  -- What we are looking for-               -> ([InstMatch],    -- Successful matches-                   PotentialUnifiers)      -- These don't match but do unify+-- | Are there any unifiers, ignoring those marked Incoherent (but including any+-- marked NonCanonical)?+someUnifiers :: PotentialUnifiers -> Bool+someUnifiers (NoUnifiers EvCanonical) = False+someUnifiers _ = True+++instEnvMatchesAndUnifiers+  :: InstEnv          -- InstEnv to look in+  -> VisibleOrphanModules   -- But filter against this+  -> Class -> [Type]  -- What we are looking for+  -> ([InstMatch],    -- Successful matches+      PotentialUnifiers)      -- These don't match but do unify                                    -- (no incoherent ones in here) -- The second component of the result pair happens when we look up --      Foo [a]@@ -882,8 +1206,8 @@ -- but Foo [Int] is a unifier.  This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' (InstEnv rm) vis_mods cls tys-  = (foldr check_match [] rough_matches, check_unifier rough_unifiers)+instEnvMatchesAndUnifiers (InstEnv rm) vis_mods cls tys+  = (foldr check_match [] rough_matches, check_unifiers rough_unifiers)   where     (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm     rough_tcs  = RML_KnownTc (className cls) : roughMatchTcsLookup tys@@ -896,22 +1220,23 @@        | Just subst <- tcMatchTys tpl_tys tys       = ((item, map (lookupTyVar subst) tpl_tvs) : acc)+       | otherwise       = acc +    check_unifiers :: [ClsInst] -> PotentialUnifiers+    check_unifiers [] = NoUnifiers EvCanonical+    check_unifiers (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items) -    check_unifier :: [ClsInst] -> PotentialUnifiers-    check_unifier [] = NoUnifiers-    check_unifier (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items)       | not (instIsVisible vis_mods item)-      = check_unifier items  -- See Note [Instance lookup and orphan instances]-      | Just {} <- tcMatchTys tpl_tys tys = check_unifier items-        -- Does not match, so next check whether the things unify-        -- See Note [Overlapping instances]-        -- Ignore ones that are incoherent: Note [Incoherent instances]-      | isIncoherent item-      = check_unifier items+      = check_unifiers items  -- See Note [Instance lookup and orphan instances] +      -- If it matches, check_match has gotten it, so skip over it here+      | Just {} <- tcMatchTys tpl_tys tys+      = check_unifiers items++      -- Does not match, so next check whether the things unify+      -- See Note [Overlapping instances]       | otherwise       = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set)                   ((ppr cls <+> ppr tys) $$@@ -919,20 +1244,38 @@                 -- 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.-            SurelyApart              -> check_unifier items+          -- 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_unifier items-            _                        ->-              OneOrMoreUnifiers (item: getPotentialUnifiers (check_unifier items))+            MaybeApart MARInfinite _ -> check_unifiers items+            _                        -> add_unifier item (check_unifiers items)        where         tpl_tv_set = mkVarSet tpl_tvs         tys_tv_set = tyCoVarsOfTypes tys +    add_unifier :: ClsInst -> PotentialUnifiers -> PotentialUnifiers+        -- Record that we encountered non-canonical instances:+        -- Note [Coherence and specialisation: overview]+    add_unifier item other_unifiers+      | not (isIncoherent item)+      = OneOrMoreUnifiers (item :| getCoherentUnifiers other_unifiers)++      -- So `item` is incoherent; see Note [Incoherent instances]+      | otherwise+      = case other_unifiers of+          OneOrMoreUnifiers{}                -> other_unifiers+          NoUnifiers{} | isNonCanonical item -> NoUnifiers EvNonCanonical+                       | otherwise           -> other_unifiers++ --------------- -- This is the common way to call this function. lookupInstEnv :: Bool              -- Check Safe Haskell overlap restrictions@@ -950,10 +1293,13 @@               tys   = (final_matches, final_unifs, unsafe_overlapped)   where-    (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys-    (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys-    all_matches = home_matches ++ pkg_matches-    all_unifs   = home_unifs   `mappend` pkg_unifs+    -- (IL1): Find all instances that match the target constraint+    (home_matches, home_unifs) = instEnvMatchesAndUnifiers home_ie vis_mods cls tys+    (pkg_matches,  pkg_unifs)  = instEnvMatchesAndUnifiers pkg_ie  vis_mods cls tys+    all_matches = home_matches <> pkg_matches+    all_unifs   = home_unifs <> pkg_unifs++    -- (IL3): Eliminate candidates that are overlapped or incoherent     final_matches = pruneOverlappedMatches all_matches         -- Even if the unifs is non-empty (an error situation)         -- we still prune the matches, so that the error message isn't@@ -966,9 +1312,19 @@            _       -> []      -- If the selected match is incoherent, discard all unifiers+    -- See (IL4) of Note [Rules for instance lookup]     final_unifs = case final_matches of-                    (m:_) | isIncoherent (fst m) -> NoUnifiers-                    _                            -> all_unifs+                    (m:ms) | isIncoherent (fst m)+                           -- Incoherent match, so discard all unifiers, but+                           -- keep track of dropping coherent or non-canonical ones+                           -- if the match is non-canonical.+                           -- See Note [Canonicity for incoherent matches]+                           -> assertPpr (null ms) (ppr final_matches) $+                              NoUnifiers $+                                 if isNonCanonical (fst m) && someUnifiers all_unifs+                                    then EvNonCanonical+                                    else EvCanonical+                    _      -> all_unifs      -- Note [Safe Haskell isSafeOverlap]     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1145,7 +1501,10 @@ pruneOverlappedMatches :: [InstMatch] -> [InstMatch] -- ^ Remove from the argument list any InstMatches for which another -- element of the list is more specific, and overlaps it, using the--- rules of Nove [Rules for instance lookup]+-- rules of Note [Rules for instance lookup], esp (IL3)+--+-- Incoherent instances are discarded, unless all are incoherent,+-- in which case exactly one is kept. pruneOverlappedMatches all_matches =   instMatches $ foldr insert_overlapping noMatches all_matches @@ -1279,8 +1638,8 @@ Example:         class C a b c where foo :: (a,b,c)         instance C [a] b Int-        instance [incoherent] [Int] b c-        instance [incoherent] C a Int c+        instance {-# INCOHERENT #-} C [Int] b c+        instance {-# INCOHERENT #-} C a Int c Thanks to the incoherent flags,         [Wanted]  C [a] b Int works: Only instance one matches, the others just unify, but are marked@@ -1298,7 +1657,12 @@ The implementation is in insert_overlapping, where we remove matching incoherent instances as long as there are others. -+If the choice of instance *does* matter, all bets are still not off:+users can consult the detailed specification of the instance selection+algorithm in the GHC Users' Manual. However, this means we can end up+with different instances at the same types at different parts of the+program, and this difference has to be preserved. Note [Coherence and+specialisation: overview] details how we achieve that.  ************************************************************************ *                                                                      *@@ -1307,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]@@ -1330,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
@@ -31,3531 +31,3918 @@  import GHC.Prelude -import GHC.Driver.Session--import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )-import GHC.Unit.Module.ModGuts-import GHC.Platform--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils-import GHC.Core.Stats ( coreBindsStats )-import GHC.Core.DataCon-import GHC.Core.Ppr-import GHC.Core.Coercion-import GHC.Core.Type as Type-import GHC.Core.Multiplicity-import GHC.Core.UsageEnv-import GHC.Core.TyCo.Rep   -- checks validity of types/coercions-import GHC.Core.TyCo.Compare( eqType )-import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.FVs-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCon as TyCon-import GHC.Core.Coercion.Axiom-import GHC.Core.FamInstEnv( compatibleBranches )-import GHC.Core.Unify-import GHC.Core.Coercion.Opt ( checkAxInstCo )-import GHC.Core.Opt.Arity    ( typeArity, exprIsDeadEnd )--import GHC.Core.Opt.Monad--import GHC.Types.Literal-import GHC.Types.Var as Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.SrcLoc-import GHC.Types.Tickish-import GHC.Types.RepType-import GHC.Types.Basic-import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )--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 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%.---************************************************************************-*                                                                      *-                 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.MCDump noSrcSpan-           $ 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-  -- If the Core linter encounters an error, output to stderr instead of-  -- stdout (#13342)-  = logMsg logger Err.MCInfo noSrcSpan-      $ 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--    -- dups_ext 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 (removeDups ord_ext (map Var.varName binders))-    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1-                  , Just m2 <- nameModule_maybe n2-                  = compare (m1, nameOccName n1) (m2, nameOccName n2)-                  | otherwise = LT--{--************************************************************************-*                                                                      *-\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 :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)-lintLetBody bndrs body-  = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (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 isJoinId_maybe binder of-            Nothing    -> return ()-            Just 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 ->-             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-    | Just arity <- isJoinId_maybe 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)----************************************************************************-*                                                                      *-\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-      checkCanEtaExpand (Var var) [] var_ty-      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 (BodyOfLetRec [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 [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 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-       ; checkCanEtaExpand fun args app_ty-       ; 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)-  = 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--        ; 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-  | Just arity <- isJoinId_maybe 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-  | Just join_arity_occ <- isJoinId_maybe var-  = do { mb_join_arity_bndr <- lookupJoinId var-       ; case mb_join_arity_bndr of {-           Nothing -> -- Binder is not a join point-                      do { join_set <- getValidJoins-                         ; addErrL (text "join set " <+> ppr join_set $$-                                    invalidJoinOcc var) } ;--           Just 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 ()---- | This function checks that we are able to perform eta expansion for--- functions with no binding, in order to satisfy invariant I3--- from Note [Representation polymorphism invariants] in GHC.Core.-checkCanEtaExpand :: 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 ()-checkCanEtaExpand (Var fun_id) args app_ty-  = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags-       ; when (do_rep_poly_checks && hasNoBinding fun_id) $-           checkL (null bad_arg_tys) err_msg }-    where-      arity :: Arity-      arity = idArity fun_id--      nb_val_args :: Int-      nb_val_args = count isValArg args--      -- Check the remaining argument types, past the-      -- given arguments and up to the arity of the 'Id'.-      -- Returns the types that couldn't be determined to have-      -- a fixed RuntimeRep.-      check_args :: [Type] -> [Type]-      check_args = go (nb_val_args + 1)-        where-          go :: Int    -- index of the argument (starting from 1)-             -> [Type] -- arguments-             -> [Type] -- value argument types that could not be-                       -- determined to have a fixed runtime representation-          go i _-            | i > arity-            = []-          go _ []-            -- The Arity of an Id should never exceed the number of value arguments-            -- that can be read off from the Id's type.-            -- See Note [Arity and function types] in GHC.Types.Id.Info.-            = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type"-                $ vcat-                  [ text "fun_id =" <+> ppr fun_id-                  , text "arity =" <+> ppr arity-                  , text "app_ty =" <+> ppr app_ty-                  , text "args = " <+> ppr args-                  , text "nb_val_args =" <+> ppr nb_val_args ]-          go i (ty : bndrs)-            | typeHasFixedRuntimeRep ty-            = go (i+1) bndrs-            | otherwise-            = ty : go (i+1) bndrs--      bad_arg_tys :: [Type]-      bad_arg_tys = check_args . map (scaledThing . fst) $ getRuntimeArgTys app_ty-        -- We use 'getRuntimeArgTys' to find all the argument types,-        -- including those hidden under newtypes. For example,-        -- if `FunNT a b` is a newtype around `a -> b`, then-        -- when checking-        ---        -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c-        ---        -- we should check that the instantiations of BOTH `a` AND `b`-        -- have a fixed runtime representation.--      err_msg :: SDoc-      err_msg-        = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id)-               , text "The following type" <> plural bad_arg_tys-                 <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:"-               , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ]--      ppr_ty_ki :: Type -> SDoc-      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)-checkCanEtaExpand _ _ _-  = return ()---- 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 ensureSubUsage lhs mult (err_msg mult)-                    return $ deleteUE body_ue lam_var-    Nothing    -> return body_ue -- A type variable-  where-    lhs = lookupUE body_ue lam_var-    err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var-                $$ ppr lhs <+> text "⊈" <+> ppr mult--{- 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)-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) }--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) <- splitForAllTyCoVar_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 -> 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 _ _ _ alt_ty (Alt DEFAULT args rhs) =-  do { lintL (null args) (mkDefaultArgsMsg args)-     ; lintAltExpr rhs alt_ty }--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)-       ; lintAltExpr rhs alt_ty }-  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-    {   -- First instantiate the universally quantified-        -- type variables of the data constructor-        -- We've already check-      lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)-    ; 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)----------------------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 | tv `isInScope` subst-                   -> return (TyVarTy tv)-                   | otherwise-                   -> failWithL $-                      hang (text "The type variable" <+> pprBndr LetBind tv)-                         2 (text "is out of scope")-     }--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]-         -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo]--       ; 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 isJoinId_maybe fun of-                     Just 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-              | cv `isInScope` subst-                   -> return (CoVarCo cv)-              | otherwise-                   ->-                      -- lintCoBndr always extends the substitution-                      failWithL $-                      hang (text "The coercion variable" <+> pprBndr LetBind cv)-                         2 (text "is out of scope")-     }---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 tcv kind_co body_co)-  | 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 = coercionKind body_co'-       ; lintForAllBody tcv' lty-       ; lintForAllBody tcv' rty--       ; when (isCoVar tcv) $-         lintL (almostDevoidCoVarOfCo tcv body_co) $-         text "Covar can only appear in Refl and GRefl: " <+> ppr co-         -- See "last wrinkle" in GHC.Core.Coercion-         -- Note [Unused coercion variable in ForAllCo]-         -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]--       ; return (ForAllCo tcv' kind_co' 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 prov r ty1 ty2)-  = do { ty1' <- lintType ty1-       ; ty2' <- lintType ty2-       ; let k1 = typeKind ty1'-             k2 = typeKind ty2'-       ; prov' <- lint_prov k1 k2 prov--       ; when (r /= Phantom && isTYPEorCONSTRAINT k1-                            && isTYPEorCONSTRAINT k2)-              (checkTypes ty1 ty2)--       ; return (UnivCo prov' r ty1' ty2') }-   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-       | allow_ill_kinded_univ_co prov-       = return ()  -- Skip kind checks-       | otherwise-       = 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--     -- CorePrep deliberately makes ill-kinded casts-     --  e.g (case error @Int "blah" of {}) :: Int#-     --     ==> (error @Int "blah") |> Unsafe Int Int#-     -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-     allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind-     allow_ill_kinded_univ_co _                        = False--     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 ()-            }--     lint_prov k1 k2 (PhantomProv kco)-       = do { kco' <- lintStarCoercion kco-            ; lintRole co Phantom r-            ; check_kinds kco' k1 k2-            ; return (PhantomProv kco') }--     lint_prov k1 k2 (ProofIrrelProv kco)-       = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co)-            ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co)-            ; kco' <- lintStarCoercion kco-            ; check_kinds kco k1 k2-            ; return (ProofIrrelProv kco') }--     lint_prov _ _ prov@(PluginProv _)   = return prov-     lint_prov _ _ prov@(CorePrepProv _) = return prov--     check_kinds kco k1 k2-       = do { let Pair k1' k2' = coercionKind kco-            ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  co)-            ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }---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 co@(AxiomInstCo con ind cos)-  = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))-                (bad_ax (text "index out of range"))-       ; let CoAxBranch { cab_tvs   = ktvs-                        , cab_cvs   = cvs-                        , cab_roles = roles } = coAxiomNthBranch con ind-       ; unless (cos `equalLength` (ktvs ++ cvs)) $-           bad_ax (text "lengths")-       ; cos' <- mapM lintCoercion cos-       ; subst <- getSubst-       ; let empty_subst = zapSubst subst-       ; _ <- foldlM check_ki (empty_subst, empty_subst)-                              (zip3 (ktvs ++ cvs) roles cos')-       ; let fam_tc = coAxiomTyCon con-       ; case checkAxInstCo co of-           Just bad_branch -> bad_ax $ text "inconsistent with" <+>-                                       pprCoAxBranch fam_tc bad_branch-           Nothing -> return ()-       ; return (AxiomInstCo con ind cos') }-  where-    bad_ax what = addErrL (hang (text  "Bad axiom application" <+> parens what)-                        2 (ppr co))--    check_ki (subst_l, subst_r) (ktv, role, arg')-      = do { let Pair s' t' = coercionKind arg'-                 sk' = typeKind s'-                 tk' = typeKind t'-           ; lintRole arg' role (coercionRole arg')-           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)-                 ktv_kind_r = substTy subst_r (tyVarKind ktv)-           ; unless (sk' `eqType` ktv_kind_l)-                    (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] ))-           ; unless (tk' `eqType` ktv_kind_r)-                    (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] ))-           ; return (extendTCvSubst subst_l ktv s',-                     extendTCvSubst subst_r ktv t') }--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 this@(AxiomRuleCo ax cos)-  = do { cos' <- mapM lintCoercion cos-       ; lint_roles 0 (coaxrAsmpRoles ax) cos'-       ; case coaxrProves ax (map coercionKind cos') of-           Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]-           Just _  -> return (AxiomRuleCo ax cos') }-  where-  err :: forall a. String -> [SDoc] -> LintM a-  err m xs  = failWithL $-              hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName 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 (HoleCo h)-  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h-       ; lintCoercion (CoVarCo (coHoleCoVar h)) }--{--************************************************************************-*                                                                      *-              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     = 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")-           ; let ax_lhs = mkInfForAllTys tvs $-                          mkTyConApp tc lhs_tys-                 nt_tvs = takeList tvs (tyConTyVars tc)-                    -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon-                 nt_lhs = mkInfForAllTys nt_tvs $-                          mkTyConApp tc (mkTyVarTys nt_tvs)-                 -- See Note [Newtype eta] in GHC.Core.TyCon-           ; lintL (ax_lhs `eqType` nt_lhs)-                   (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` 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]-~~~~~~~~~~~~~~~~~~~~~~~~-Core understands linear types: linearity is checked with the flag-`-dlinear-core-lint`. Why not make `-dcore-lint` check linearity?  Because-optimisation passes are not (yet) guaranteed to maintain linearity.  They should-do so semantically (GHC is careful not to duplicate computation) but it is much-harder to ensure that the statically-checkable constraints of Linear Core are-maintained. The current Linear Core is described in the wiki at:-https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.--Why don't the optimisation passes maintain the static types of Linear Core?-Because doing so would cripple some important optimisations.  Here is an-example:--  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 wants to change this to--  case %1 x of z {-    I# n' -> let x = z in (x, n')-  }--Now, this is not something that a linear type checker usually considers-well-typed. It is not something that `-dlinear-core-lint` considers to be-well-typed either. But it's only because `-dlinear-core-lint` is not good-enough. However, making `-dlinear-core-lint` recognise this expression as valid-is not obvious. There are many such interactions between a linear type system-and GHC optimisations documented in the linear-type implementation wiki page-[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes].--PRINCIPLE: The type system bends to the optimisation, not the other way around.--In the original linear-types implementation, we had tried to make every-optimisation pass produce code that passes `-dlinear-core-lint`. It had proved-very difficult. And we kept finding corner case after corner case.  Plus, we-used to restrict transformations when `-dlinear-core-lint` couldn't typecheck-the result. There are still occurrences of such restrictions in the code. But-our current stance is that such restrictions can be removed.--For instance, 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. This issue is discussed-in  ticket #18694.--Plus in many cases, in order to make a transformation compatible with linear-linting, we ended up restricting to avoid producing patterns that were not-recognised as linear by the linter. This violates the above principle.--In the future, we may be able to lint the linearity of the output of-Core-to-Core passes (#19165). But right now, we can't. Therefore, in virtue of-the principle above, after the desguarer, the optimiser should take no special-pains to preserve linearity (in the type system sense).--In general the optimiser tries hard not to lose sharing, so it probably doesn't-actually make linear things non-linear. We postulate that any program-transformation which breaks linearity would negatively impact performance, and-therefore wouldn't be suitable for an optimiser. An alternative to linting-linearity after each pass is to prove this statement.--There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123--Note [checkCanEtaExpand]-~~~~~~~~~~~~~~~~~~~~~~~~-The checkCanEtaExpand function is responsible for enforcing invariant I3-from Note [Representation polymorphism invariants] in GHC.Core: in any-partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to-eta expand `f` to match the declared arity of `f`.--Wrinkle 1: eta-expansion and newtypes--  Most of the time, when we have a partial application `f e_1 .. e_n`-  in which `f` is `hasNoBinding`, we eta-expand it up to its arity-  as follows:--    \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity--  However, we might need to insert casts if some of the arguments-  that `f` takes are under a newtype.-  For example, suppose `f` `hasNoBinding`, has arity 1 and type--    f :: forall r (a :: TYPE r). Identity (a -> a)--  then we eta-expand the nullary application `f` to--    ( \ x -> f x ) |> co--  where--    co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) )--  In this case we would have to perform a representation-polymorphism check on the instantiation-  of `a`.--Wrinkle 2: 'hasNoBinding' and laziness--  It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing-  the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in-    Note [Lazily checking Unfoldings] in GHC.IfaceToCore.--}--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-  | BodyOfLetRec [Id]   -- One of the binders-  | 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 }) errs ->-    unLintM m (env { le_ids   = extendVarEnv id_set id (id, linted_ty)-                   , le_joins = add_joins join_set }) errs-  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-                   ; 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    = hang (text "Occurrence is GlobalId, but binding is LocalId")-                            2 (pprBndr LetBind id_occ)-    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 (Maybe JoinArity)--- 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 (isJoinId_maybe id')-            Nothing  -> return Nothing }--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    -> unitUE id OneTy-         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-ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg--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 (BodyOfLetRec [])-  = (noSrcLoc, text "In body of a letrec with no binders")--dumpLoc (BodyOfLetRec bs@(b:_))-  = ( getSrcLoc b, text "In the body of 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 "Exp type:")-                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),-              hang (text "Arg type:")-                 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--mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc-mkBadUnivCoMsg lr co-  = text "Kind mismatch on the" <+> pprLeftOrRight lr <+>-    text "side of a UnivCo:" <+> ppr co--mkBadProofIrrelMsg :: Type -> Coercion -> SDoc-mkBadProofIrrelMsg ty co-  = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")-       2 (vcat [ text "type:" <+> ppr ty-               , text "co:" <+> ppr co ])--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) ]--mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc-mkBadJoinPointRuleMsg bndr join_arity rule-  = vcat [ text "Join point has rule with wrong number of arguments"-         , text "Var:" <+> ppr bndr-         , text "Join arity:" <+> ppr join_arity-         , text "Rule:" <+> ppr rule ]--pprLeftOrRight :: LeftOrRight -> SDoc-pprLeftOrRight CLeft  = text "left"-pprLeftOrRight CRight = text "right"+import GHC.Driver.DynFlags++import GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars+  , isFloatingPrimTy, isTyFamFree )+import GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..) )+import GHC.Unit.Module.ModGuts+import GHC.Platform++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Stats ( coreBindsStats )+import GHC.Core.DataCon+import GHC.Core.Ppr+import GHC.Core.Coercion+import GHC.Core.Type as Type+import GHC.Core.Predicate( isCoVarType )+import GHC.Core.Multiplicity+import GHC.Core.UsageEnv+import GHC.Core.TyCo.Rep   -- checks validity of types/coercions+import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis )+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCon as TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.FamInstEnv( compatibleBranches )+import GHC.Core.Unify+import GHC.Core.Opt.Arity    ( typeArity, exprIsDeadEnd )++import GHC.Core.Opt.Monad++import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Types.Unique.FM ( isNullUFM, sizeUFM )+import GHC.Types.RepType+import GHC.Types.Basic+import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )++import GHC.Builtin.Names+import GHC.Builtin.Types.Prim++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+  = vcat [ text "Join point has rule with wrong number of arguments"+         , text "Var:" <+> ppr bndr+         , text "Join arity:" <+> ppr join_arity+         , text "Rule:" <+> ppr rule ]  dupVars :: [NonEmpty Var] -> SDoc dupVars vars
compiler/GHC/Core/Make.hs view
@@ -1,12 +1,11 @@-{-# 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,-        mkWildValBinder, mkWildEvBinder,+        mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps,+        mkCoreLams, mkCoreTyLams,+        mkWildCase, mkIfThenElse,+        mkWildValBinder,         mkSingleAltCase,         sortQuantVars, castBottomExpr, @@ -54,7 +53,7 @@ import GHC.Platform  import GHC.Types.Id-import GHC.Types.Var  ( EvVar, setTyVarUnique, visArgConstraintLike )+import GHC.Types.Var  ( setTyVarUnique, visArgConstraintLike ) import GHC.Types.TyThing import GHC.Types.Id.Info import GHC.Types.Cpr@@ -65,11 +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.TyCo.Compare( eqType )-import GHC.Core.Coercion ( isCoVar )-import GHC.Core.DataCon  ( DataCon, dataConWorkId )+import GHC.Core.Predicate    ( scopedSort, isEqPred )+import GHC.Core.TyCo.Compare ( eqType )+import GHC.Core.Coercion     ( isCoVar, mkRepReflCo, mkForAllVisCos )+import GHC.Core.DataCon      ( DataCon, dataConWorkId, dataConWrapId ) import GHC.Core.Multiplicity  import GHC.Builtin.Types@@ -79,12 +79,13 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  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@@ -173,9 +189,6 @@ *                                                                      * ********************************************************************* -} -mkWildEvBinder :: PredType -> EvVar-mkWildEvBinder pred = mkWildValBinder ManyTy pred- -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site.  Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very@@ -227,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)  {- ************************************************************************@@ -472,12 +485,12 @@  -- | Build the type of a big tuple that holds the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples]-mkBigCoreVarTupTy :: [Id] -> Type+mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)  -- | Build the type of a big tuple that holds the specified type of thing -- One-tuples are flattened; see Note [Flattening one-tuples]-mkBigCoreTupTy :: [Type] -> Type+mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $                      map boxTy tys @@ -502,7 +515,7 @@   where     e_ty = exprType e -boxTy :: Type -> Type+boxTy :: HasDebugCallStack => Type -> Type -- ^ `boxTy ty` is the boxed version of `ty`. That is, -- if `e :: ty`, then `wrapBox e :: boxTy ty`. -- Note that if `ty :: Type`, `boxTy ty` just returns `ty`.@@ -559,7 +572,8 @@   where     n_xs     = length xs     split [] = []-    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)+    split xs = let (as, bs) = splitAt mAX_TUPLE_SIZE xs+               in as : split bs   {-@@ -611,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@@ -651,12 +670,12 @@ -- To avoid shadowing, we use uniques to invent new variables. -- -- If necessary we pattern match on a "big" tuple.-mkBigTupleCase :: UniqSupply       -- ^ For inventing names of intermediate variables-               -> [Id]             -- ^ The tuple identifiers to pattern match on;+mkBigTupleCase :: MonadUnique m    --   For inventing names of intermediate variables+               => [Id]             -- ^ The tuple identifiers to pattern match on;                                    --   Bring these into scope in the body                -> CoreExpr         -- ^ Body of the case                -> CoreExpr         -- ^ Scrutinee-               -> CoreExpr+               -> m CoreExpr -- ToDo: eliminate cases where none of the variables are needed. -- --         mkBigTupleCase uniqs [a,b,c,d] body v e@@ -664,11 +683,11 @@ --             case p of p { (a,b) -> --             case q of q { (c,d) -> --             body }}}-mkBigTupleCase us vars body scrut-  = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body+mkBigTupleCase vars body scrut+  = do us <- getUniqueSupplyM+       let (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars+       return $ mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body   where-    (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars-     scrut_ty = exprType scrut      unwrap var (us,vars,body)@@ -910,7 +929,7 @@                                   nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID  err_nm :: String -> Unique -> Id -> Name-err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id+err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id  rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id@@ -1082,8 +1101,9 @@ mkImpossibleExpr res_ty str   = mkRuntimeErrorApp err_id res_ty str   where    -- See Note [Type vs Constraint for error ids]-    err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID-           | otherwise                              = iMPOSSIBLE_ERROR_ID+    err_id = case typeTypeOrConstraint res_ty of+               TypeLike       -> iMPOSSIBLE_ERROR_ID+               ConstraintLike -> iMPOSSIBLE_CONSTRAINT_ERROR_ID  {- Note [Type vs Constraint for error ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1207,8 +1227,9 @@ mkAbsentErrorApp res_ty err_msg   = mkApps (Var err_id) [ Type res_ty, err_string ]   where-    err_id | isConstraintLikeKind (typeKind res_ty) = aBSENT_CONSTRAINT_ERROR_ID-           | otherwise                              = aBSENT_ERROR_ID+    err_id = case typeTypeOrConstraint res_ty of+               TypeLike       -> aBSENT_ERROR_ID+               ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID     err_string = Lit (mkLitString err_msg)  absentErrorName, absentConstraintErrorName :: Name@@ -1251,7 +1272,7 @@  mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id -- Error function---   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a+--   with type:  forall (r::RuntimeRep) (a::TYPE r). Addr# -> a --   with arity: 1 -- which diverges after being given one argument -- The Addr# is expected to be the address of@@ -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
@@ -40,6 +40,7 @@ import qualified Data.Map    as Map import GHC.Types.Name.Env import Control.Monad( (>=>) )+import GHC.Types.Literal (Literal)  {- This module implements TrieMaps over Core related data structures@@ -121,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,@@ -128,6 +130,8 @@ -- inside another 'TrieMap', this is the type you want. type CoreMapG = GenMap CoreMapX +type LiteralMap  a = Map.Map Literal a+ -- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without -- the 'GenMap' optimization. data CoreMapX a@@ -267,6 +271,7 @@    alterTM  = xtE    foldTM   = fdE    filterTM = ftE+   mapMaybeTM = mpE  -------------------------- ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a@@ -283,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@@ -405,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@@ -442,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
@@ -38,6 +38,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Rep+import GHC.Core.TyCon( isForgetfulSynTyCon ) import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Data.TrieMap @@ -95,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)@@ -111,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@@ -188,6 +191,7 @@    alterTM  = xtT    foldTM   = fdT    filterTM = filterT+   mapMaybeTM = mpT  instance Eq (DeBruijn Type) where   (==) = eqDeBruijnType@@ -228,10 +232,11 @@     andEq TEQX e = hasCast e     andEq TEQ  e = e -    -- See Note [Comparing nullary type synonyms] in GHC.Core.Type-    go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 []))-      | tc1 == tc2-      = TEQ+    -- See Note [Comparing type synonyms] in GHC.Core.TyCo.Compare+    go (D env1 (TyConApp tc1 tys1)) (D env2 (TyConApp tc2 tys2))+      | tc1 == tc2, not (isForgetfulSynTyCon tc1)+      = gos env1 env2 tys1 tys2+     go env_t@(D env t) env_t'@(D env' t')       | Just new_t  <- coreView t  = go (D env new_t) env_t'       | Just new_t' <- coreView t' = go env_t (D env' new_t')@@ -378,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 }@@ -397,7 +403,7 @@     CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }  foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b-foldTyLit l m = flip (foldUFM l) (tlm_string m)+foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m)               . flip (Map.foldr l) (tlm_number m)               . flip (Map.foldr l) (tlm_char m) @@ -405,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.@@ -433,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@@ -477,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)  {- ************************************************************************@@ -556,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.@@ -592,6 +607,7 @@    alterTM  = xtVar emptyCME    foldTM   = fdVar    filterTM = ftVar+   mapMaybeTM = mpVar  lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v@@ -617,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/Multiplicity.hs view
@@ -30,7 +30,9 @@   , IsSubmult(..)   , submult   , mapScaledType-  , pprArrowWithMultiplicity ) where+  , pprArrowWithMultiplicity+  , MultiplicityFlag(..)+  ) where  import GHC.Prelude @@ -395,3 +397,8 @@   | otherwise   = ppr (funTyFlagTyCon af) +-- | In Core, without `-dlinear-core-lint`, some function must ignore+-- multiplicities. See Note [Linting linearity] in GHC.Core.Lint.+data MultiplicityFlag+  = RespectMultiplicities+  | IgnoreMultiplicities
compiler/GHC/Core/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 )+import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy ) import GHC.Core.Multiplicity  -- We have two sorts of substitution:@@ -68,6 +69,7 @@ import GHC.Types.Demand import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) import GHC.Types.Id+import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic@@ -84,9 +86,10 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import Data.List.NonEmpty ( nonEmpty )+import qualified Data.List.NonEmpty as NE import Data.Maybe( isJust )  {-@@ -134,6 +137,9 @@ -- Join points are supposed to have manifestly-visible -- lambdas at the top: no ticks, no casts, nothing -- Moreover, type lambdas count in JoinArity+-- NB: For non-recursive bindings, the join arity of the binding may actually be+-- less that the number of manifestly-visible lambdas.+-- See Note [Join arity prediction based on joinRhsArity] in GHC.Core.Opt.OccurAnal joinRhsArity (Lam _ e) = 1 + joinRhsArity e joinRhsArity _         = 0 @@ -195,8 +201,10 @@   = go initRecTc ty   where     go rec_nts ty-      | Just (_, ty')  <- splitForAllTyCoVar_maybe ty-      = go rec_nts ty'+      | Just (tcv, ty')  <- splitForAllTyCoVar_maybe ty+      = if isCoVar tcv+        then idOneShotInfo tcv : go rec_nts ty'+        else go rec_nts ty'        | Just (_,_,arg,res) <- splitFunTy_maybe ty       = typeOneShot arg : go rec_nts res@@ -510,8 +518,11 @@  Of course both (1) and (2) are readily defeated by disguising the bottoms. -4. Note [Newtype arity]-~~~~~~~~~~~~~~~~~~~~~~~~+There also is an interaction with Note [Combining arity type with demand info],+outlined in Wrinkle (CAD1).++Note [Newtype arity]+~~~~~~~~~~~~~~~~~~~~ Non-recursive newtypes are transparent, and should not get in the way. We do (currently) eta-expand recursive newtypes too.  So if we have, say @@ -713,7 +724,7 @@ now reflects the (cost-free) arity of the expression  Why do we ever need an "unsafe" ArityType, such as the example above?-Because its (cost-free) arity may increased by combineWithDemandOneShots+Because its (cost-free) arity may increased by combineWithCallCards in findRhsArity. See Note [Combining arity type with demand info].  Thus the function `arityType` returns a regular "unsafe" ArityType, that@@ -915,14 +926,14 @@                          NonRecursive -> trimArityType ty_arity (cheapArityType rhs)      ty_arity     = typeArity (idType bndr)-    id_one_shots = idDemandOneShots bndr+    use_call_cards = useSiteCallCards bndr      step :: ArityEnv -> SafeArityType     step env = trimArityType ty_arity $                safeArityType $ -- See Note [Arity invariants for bindings], item (3)-               arityType env rhs `combineWithDemandOneShots` id_one_shots+               combineWithCallCards env (arityType env rhs) use_call_cards        -- trimArityType: see Note [Trim arity inside the loop]-       -- combineWithDemandOneShots: take account of the demand on the+       -- combineWithCallCards: take account of the demand on the        -- binder.  Perhaps it is always called with 2 args        --   let f = \x. blah in (f 3 4, f 1 9)        -- f's demand-info says how many args it is called with@@ -947,14 +958,24 @@       where         next_at = step (extendSigEnv init_env bndr cur_at) -infixl 2 `combineWithDemandOneShots`--combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType+combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType -- See Note [Combining arity type with demand info]-combineWithDemandOneShots at@(AT lams div) oss+combineWithCallCards env at@(AT lams div) cards   | null lams = at   | otherwise = AT (zip_lams lams oss) div   where+    oss = map card_to_oneshot cards+    card_to_oneshot n+      | isAtMostOnce n, not (pedanticBottoms env)+         -- Take care for -fpedantic-bottoms;+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | n == C_11+         -- Safe to eta-expand even in the presence of -fpedantic-bottoms+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | otherwise+      = NoOneShotInfo     zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo]     zip_lams lams []  = lams     zip_lams []   oss | isDeadEndDiv div = []@@ -963,29 +984,33 @@     zip_lams ((ch,os1):lams) (os2:oss)       = (ch, os1 `bestOneShot` os2) : zip_lams lams oss -idDemandOneShots :: Id -> [OneShotInfo]-idDemandOneShots bndr-  = call_arity_one_shots `zip_lams` dmd_one_shots+useSiteCallCards :: Id -> [Card]+useSiteCallCards bndr+  = call_arity_one_shots `zip_cards` dmd_one_shots   where-    call_arity_one_shots :: [OneShotInfo]+    call_arity_one_shots :: [Card]     call_arity_one_shots       | call_arity == 0 = []-      | otherwise       = NoOneShotInfo : replicate (call_arity-1) OneShotLam-    -- Call Arity analysis says the function is always called-    -- applied to this many arguments.  The first NoOneShotInfo is because-    -- if Call Arity says "always applied to 3 args" then the one-shot info-    -- we get is [NoOneShotInfo, OneShotLam, OneShotLam]+      | otherwise       = C_0N : replicate (call_arity-1) C_01+    -- Call Arity analysis says /however often the function is called/, it is+    -- always applied to this many arguments.+    -- The first C_0N is because of the "however often it is called" part.+    -- Thus if Call Arity says "always applied to 3 args" then the one-shot info+    -- we get is [C_0N, C_01, C_01]     call_arity = idCallArity bndr -    dmd_one_shots :: [OneShotInfo]+    dmd_one_shots :: [Card]     -- If the demand info is C(x,C(1,C(1,.))) then we know that an     -- application to one arg is also an application to three-    dmd_one_shots = argOneShots (idDemandInfo bndr)+    dmd_one_shots = case idDemandInfo bndr of+      AbsDmd  -> [] -- There is no use in eta expanding+      BotDmd  -> [] -- when the binding could be dropped instead+      _ :* sd -> callCards sd      -- Take the *longer* list-    zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2-    zip_lams []           lams2        = lams2-    zip_lams lams1        []           = lams1+    zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2+    zip_cards []       ns2      = ns2+    zip_cards ns1      []       = ns1  {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1081,7 +1106,7 @@ result: arity=3, which is better than we could do from either source alone. -The "combining" part is done by combineWithDemandOneShots.  It+The "combining" part is done by combineWithCallCards.  It uses info from both Call Arity and demand analysis.  We may have /more/ call demands from the calls than we have lambdas@@ -1100,6 +1125,22 @@ Nor, in the case of f2, do we want to push that error call under a lambda.  Hence the takeWhile in combineWithDemandDoneShots. +Wrinkles:++(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms+  (See Note [Dealing with bottom]). Consider++    let f = \x y. error "blah" in+    f 2 1 `seq` Just (f 3 2 1)+      -- Demand on f is C(x,C(1,C(M,L)))++  Usually, it is OK to consider a lambda that is called *at most* once (so call+  cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it.+  But with -fpedantic-bottoms that is no longer true: If we were to eta-expand+  f to arity 3, we'd discard the error raised when evaluating `f 2 1`.+  Hence in the presence of -fpedantic-bottoms, we must have C_11 for+  eta-expansion.+ Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly to CPR (see Note [Don't w/w join points for CPR] in@@ -1232,8 +1273,14 @@ floatIn :: Cost -> ArityType -> ArityType -- We have something like (let x = E in b), -- where b has the given arity type.-floatIn IsCheap     at = at-floatIn IsExpensive at = addWork at+-- NB: be as lazy as possible in the Cost-of-E argument;+--     we can often get away without ever looking at it+--     See Note [Care with nested expressions]+floatIn ch at@(AT lams div)+  = case lams of+      []                 -> at+      (IsExpensive,_):_  -> at+      (_,os):lams        -> AT ((ch,os):lams) div  addWork :: ArityType -> ArityType -- Add work to the outermost level of the arity type@@ -1316,6 +1363,25 @@ first bullet).  So 'go2' gets an arityType of \(C?)(C1).T, which is what we want. +Note [Care with nested expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    arityType (Just <big-expressions>)+We will take+    arityType Just = AT [(IsCheap,os)] topDiv+and then do+    arityApp (AT [(IsCheap os)] topDiv) (exprCost <big-expression>)+The result will be AT [] topDiv.  It doesn't matter what <big-expresison>+is!  The same is true of+    arityType (let x = <rhs> in <body>)+where the cost of <rhs> doesn't matter unless <body> has a useful+arityType.++TL;DR in `floatIn`, do not to look at the Cost argument until you have to.++I found this when looking at #24471, although I don't think it was really+the main culprit.+ Note [Combining case branches: andWithTail] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When combining the ArityTypes for two case branches (with andArityType)@@ -1357,6 +1423,16 @@ We really want to eta-expand this!  #20103 is quite convincing! We do this regardless of -fdicts-cheap; it's not really a dictionary. +We also want to check both for (IP blah CallStack) and for CallStack itself.+We might have either+   d :: IP blah CallStack    -- Or HasCallStack+   d = (cs-expr :: CallStack) |> (nt-ax :: CallStack ~ IP blah CallStack)+or just+   cs :: CallStack+   cs = cs-expr++Test T20103 is an example of the latter.+ Note [Eta expanding through dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the experimental -fdicts-cheap flag is on, we eta-expand through@@ -1456,11 +1532,11 @@     cheap_dict = case mb_ty of                      Nothing -> False                      Just ty -> (ao_dicts_cheap opts && isDictTy ty)-                                || isCallStackPredTy ty+                                || isCallStackPredTy ty || isCallStackTy ty         -- 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@@ -1526,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]@@ -1873,15 +1948,14 @@   \(y::Int). let j' :: Int -> Bool                  j' x = e y              in b[j'/j] y-where I have written to stress that j's type has+where I have written b[j'/j] to stress that j's type has changed.  Note that (of course!) we have to push the application inside the RHS of the join as well as into the body.  AND if j has an unfolding we have to push it into there too.  AND j might be recursive... -So for now I'm abandoning the no-crap rule in this case. I think-that for the use in CorePrep it really doesn't matter; and if-it does, then CoreToStg.myCollectArgs will fall over.+So for now I'm abandoning the no-crap rule in this case, conscious that this+causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep].  (Moreover, I think that casts can make the no-crap rule fail too.) @@ -2036,8 +2110,8 @@     Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp -To a first approximation EtaInfo is just [Var].  But-casts complicate the question.  If we have+To a first approximation EtaInfo is just [Var].  But casts complicate+the question.  If we have    newtype N a = MkN (S -> a)      axN :: N a  ~  S -> a and@@ -2053,6 +2127,20 @@     data EtaInfo = EI [Var] MCoercionR +Precisely, here is the (EtaInfo Invariant):++  EI bs co :: EtaInfo++describes a particular eta-expansion, thus:++  Abstraction:  (\b1 b2 .. bn. []) |> sym co+  Application:  ([] |> co) b1 b2 .. bn++  e  :: T+  co :: T ~R (t1 -> t2 -> .. -> tn -> tr)+  e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co++ Note [Check for reflexive casts in eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It turns out that the casts created by the above mechanism are often Refl.@@ -2108,13 +2196,7 @@  -------------- data EtaInfo = EI [Var] MCoercionR---- (EI bs co) describes a particular eta-expansion, as follows:---  Abstraction:  (\b1 b2 .. bn. []) |> sym co---  Application:  ([] |> co) b1 b2 .. bn------    e :: T    co :: T ~ (t1 -> t2 -> .. -> tn -> tr)---    e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co+     -- See Note [The EtaInfo mechanism]  instance Outputable EtaInfo where   ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco)@@ -2178,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@@ -2224,18 +2306,18 @@      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)-       | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty+       | Just (Bndr tcv vis, ty') <- splitForAllForAllTyBinder_maybe ty        , (subst', tcv') <- Type.substVarBndr subst tcv        , let oss' | isTyVar tcv = oss                   | otherwise   = oss1          -- A forall can bind a CoVar, in which case          -- we consume one of the [OneShotInfo]        , (in_scope, EI bs mco) <- go n oss' subst' ty'-       = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco))+       = (in_scope, EI (tcv' : bs) (mkEtaForAllMCo (Bndr tcv' vis) ty' mco))         ----------- Function types  (t1 -> t2)        | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty@@ -2271,13 +2353,26 @@                          -- 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).         -- So we simply decline to eta-expand.  Otherwise we'd end up         -- with an explicit lambda having a non-function type +mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion+mkEtaForAllMCo (Bndr tcv vis) ty mco+  = case mco of+      MRefl | vis == coreTyLamForAllTyFlag -> MRefl+            | otherwise                    -> mk_fco (mkRepReflCo ty)+      MCo co                               -> mk_fco co+  where+    mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag+                                (mkNomReflCo (varType tcv)) co)+    -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly+    -- the (EtaInfo Invariant).  (sym co) wraps a lambda that always has+    -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]+    -- in GHC.Core.TyCo.Rep  {- ************************************************************************@@ -2414,14 +2509,6 @@ And here are a few more technical criteria for when it is *not* sound to eta-reduce that are specific to Core and GHC: -(L) With linear types, eta-reduction can break type-checking:-      f :: A ⊸ B-      g :: A -> B-      g = \x. f x-    The above is correct, but eta-reducing g would yield g=f, the linter will-    complain that g and f don't have the same type. NB: Not unsound in the-    dynamic semantics, but unsound according to the static semantics of Core.- (J) We may not undersaturate join points.     See Note [Invariants on join points] in GHC.Core, and #20599. @@ -2681,7 +2768,7 @@       | fun `elemUnVarSet` rec_ids          -- Criterion (R)       = False -- Don't eta-reduce in fun in its own recursive RHSs -      | cantEtaReduceFun fun                -- Criteria (L), (J), (W), (B)+      | cantEtaReduceFun fun                -- Criteria (J), (W), (B)       = False -- Function can't be eta reduced to arity 0               -- without violating invariants of Core and GHC @@ -2704,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)      ---------------@@ -2717,9 +2804,19 @@                                --   (and similarly for tyvars, coercion args)                     , [CoreTickish])     -- See Note [Eta reduction with casted arguments]-    ok_arg bndr (Type ty) co _-       | Just tv <- getTyVar_maybe ty-       , bndr == tv  = Just (mkHomoForAllCos [tv] co, [])+    ok_arg bndr (Type arg_ty) co fun_ty+       | Just tv <- getTyVar_maybe arg_ty+       , bndr == tv  = case splitForAllForAllTyBinder_maybe fun_ty of+           Just (Bndr _ vis, _) -> Just (fco, [])+             where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co+                   -- The lambda we are eta-reducing always has visibility+                   -- 'coreTyLamForAllTyFlag' which may or may not match+                   -- the visibility on the inner function (#24014)+                   kco = mkNomReflCo (tyVarKind tv)+           Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type"+                               (text "fun:" <+> ppr bndr+                                $$ text "arg:" <+> ppr arg_ty+                                $$ text "fun_ty:" <+> ppr fun_ty)     ok_arg bndr (Var v) co fun_ty        | bndr == v        , let mult = idMult bndr@@ -2741,7 +2838,7 @@     ok_arg _ _ _ _ = Nothing  -- | Can we eta-reduce the given function--- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L).+-- See Note [Eta reduction soundness], criteria (B), (J), and (W). cantEtaReduceFun :: Id -> Bool cantEtaReduceFun fun   =    hasNoBinding fun -- (B)@@ -2755,12 +2852,7 @@        -- Don't undersaturate StrictWorkerIds.        -- See Note [CBV Function Ids] in GHC.Types.Id.Info. -    ||  isLinearType (idType fun) -- (L)-       -- Don't perform eta reduction on linear types.-       -- If `f :: A %1-> B` and `g :: A -> B`,-       -- then `g x = f x` is OK but `g = f` is not. - {- ********************************************************************* *                                                                      *               The "push rules"@@ -2930,21 +3022,31 @@     | otherwise     = Nothing -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion+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 co-  | isReflCo co || from_ty `eqType` to_ty  -- try cheap test first-  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args-  = Just (dc, map exprToType univ_ty_args, rest_args)+pushCoDataCon dc dc_args MRefl    = Just $! (push_dc_refl dc dc_args)+pushCoDataCon dc dc_args (MCo co) = push_dc_gen  dc dc_args co (coercionKind co) +push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr])+push_dc_refl dc dc_args+  = (dc, map exprToType univ_ty_args, rest_args)+  where+    !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args++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+  = Just $! (push_dc_refl dc dc_args)+   | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty   , to_tc == dataConTyCon dc         -- These two tests can fail; we might see@@ -2952,46 +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) -  where-    Pair from_ty to_ty = coercionKind co+    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@@ -3047,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.- -}  {- *********************************************************************@@ -3105,7 +3212,7 @@ -- Adds as many binders as asked for; assumes expr is not a lambda etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) etaBodyForJoinPoint need_args body-  = go need_args (exprType body) (init_subst body) [] body+  = go need_args body_ty (mkEmptySubst in_scope) [] body   where     go 0 _  _     rev_bs e       = (reverse rev_bs, e)@@ -3124,9 +3231,16 @@       = pprPanic "etaBodyForJoinPoint" $ int need_args $$                                          ppr body $$ ppr (exprType body) -    init_subst e = mkEmptySubst (mkInScopeSet (exprFreeVars e))--+    body_ty = exprType body+    in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty)+    -- in_scope is a bit tricky.+    -- - We are wrapping `body` in some value lambdas, so must not shadow+    --   any free vars of `body`+    -- - We are wrapping `body` in some type lambdas, so must not shadow any+    --   tyvars in body_ty.  Example: body is just a variable+    --            (g :: forall (a::k). T k a -> Int)+    --   We must not shadown that `k` when adding the /\a. So treat the free vars+    --   of body_ty as in-scope.  Showed up in #23026.  -------------- freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id)@@ -3141,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.hs view
@@ -15,18 +15,15 @@     , parseCallerCcFilter     ) where -import Data.Word (Word8) import Data.Maybe  import Control.Applicative import GHC.Utils.Monad.State.Strict-import Data.Either import Control.Monad-import qualified Text.ParserCombinators.ReadP as P  import GHC.Prelude import GHC.Utils.Outputable as Outputable-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName)@@ -38,11 +35,8 @@ import GHC.Data.FastString import GHC.Core import GHC.Core.Opt.Monad-import GHC.Utils.Panic-import qualified GHC.Utils.Binary as B-import Data.Char+import GHC.Core.Opt.CallerCC.Types -import Language.Haskell.Syntax.Module.Name  addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do@@ -138,91 +132,4 @@             Nothing -> True         checkFunc =             occNameMatches (ccfFuncName ccf) (getOccName i)--data NamePattern-    = PChar Char NamePattern-    | PWildcard NamePattern-    | PEnd--instance Outputable NamePattern where-  ppr (PChar c rest) = char c <> ppr rest-  ppr (PWildcard rest) = char '*' <> ppr rest-  ppr PEnd = Outputable.empty--instance B.Binary NamePattern where-  get bh = do-    tag <- B.get bh-    case tag :: Word8 of-      0 -> PChar <$> B.get bh <*> B.get bh-      1 -> PWildcard <$> B.get bh-      2 -> pure PEnd-      _ -> panic "Binary(NamePattern): Invalid tag"-  put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y-  put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x-  put_ bh PEnd = B.put_ bh (2 :: Word8)--occNameMatches :: NamePattern -> OccName -> Bool-occNameMatches pat = go pat . occNameString-  where-    go :: NamePattern -> String -> Bool-    go PEnd "" = True-    go (PChar c rest) (d:s)-      = d == c && go rest s-    go (PWildcard rest) s-      = go rest s || go (PWildcard rest) (tail s)-    go _ _  = False--type Parser = P.ReadP--parseNamePattern :: Parser NamePattern-parseNamePattern = pattern-  where-    pattern = star P.<++ wildcard P.<++ char P.<++ end-    star = PChar '*' <$ P.string "\\*" <*> pattern-    wildcard = do-      void $ P.char '*'-      PWildcard <$> pattern-    char = PChar <$> P.get <*> pattern-    end = PEnd <$ P.eof--data CallerCcFilter-    = CallerCcFilter { ccfModuleName  :: Maybe ModuleName-                     , ccfFuncName    :: NamePattern-                     }--instance Outputable CallerCcFilter where-  ppr ccf =-    maybe (char '*') ppr (ccfModuleName ccf)-    <> char '.'-    <> ppr (ccfFuncName ccf)--instance B.Binary CallerCcFilter where-  get bh = CallerCcFilter <$> B.get bh <*> B.get bh-  put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y--parseCallerCcFilter :: String -> Either String CallerCcFilter-parseCallerCcFilter inp =-    case P.readP_to_S parseCallerCcFilter' inp of-      ((result, ""):_) -> Right result-      _ -> Left $ "parse error on " ++ inp--parseCallerCcFilter' :: Parser CallerCcFilter-parseCallerCcFilter' =-  CallerCcFilter-    <$> moduleFilter-    <*  P.char '.'-    <*> parseNamePattern-  where-    moduleFilter :: Parser (Maybe ModuleName)-    moduleFilter =-      (Just . mkModuleName <$> moduleName)-      <|>-      (Nothing <$ P.char '*')--    moduleName :: Parser String-    moduleName = do-      c <- P.satisfy isUpper-      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')-      rest <- optional $ P.char '.' >> fmap ('.':) moduleName-      return $ c : (cs ++ fromMaybe "" rest)
− compiler/GHC/Core/Opt/CallerCC.hs-boot 
@@ -1,8 +0,0 @@-module GHC.Core.Opt.CallerCC where--import GHC.Prelude---- Necessary due to import in GHC.Driver.Session.-data CallerCcFilter--parseCallerCcFilter :: String -> Either String CallerCcFilter
+ compiler/GHC/Core/Opt/CallerCC/Types.hs view
@@ -0,0 +1,122 @@+module GHC.Core.Opt.CallerCC.Types ( NamePattern(..)+                                   , CallerCcFilter(..)+                                   , occNameMatches+                                   , parseCallerCcFilter+                                   , parseNamePattern+                                   ) where++import Data.Word (Word8)+import Data.Maybe++import Control.Applicative+import Data.Either+import Control.Monad+import qualified Text.ParserCombinators.ReadP as P++import GHC.Prelude+import GHC.Utils.Outputable as Outputable+import GHC.Types.Name hiding (varName)+import GHC.Utils.Panic+import qualified GHC.Utils.Binary as B+import Data.Char+import Control.DeepSeq++import Language.Haskell.Syntax.Module.Name+++data NamePattern+    = PChar Char NamePattern+    | PWildcard NamePattern+    | PEnd++instance Outputable NamePattern where+  ppr (PChar c rest) = char c <> ppr rest+  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+    case tag :: Word8 of+      0 -> PChar <$> B.get bh <*> B.get bh+      1 -> PWildcard <$> B.get bh+      2 -> pure PEnd+      _ -> panic "Binary(NamePattern): Invalid tag"+  put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y+  put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x+  put_ bh PEnd = B.put_ bh (2 :: Word8)++occNameMatches :: NamePattern -> OccName -> Bool+occNameMatches pat = go pat . occNameString+  where+    go :: NamePattern -> String -> Bool+    go PEnd "" = True+    go (PChar c rest) (d:s)+      = d == c && go rest s+    go (PWildcard rest) s+      = go rest s || go (PWildcard rest) (tail s)+    go _ _  = False++++type Parser = P.ReadP++parseNamePattern :: Parser NamePattern+parseNamePattern = namePattern+  where+    namePattern = star P.<++ wildcard P.<++ char P.<++ end+    star = PChar '*' <$ P.string "\\*" <*> namePattern+    wildcard = do+      void $ P.char '*'+      PWildcard <$> namePattern+    char = PChar <$> P.get <*> namePattern+    end = PEnd <$ P.eof++data CallerCcFilter+    = 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 =+    maybe (char '*') ppr (ccfModuleName ccf)+    <> char '.'+    <> ppr (ccfFuncName ccf)++instance B.Binary CallerCcFilter where+  get bh = CallerCcFilter <$> B.get bh <*> B.get bh+  put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y++parseCallerCcFilter :: String -> Either String CallerCcFilter+parseCallerCcFilter inp =+    case P.readP_to_S parseCallerCcFilter' inp of+      ((result, ""):_) -> Right result+      _ -> Left $ "parse error on " ++ inp++parseCallerCcFilter' :: Parser CallerCcFilter+parseCallerCcFilter' =+  CallerCcFilter+    <$> moduleFilter+    <*  P.char '.'+    <*> parseNamePattern+  where+    moduleFilter :: Parser (Maybe ModuleName)+    moduleFilter =+      (Just . mkModuleName <$> moduleName)+      <|>+      (Nothing <$ P.char '*')++    moduleName :: Parser String+    moduleName = do+      c <- P.satisfy isUpper+      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')+      rest <- optional $ P.char '.' >> fmap ('.':) moduleName+      return $ c : (cs ++ fromMaybe "" rest)
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -20,19 +20,21 @@ {-# 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    ( primOpRules    , builtinRules    , caseRules+   , caseRules2    ) where  import GHC.Prelude  import GHC.Platform+import GHC.Float  import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id@@ -53,9 +55,8 @@ import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon-   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon-   , isNewTyCon, tyConDataCons-   , tyConFamilySize )+   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize+   , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr )  import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )@@ -64,13 +65,14 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Names +import GHC.Cmm.MachOp ( FMASign(..) )+import GHC.Cmm.Type ( Width(..) )+ import GHC.Data.FastString-import GHC.Data.Maybe      ( orElse )  import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Applicative ( Alternative(..) ) import Control.Monad@@ -100,7 +102,8 @@ primOpRules ::  Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case    TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]-   DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]+   DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ]+   DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ]     -- Int8 operations    Int8AddOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))@@ -120,7 +123,9 @@    Int8QuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot)                                     , leftZero                                     , rightIdentity oneI8-                                    , equalArgs $> Lit oneI8 ]+                                    , equalArgs $> Lit oneI8+                                    , quotFoldingRules int8Ops+                                    ]    Int8RemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI8@@ -149,7 +154,9 @@                                     , mulFoldingRules Word8MulOp word8Ops                                     ]    Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot)-                                    , rightIdentity oneW8 ]+                                    , rightIdentity oneW8+                                    , quotFoldingRules word8Ops+                                    ]    Word8RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW8@@ -194,7 +201,9 @@    Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot)                                     , leftZero                                     , rightIdentity oneI16-                                    , equalArgs $> Lit oneI16 ]+                                    , equalArgs $> Lit oneI16+                                    , quotFoldingRules int16Ops+                                    ]    Int16RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI16@@ -223,7 +232,9 @@                                     , mulFoldingRules Word16MulOp word16Ops                                     ]    Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot)-                                    , rightIdentity oneW16 ]+                                    , rightIdentity oneW16+                                    , quotFoldingRules word16Ops+                                    ]    Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW16@@ -268,7 +279,9 @@    Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot)                                     , leftZero                                     , rightIdentity oneI32-                                    , equalArgs $> Lit oneI32 ]+                                    , equalArgs $> Lit oneI32+                                    , quotFoldingRules int32Ops+                                    ]    Int32RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI32@@ -297,7 +310,9 @@                                     , mulFoldingRules Word32MulOp word32Ops                                     ]    Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot)-                                    , rightIdentity oneW32 ]+                                    , rightIdentity oneW32+                                    , quotFoldingRules word32Ops+                                    ]    Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW32@@ -341,7 +356,9 @@    Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot)                                     , leftZero                                     , rightIdentity oneI64-                                    , equalArgs $> Lit oneI64 ]+                                    , equalArgs $> Lit oneI64+                                    , quotFoldingRules int64Ops+                                    ]    Int64RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI64@@ -370,7 +387,9 @@                                     , mulFoldingRules Word64MulOp word64Ops                                     ]    Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot)-                                    , rightIdentity oneW64 ]+                                    , rightIdentity oneW64+                                    , quotFoldingRules word64Ops+                                    ]    Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW64@@ -451,7 +470,9 @@    IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)                                     , leftZero                                     , rightIdentityPlatform onei-                                    , equalArgs >> retLit onei ]+                                    , equalArgs >> retLit onei+                                    , quotFoldingRules intOps+                                    ]    IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)                                     , leftZero                                     , oneLit 1 >> retLit zeroi@@ -503,7 +524,9 @@                                     , mulFoldingRules WordMulOp wordOps                                     ]    WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)-                                    , rightIdentityPlatform onew ]+                                    , rightIdentityPlatform onew+                                    , quotFoldingRules wordOps+                                    ]    WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)                                     , leftZero                                     , oneLit 1 >> retLit zerow@@ -634,6 +657,38 @@                                        , removeOp32                                        , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ] +   CastWord64ToDoubleOp -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+         LitNumber _ n+             | v <- castWord64ToDouble (fromInteger n)+             -- we can't represent those float literals in Core until #18897 is fixed+             , not (isNaN v || isInfinite v || isNegativeZero v)+             -> Just (mkDoubleLitDouble v)+         _   -> Nothing+      ]++   CastWord32ToFloatOp -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+          LitNumber _ n+              | v <- castWord32ToFloat (fromInteger n)+              -- we can't represent those float literals in Core until #18897 is fixed+              , not (isNaN v || isInfinite v || isNegativeZero v)+              -> Just (mkFloatLitFloat v)+          _   -> Nothing+      ]++   CastDoubleToWord64Op -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+         LitDouble n -> Just (mkWord64LitWord64 (castDoubleToWord64 (fromRational n)))+         _           -> Nothing+      ]++   CastFloatToWord32Op -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+          LitFloat n -> Just (mkWord32LitWord32 (castFloatToWord32 (fromRational n)))+          _          -> Nothing+      ]+    OrdOp          -> mkPrimOpRule nm 1 [ liftLit charToIntLit                                        , semiInversePrimOp ChrOp ]    ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs@@ -656,6 +711,11 @@    FloatMulOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))                                           , identity onef                                           , strengthReduction twof FloatAddOp  ]+   FloatFMAdd        -> mkPrimOpRule nm 3 (fmaRules FMAdd  W32)+   FloatFMSub        -> mkPrimOpRule nm 3 (fmaRules FMSub  W32)+   FloatFNMAdd       -> mkPrimOpRule nm 3 (fmaRules FNMAdd W32)+   FloatFNMSub       -> mkPrimOpRule nm 3 (fmaRules FNMSub W32)+              -- zeroElem zerof doesn't hold because of NaN    FloatDivOp        -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))                                           , rightIdentity onef ]@@ -671,6 +731,10 @@    DoubleMulOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))                                              , identity oned                                              , strengthReduction twod DoubleAddOp  ]+   DoubleFMAdd          -> mkPrimOpRule nm 3 (fmaRules FMAdd  W64)+   DoubleFMSub          -> mkPrimOpRule nm 3 (fmaRules FMSub  W64)+   DoubleFNMAdd         -> mkPrimOpRule nm 3 (fmaRules FNMAdd W64)+   DoubleFNMSub         -> mkPrimOpRule nm 3 (fmaRules FNMSub W64)               -- zeroElem zerod doesn't hold because of NaN    DoubleDivOp          -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))                                              , rightIdentity oned ]@@ -790,7 +854,6 @@     AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] -   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]    SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]     _          -> Nothing@@ -1066,7 +1129,7 @@     _ | shift_len == 0 -> pure e1        -- See Note [Guarding against silly shifts]-    _ | shift_len < 0 || shift_len > bit_size+    _ | shift_len < 0 || shift_len >= bit_size       -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0            -- Be sure to use lit_num_ty here, so we get a correctly typed zero.            -- See #18589@@ -1118,6 +1181,150 @@   = Nothing  --------------------------++-- | Constant folding rules for fused multiply-add operations.+fmaRules :: FMASign -> Width -> [RuleM CoreExpr]+fmaRules signs width =+     [ fmaLit signs width+     , fmaZero_z signs width+     , fmaOne signs width ]++-- | Compute @a * b + c@ when @a@, @b@, @c@ are all literals.+fmaLit :: FMASign -> Width -> RuleM CoreExpr+fmaLit signs width = do+  env <- getRuleOpts+  [Lit l1, Lit l2, Lit l3] <- getArgs+  liftMaybe $+    op env+      (convFloating env l1)+      (convFloating env l2)+      (convFloating env l3)++  where+    op env l1 l2 l3 =+      case width of+        W32+          | LitFloat x <- l1+          , LitFloat y <- l2+          , LitFloat z <- l3+          -> Just $ mkFloatVal env $+            case signs of+              FMAdd  -> x * y + z+              FMSub  -> x * y - z+              FNMAdd -> negate ( x * y ) + z+              FNMSub -> negate ( x * y ) - z+        W64+          | LitDouble x <- l1+          , LitDouble y <- l2+          , LitDouble z <- l3+          -> Just $ mkDoubleVal env $+            case signs of+              FMAdd  -> x * y + z+              FMSub  -> x * y - z+              FNMAdd -> negate ( x * y ) + z+              FNMSub -> negate ( x * y ) - z+        _ -> Nothing++-- | @x * y + 0 = x * y@.+fmaZero_z :: FMASign -> Width -> RuleM CoreExpr+fmaZero_z signs width = do+  [x, y, Lit z] <- getArgs+  let+    -- TODO: we should additionally check the sign of z.+    -- FMAdd, FNMAdd: should be -0.0.+    -- FMSub, FNMSub: should be +0.0.+    ok =+      case width of+        W32+          | LitFloat 0 <- z+          -> True+        W64+          | LitDouble 0 <- z+          -> True+        _ -> False+    neg = case width of+      W32 ->  FloatNegOp+      W64 -> DoubleNegOp+      _   -> panic "fmaZero_xy: not Float# or Double#"+    mul = case width of+      W32 ->  FloatMulOp+      W64 -> DoubleMulOp+      _   -> panic "fmaZero_z: not Float# or Double#"+  if ok+  then return $ case signs of+    FMAdd  -> Var (primOpId mul) `App` x `App` y+    FMSub  -> Var (primOpId mul) `App` x `App` y+    FNMAdd -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y)+    FNMSub -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y)+  else mzero++-- | @±1 * y + z ==> z ± y@ and @x * ±1 + z ==> z ± x@.+fmaOne :: FMASign -> Width -> RuleM CoreExpr+fmaOne signs width = do+  [x, y, z] <- getArgs+  let+    posNegOne_maybe :: Rational -> Maybe Bool+    posNegOne_maybe i+      | i == 1+      = Just False+      | i == -1+      = Just True+      | otherwise+      = Nothing+    ok =+      case width of+        W32+          | Lit (LitFloat i) <- x+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, y)+          | Lit (LitFloat i) <- y+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, x)+        W64+          | Lit (LitDouble i) <- x+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, y)+          | Lit (LitDouble i) <- y+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, x)+        _ -> Nothing+    neg = case width of+      W32 ->  FloatNegOp+      W64 -> DoubleNegOp+      _   -> panic "fmaOne: not Float# or Double#"+    add = case width of+      W32 ->  FloatAddOp+      W64 -> DoubleAddOp+      _   -> panic "fmaOne: not Float# or Double#"+    sub = case width of+      W32 ->  FloatSubOp+      W64 -> DoubleSubOp+      _   -> panic "fmaOne: not Float# or Double#"+  case ok of+    Nothing  -> mzero+    Just (sgn, t) -> return $+      if -- t + z+         |  ( signs ==  FMAdd && sgn == False )+         || ( signs == FNMAdd && sgn == True  )+         -> Var (primOpId add) `App` t `App` z+         -- - t + z+         |  signs ==  FMAdd+         || signs == FNMAdd+         -> Var (primOpId sub) `App` z `App` t+         -- t - z+         |  ( signs ==  FMSub && sgn == False )+         || ( signs == FNMSub && sgn == True  )+         -> Var (primOpId sub) `App` t `App` z+         -- - t - z+         |  signs ==  FMSub+         || signs == FNMSub+         -> Var (primOpId neg) `App` (Var (primOpId add) `App` t `App` z)+         | otherwise+         -> pprPanic "fmaOne: non-exhaustive pattern match" $+              vcat [ text "signs:" <+> text (show signs)+                   , text "sign:" <+> ppr sgn ]++-------------------------- {- Note [The litEq rule: converting equality to case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This stuff turns@@ -1404,15 +1611,15 @@     let x = I# (error "invalid shift")     in ... -This was originally done in the fix to #16449 but this breaks the let-can-float-invariant (see Note [Core let-can-float invariant] in GHC.Core) as noted in #16742.-For the reasons discussed in Note [Checking versus non-checking-primops] (in the PrimOp module) there is no safe way to rewrite the argument of I#-such that it bottoms.+This was originally done in the fix to #16449 but this breaks the+let-can-float invariant (see Note [Core let-can-float invariant] in+GHC.Core) as noted in #16742.  For the reasons discussed under+"NoEffect" in Note [Classifying primop effects] (in GHC.Builtin.PrimOps)+there is no safe way to rewrite the argument of I# such that it bottoms. -Consequently we instead take advantage of the fact that large shifts are-undefined behavior (see associated documentation in primops.txt.pp) and-transform the invalid shift into an "obviously incorrect" value.+Consequently we instead take advantage of the fact that the result of a+large shift is unspecified (see associated documentation in primops.txt.pp)+and transform the invalid shift into an "obviously incorrect" value.  There are two cases: @@ -1789,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@@ -1800,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) $@@ -1810,12 +2029,14 @@  ------------------------------ dataToTagRule :: RuleM CoreExpr--- See Note [dataToTag# magic].+-- Used for both dataToTagSmall# and dataToTagLarge#.+-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,+-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b   where     -- dataToTag (tagToEnum x)   ==>   x     a = do-      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      [Type _lev, Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs       guard $ tag_to_enum `hasKey` tagToEnumKey       guard $ ty1 `eqType` ty2       return tag@@ -1826,42 +2047,13 @@     -- where x's unfolding is a constructor application     b = do       platform <- getPlatform-      [_, val_arg] <- getArgs+      [_lev, _ty, val_arg] <- getArgs       in_scope <- getInScopeEnv       (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg       massert (not (isNewTyCon (dataConTyCon dc)))       return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) -{- Note [dataToTag# magic]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The primop dataToTag# is unusual because it evaluates its argument.-Only `SeqOp` shares that property.  (Other primops do not do anything-as fancy as argument evaluation.)  The special handling for dataToTag#-is: -* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,-  (actually in app_ok).  Most primops with lifted arguments do not-  evaluate those arguments, but DataToTagOp and SeqOp are two-  exceptions.  We say that they are /never/ ok-for-speculation,-  regardless of the evaluated-ness of their argument.-  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]--* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,-  that evaluates its argument and then extracts the tag from-  the returned value.--* An application like (dataToTag# (Just x)) is optimised by-  dataToTagRule in GHC.Core.Opt.ConstantFold.--* A case expression like-     case (dataToTag# e) of <alts>-  gets transformed t-     case e of <transformed alts>-  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]--See #15696 for a long saga.--}- {- ********************************************************************* *                                                                      *              unsafeEqualityProof@@ -1878,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]) }@@ -1886,75 +2078,18 @@  {- ********************************************************************* *                                                                      *-             Rules for seq# and spark#+             Rules for spark# *                                                                      * ********************************************************************* -} -{- Note [seq# magic]-~~~~~~~~~~~~~~~~~~~~-The primop-   seq# :: forall a s . a -> State# s -> (# State# s, a #)--is /not/ the same as the Prelude function seq :: a -> b -> b-as you can see from its type.  In fact, seq# is the implementation-mechanism for 'evaluate'--   evaluate :: a -> IO a-   evaluate a = IO $ \s -> seq# a s--The semantics of seq# is-  * evaluate its first argument-  * and return it--Things to note--* Why do we need a primop at all?  That is, instead of-      case seq# x s of (# x, s #) -> blah-  why not instead say this?-      case x of { DEFAULT -> blah)--  Reason (see #5129): if we saw-    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler--  then we'd drop the 'case x' because the body of the case is bottom-  anyway. But we don't want to do that; the whole /point/ of-  seq#/evaluate is to evaluate 'x' first in the IO monad.--  In short, we /always/ evaluate the first argument and never-  just discard it.--* Why return the value?  So that we can control sharing of seq'd-  values: in-     let x = e in x `seq` ... x ...-  We don't want to inline x, so better to represent it as-       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...-  also it matches the type of rseq in the Eval monad.--Implementing seq#.  The compiler has magic for SeqOp in--- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)--- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#--- GHC.Core.Utils.exprOkForSpeculation;-  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils--- Simplify.addEvals records evaluated-ness for the result; see-  Note [Adding evaluatedness info to pattern-bound variables]-  in GHC.Core.Opt.Simplify--}--seqRule :: RuleM CoreExpr-seqRule = do+-- spark# :: forall a s . a -> State# s -> (# State# s, a #)+sparkRule :: RuleM CoreExpr+sparkRule = do -- reduce on HNF   [Type _ty_a, Type _ty_s, a, s] <- getArgs   guard $ exprIsHNF a   return $ mkCoreUnboxedTuple [s, a]---- spark# :: forall a s . a -> State# s -> (# State# s, a #)-sparkRule :: RuleM CoreExpr-sparkRule = seqRule -- reduce on HNF, just the same-  -- XXX perhaps we shouldn't do this, because a spark eliminated by-  -- this rule won't be counted as a dud at runtime?+    -- XXX perhaps we shouldn't do this, because a spark eliminated by+    -- this rule won't be counted as a dud at runtime?  {- ************************************************************************@@ -2478,6 +2613,10 @@      inline f_ty (f a b c) = <f's unfolding> a b c   (if f has an unfolding, EVEN if it's a loop breaker) +  Additionally the rule looks through ticks/casts as well (#24808):+      inline f_ty (f a b c |> co) = <f's unfolding> a b c |> co+      inline f_ty <tick> ( f a b c ) = <tick> <f's unfolding> a b c+   It's important to allow the argument to 'inline' to have args itself   (a) because its more forgiving to allow the programmer to write       either  inline f a b c@@ -2490,18 +2629,31 @@ -}  match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_inline (Type _ : e : _)-  | (Var f, args1) <- collectArgs e,-    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)-             -- Ignore the IdUnfoldingFun here!-  = Just (mkApps unf args1)+match_inline (Type _ : e : _) = go e+  -- Maybe Monad ahead:+  where+    go (Var f)      = -- Ignore the IdUnfoldingFun here!+                      (maybeUnfoldingTemplate (realIdUnfolding f))+    go (App f a)    = do { f' <- go f; pure $ App f' a }+    -- inline (f |> co)+    go (Cast e co)  = do { app <- go e; pure (Cast app co) }+    -- inline (<tick> f)+    go (Tick t e)   = do { app <- go e; pure (Tick t app) }+    go _            = Nothing  match_inline _ = Nothing  -------------------------------------------------------- -- 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 -- consequence we only perform local (small-step) transformations that either:@@ -2652,6 +2804,14 @@       (orFoldingRules' platform arg1 arg2 num_ops        <|> orFoldingRules' platform arg2 arg1 num_ops) +quotFoldingRules :: NumOps -> RuleM CoreExpr+quotFoldingRules num_ops = do+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe (quotFoldingRules' platform arg1 arg2 num_ops)+ addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of @@ -2914,6 +3074,11 @@     -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)     -- increase operation numbers +    -- x and (y or ... or x or ... or z) ==> x+    (x, is_or_list num_ops -> Just xs)+      | any (cheapEqExpr x) xs+      -> Just x+     _ -> Nothing     where       mkL = Lit . mkNumLiteral platform num_ops@@ -2937,11 +3102,39 @@     -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)     -- increase operation numbers +    -- x or (y and ... and x and ... and z) ==> x+    (x, is_and_list num_ops -> Just xs)+      | any (cheapEqExpr x) xs+      -> Just x+     _ -> Nothing     where       mkL = Lit . mkNumLiteral platform num_ops       or x y = BinOpApp x (fromJust (numOr num_ops)) y +quotFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+quotFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of++  -- (x / l1) / l2+  -- l1 and l2 /= 0+  -- l1*l2 doesn't overflow+  -- ==> x / (l1 * l2)+  (is_div num_ops -> Just (x, L l1), L l2)+    | l1 /= 0+    , l2 /= 0+    -- check that the result of the multiplication is in range+    , Just l <- mkNumLiteralMaybe platform num_ops (l1 * l2)+    -> Just (div x (Lit l))+      -- NB: we could directly return 0 or (-1) in case of overflow,+      -- but we would need to know+      --  (1) if we're dealing with a quot or a div operation+      --  (2) if it's an underflow or an overflow.+      -- Left as future work for now.++  _ -> Nothing+  where+    div x y = BinOpApp x (fromJust (numDiv num_ops)) y+ is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr) is_binop op e = case e of  BinOpApp x op' y | op == op' -> Just (x,y)@@ -2952,16 +3145,36 @@  App (OpVal op') x | op == op' -> Just x  _                             -> Nothing -is_add, is_sub, is_mul, is_and, is_or :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg) is_add num_ops e = is_binop (numAdd num_ops) e is_sub num_ops e = is_binop (numSub num_ops) e is_mul num_ops e = is_binop (numMul num_ops) e is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e is_or  num_ops e = numOr  num_ops >>= \op -> is_binop op e+is_div num_ops e = numDiv num_ops >>= \op -> is_binop op e  is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr) is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e +-- Return a list of operands for a given operation.+-- E.e. is_and_list (a and ... and z) => [a,...,z] for any nesting of the and+-- operation+is_list :: (CoreExpr -> Maybe (CoreArg,CoreArg)) -> CoreExpr -> Maybe [CoreArg]+is_list f e_org = case f e_org of -- do we have the operator at all?+  Just (a,b) -> Just (go [a,b])+  Nothing    -> Nothing+  where+    go = \case+      []     -> []+      (e:es) -> case f e of+        -- we can't split any more: add to the result list+        Nothing    -> e : go es+        Just (a,b) -> go (a:b:es)++is_and_list, is_or_list :: NumOps -> CoreExpr -> Maybe [CoreArg]+is_and_list ops = is_list (is_and ops)+is_or_list  ops = is_list (is_or  ops)+ -- match operation with a literal (handles commutativity) is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr) is_lit_add num_ops e = is_lit' is_add num_ops e@@ -3006,6 +3219,7 @@    { numAdd     :: !PrimOp         -- ^ Add two numbers    , numSub     :: !PrimOp         -- ^ Sub two numbers    , numMul     :: !PrimOp         -- ^ Multiply two numbers+   , numDiv     :: !(Maybe PrimOp) -- ^ Divide two numbers    , numAnd     :: !(Maybe PrimOp) -- ^ And two numbers    , numOr      :: !(Maybe PrimOp) -- ^ Or two numbers    , numNeg     :: !(Maybe PrimOp) -- ^ Negate a number@@ -3016,15 +3230,20 @@ mkNumLiteral :: Platform -> NumOps -> Integer -> Literal mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i +-- | Create a numeric literal if it is in range+mkNumLiteralMaybe :: Platform -> NumOps -> Integer -> Maybe Literal+mkNumLiteralMaybe platform ops i = mkLitNumberMaybe platform (numLitType ops) i+ int8Ops :: NumOps int8Ops = NumOps    { numAdd     = Int8AddOp    , numSub     = Int8SubOp    , numMul     = Int8MulOp-   , numLitType = LitNumInt8+   , numDiv     = Just Int8QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int8NegOp+   , numLitType = LitNumInt8    }  word8Ops :: NumOps@@ -3032,6 +3251,7 @@    { numAdd     = Word8AddOp    , numSub     = Word8SubOp    , numMul     = Word8MulOp+   , numDiv     = Just Word8QuotOp    , numAnd     = Just Word8AndOp    , numOr      = Just Word8OrOp    , numNeg     = Nothing@@ -3043,10 +3263,11 @@    { numAdd     = Int16AddOp    , numSub     = Int16SubOp    , numMul     = Int16MulOp-   , numLitType = LitNumInt16+   , numDiv     = Just Int16QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int16NegOp+   , numLitType = LitNumInt16    }  word16Ops :: NumOps@@ -3054,6 +3275,7 @@    { numAdd     = Word16AddOp    , numSub     = Word16SubOp    , numMul     = Word16MulOp+   , numDiv     = Just Word16QuotOp    , numAnd     = Just Word16AndOp    , numOr      = Just Word16OrOp    , numNeg     = Nothing@@ -3065,10 +3287,11 @@    { numAdd     = Int32AddOp    , numSub     = Int32SubOp    , numMul     = Int32MulOp-   , numLitType = LitNumInt32+   , numDiv     = Just Int32QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int32NegOp+   , numLitType = LitNumInt32    }  word32Ops :: NumOps@@ -3076,6 +3299,7 @@    { numAdd     = Word32AddOp    , numSub     = Word32SubOp    , numMul     = Word32MulOp+   , numDiv     = Just Word32QuotOp    , numAnd     = Just Word32AndOp    , numOr      = Just Word32OrOp    , numNeg     = Nothing@@ -3087,10 +3311,11 @@    { numAdd     = Int64AddOp    , numSub     = Int64SubOp    , numMul     = Int64MulOp-   , numLitType = LitNumInt64+   , numDiv     = Just Int64QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int64NegOp+   , numLitType = LitNumInt64    }  word64Ops :: NumOps@@ -3098,6 +3323,7 @@    { numAdd     = Word64AddOp    , numSub     = Word64SubOp    , numMul     = Word64MulOp+   , numDiv     = Just Word64QuotOp    , numAnd     = Just Word64AndOp    , numOr      = Just Word64OrOp    , numNeg     = Nothing@@ -3109,6 +3335,7 @@    { numAdd     = IntAddOp    , numSub     = IntSubOp    , numMul     = IntMulOp+   , numDiv     = Just IntQuotOp    , numAnd     = Just IntAndOp    , numOr      = Just IntOrOp    , numNeg     = Just IntNegOp@@ -3120,6 +3347,7 @@    { numAdd     = WordAddOp    , numSub     = WordSubOp    , numMul     = WordMulOp+   , numDiv     = Just WordQuotOp    , numAnd     = Just WordAndOp    , numOr      = Just WordOrOp    , numNeg     = Nothing@@ -3180,16 +3408,81 @@            , \v -> (App (App (Var f) type_arg) (Var v)))  -- See Note [caseRules for dataToTag]-caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x-  | Just DataToTagOp <- isPrimOpId_maybe f-  , Just (tc, _) <- tcSplitTyConApp_maybe ty-  , isAlgTyCon tc-  = Just (v, tx_con_dtt ty-           , \v -> App (App (Var f) (Type ty)) (Var v))+caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x+  | Just op <- isPrimOpId_maybe f+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case splitTyConApp_maybe ty of+      Just (tc, _) | isValidDTT2TyCon tc+        -> Just (v, tx_con_dtt tc+                , \v' -> Var f `App` Type lev `App` Type ty `App` Var v')+      _ -> pprTraceUserWarning warnMsg Nothing+  where+    warnMsg = vcat $ map text+      [ "Found dataToTag primop applied to a non-ADT type. This could"+      , "be a future bug in GHC, or it may be caused by an unsupported"+      , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#."+      , "In either case, the GHC developers would like to know about it!"+      , "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug"+      ]  caseRules _ _ = Nothing  +-- | Case rules+--+-- It's important that occurrence info are present, hence the use of In* types.+caseRules2+   :: InExpr  -- ^ Scutinee+   -> InId    -- ^ Case-binder+   -> [InAlt] -- ^ Alternatives in standard (increasing) order+   -> Maybe (InExpr, InId, [InAlt])+caseRules2 scrut bndr alts++  -- case quotRem# x y of+  --    (# q, _ #) -> body+  -- ====>+  --  case quot# x y of+  --    q -> body+  --+  -- case quotRem# x y of+  --    (# _, r #) -> body+  -- ====>+  --  case rem# x y of+  --    r -> body+  | BinOpApp x op y <- scrut+  , Just (quot,rem) <- is_any_quot_rem op+  , [Alt (DataAlt _) [q,r] body] <- alts+  , isDeadBinder bndr+  , dead_q <- isDeadBinder q+  , dead_r <- isDeadBinder r+  , dead_q || dead_r+  = if+      | dead_q    -> Just $ (BinOpApp x rem  y, r, [Alt DEFAULT [] body])+      | dead_r    -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body])+      | otherwise -> Nothing++  | otherwise+  = Nothing+++-- | If the given primop is a quotRem, return the corresponding (quot,rem).+is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp)+is_any_quot_rem = \case+  IntQuotRemOp    -> Just (IntQuotOp ,  IntRemOp)+  Int8QuotRemOp   -> Just (Int8QuotOp,  Int8RemOp)+  Int16QuotRemOp  -> Just (Int16QuotOp, Int16RemOp)+  Int32QuotRemOp  -> Just (Int32QuotOp, Int32RemOp)+  -- Int64QuotRemOp doesn't exist (yet)++  WordQuotRemOp   -> Just (WordQuotOp,   WordRemOp)+  Word8QuotRemOp  -> Just (Word8QuotOp,  Word8RemOp)+  Word16QuotRemOp -> Just (Word16QuotOp, Word16RemOp)+  Word32QuotRemOp -> Just (Word32QuotOp, Word32RemOp)+  -- Word64QuotRemOp doesn't exist (yet)++  _ -> Nothing++ tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon tx_lit_con _        _      DEFAULT    = Just DEFAULT tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)@@ -3238,9 +3531,9 @@ tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]   = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc -tx_con_dtt :: Type -> AltCon -> Maybe AltCon+tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon tx_con_dtt _  DEFAULT = Just DEFAULT-tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))+tx_con_dtt tc (LitAlt (LitNumber LitNumInt i))    | tag >= 0    , tag < n_data_cons    = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)@@ -3248,17 +3541,16 @@    = Nothing    where      tag         = fromInteger i :: ConTagZ-     tc          = tyConAppTyCon ty      n_data_cons = tyConFamilySize tc      data_cons   = tyConDataCons tc -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)+tx_con_dtt _ alt = pprPanic "caseRules/dataToTag: bad alt" (ppr alt)   {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to transform-   case tagToEnum x of+   case tagToEnum# x of      False -> e1      True  -> e2 into@@ -3266,13 +3558,13 @@      0# -> e1      1# -> e2 -This rule eliminates a lot of boilerplate. For+See #8317.   This rule eliminates a lot of boilerplate. For   if (x>y) then e2 else e1 we generate-  case tagToEnum (x ># y) of+  case tagToEnum# (x ># y) of     False -> e1     True  -> e2-and it is nice to then get rid of the tagToEnum.+and it is nice to then get rid of the tagToEnum#.  Beware (#14768): avoid the temptation to map constructor 0 to DEFAULT, in the hope of getting this@@ -3290,15 +3582,16 @@       DEFAULT -> e1       DEFAULT -> e2 -Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils-(add_default in mkCase3).+Instead, when possible, we turn one branch into DEFAULT in+GHC.Core.Opt.Simplify.Utils.mkCase2; see Note [Literal cases]+in that module.  Note [caseRules for dataToTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [dataToTag# magic].+See also Note [DataToTag overview] in GHC.Tc.Instance.Class.  We want to transform-  case dataToTag x of+  case dataToTagSmall# x of     DEFAULT -> e1     1# -> e2 into@@ -3306,14 +3599,23 @@     DEFAULT -> e1     (:) _ _ -> e2 -Note the need for some wildcard binders in-the 'cons' case.+(Note the need for some wildcard binders in the 'cons' case.) -For the time, we only apply this transformation when the type of `x` is a type-headed by a normal tycon. In particular, we do not apply this in the case of a-data family tycon, since that would require carefully applying coercion(s)-between the data family and the data family instance's representation type,-which caseRules isn't currently engineered to handle (#14680).+This transformation often enables further optimisation via+case-flattening and case-of-known-constructor and can be very+important for code using derived Eq instances.++We can apply this transformation only when we can easily get the+constructors from the type at which dataToTagSmall# is used.  And we+cannot apply this transformation at "type data"-related types without+breaking invariant I1 from Note [Type data declarations] in+GHC.Rename.Module.  That leaves exactly the types satisfying condition+DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class.++All of the above applies identically for `dataToTagLarge#`.  And+thanks to wrinkle DTW5, there is no need to worry about large-tag+arguments for `dataToTagSmall#`; those cause undefined behavior anyway.+  Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/Monad.hs view
@@ -40,7 +40,7 @@  import GHC.Prelude hiding ( read ) -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Env  import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )@@ -73,23 +73,27 @@ import Control.Monad import Control.Applicative ( Alternative(..) ) -data FloatOutSwitches = FloatOutSwitches {-  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if-                                   -- doing so will abstract over n or fewer-                                   -- value variables-                                   -- Nothing <=> float all lambdas to top level,-                                   --             regardless of how many free variables-                                   -- Just 0 is the vanilla case: float a lambda-                                   --    iff it has no free vars+data FloatOutSwitches = FloatOutSwitches+  { floatOutLambdas   :: Maybe Int  -- ^ Just n <=> float lambdas to top level, if+                                    -- doing so will abstract over n or fewer+                                    -- value variables+                                    -- Nothing <=> float all lambdas to top level,+                                    --             regardless of how many free variables+                                    -- Just 0 is the vanilla case: float a lambda+                                    --    iff it has no free vars -  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,-                                   --            even if they do not escape a lambda-  floatOutOverSatApps :: Bool,-                             -- ^ True <=> float out over-saturated applications-                             --            based on arity information.-                             -- See Note [Floating over-saturated applications]-                             -- in GHC.Core.Opt.SetLevels-  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.+  , floatOutConstants :: Bool       -- ^ True <=> float constants to top level,+                                    --            even if they do not escape a lambda++  , floatOutOverSatApps :: Bool     -- ^ True <=> float out over-saturated applications+                                    --            based on arity information.+                                    -- See Note [Floating over-saturated applications]+                                    -- in GHC.Core.Opt.SetLevels+  , floatToTopLevelOnly :: Bool     -- ^ Allow floating to the top level only.++  , floatJoinsToTop :: Bool         -- ^ Float join points to top level if possible+                                    -- See Note [Floating join point bindings]+                                    --     in GHC.Core.Opt.SetLevels   } instance Outputable FloatOutSwitches where     ppr = pprFloatOutSwitches@@ -100,6 +104,7 @@      sep $ punctuate comma $      [ text "Lam ="    <+> ppr (floatOutLambdas sw)      , text "Consts =" <+> ppr (floatOutConstants sw)+     , text "JoinsToTop =" <+> ppr (floatJoinsToTop sw)      , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])  {-
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -1,3432 +1,4073 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--************************************************************************-*                                                                      *-\section[OccurAnal]{Occurrence analysis pass}-*                                                                      *-************************************************************************--The occurrence analyser re-typechecks a core expression, returning a new-core expression with (hopefully) improved usage information.--}--module GHC.Core.Opt.OccurAnal (-    occurAnalysePgm,-    occurAnalyseExpr,-    zapLambdaBndrs, scrutBinderSwap_maybe-  ) where--import GHC.Prelude hiding ( head, init, last, tail )--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,-                          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 )--import GHC.Data.Maybe( isJust, orElse )-import GHC.Data.Graph.Directed ( SCC(..), Node(..)-                               , stronglyConnCompFromEdgedVerticesUniq-                               , stronglyConnCompFromEdgedVerticesUniqR )-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Basic-import GHC.Types.Tickish-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Var-import GHC.Types.Demand ( argOneShots, argsOneShots )--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc--import GHC.Builtin.Names( runRWKey )-import GHC.Unit.Module( Module )--import Data.List (mapAccumL, mapAccumR)-import Data.List.NonEmpty (NonEmpty (..), nonEmpty)-import qualified Data.List.NonEmpty as NE--{--************************************************************************-*                                                                      *-    occurAnalysePgm, occurAnalyseExpr-*                                                                      *-************************************************************************--Here's the externally-callable interface:--}---- | Do occurrence analysis, and discard occurrence info returned-occurAnalyseExpr :: CoreExpr -> CoreExpr-occurAnalyseExpr expr = expr'-  where-    (WithUsageDetails _ expr') = occAnal initOccEnv expr--occurAnalysePgm :: Module         -- Used only in debug output-                -> (Id -> Bool)         -- Active unfoldings-                -> (Activation -> Bool) -- Active rules-                -> [CoreRule]           -- Local rules for imported Ids-                -> CoreProgram -> CoreProgram-occurAnalysePgm this_mod active_unf active_rule imp_rules binds-  | isEmptyDetails final_usage-  = occ_anald_binds--  | otherwise   -- See Note [Glomming]-  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))-    occ_anald_glommed_binds-  where-    init_env = initOccEnv { occ_rule_act = active_rule-                          , occ_unf_act  = active_unf }--    (WithUsageDetails final_usage occ_anald_binds) = go init_env binds-    (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel-                                                    imp_rule_edges-                                                    (flattenBinds binds)-                                                    initial_uds-          -- It's crucial to re-analyse the glommed-together bindings-          -- so that we establish the right loop breakers. Otherwise-          -- we can easily create an infinite loop (#9583 is an example)-          ---          -- Also crucial to re-analyse the /original/ bindings-          -- in case the first pass accidentally discarded as dead code-          -- a binding that was actually needed (albeit before its-          -- definition site).  #17724 threw this up.--    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)-    -- The RULES declarations keep things alive!--    -- imp_rule_edges maps a top-level local binder 'f' to the-    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,-    -- where 'f' appears on the LHS-    --   e.g.  RULE foldr f = blah-    --         imp_rule_edges contains f :-> fvs(blah)-    -- We treat such RULES as extra rules for 'f'-    -- See Note [Preventing loops due to imported functions rules]-    imp_rule_edges :: ImpRuleEdges-    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv-                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $-                             exprsFreeIds args `delVarSetList` bndrs-                           | Rule { ru_act = act, ru_bndrs = bndrs-                                   , ru_args = args, ru_rhs = rhs } <- imp_rules-                                   -- Not BuiltinRules; see Note [Plugin rules]-                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]--    go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]-    go !_ []-        = WithUsageDetails initial_uds []-    go env (bind:binds)-        = WithUsageDetails final_usage (bind' ++ binds')-        where-           (WithUsageDetails bs_usage binds')   = go env binds-           (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage--{- *********************************************************************-*                                                                      *-                IMP-RULES-         Local rules for imported functions-*                                                                      *-********************************************************************* -}--type ImpRuleEdges = IdEnv [(Activation, VarSet)]-    -- Mapping from a local Id 'f' to info about its IMP-RULES,-    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS-    -- We record (a) its Activation and (b) the RHS free vars-    -- See Note [IMP-RULES: local rules for imported functions]--noImpRuleEdges :: ImpRuleEdges-noImpRuleEdges = emptyVarEnv--lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]-lookupImpRules imp_rule_edges bndr-  = case lookupVarEnv imp_rule_edges bndr of-      Nothing -> []-      Just vs -> vs--impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails--- Variable mentioned in RHS of an IMP-RULE for the bndr,--- whether active or not-impRulesScopeUsage imp_rules_info-  = foldr add emptyDetails imp_rules_info-  where-    add (_,vs) usage = addManyOccs usage vs--impRulesActiveFvs :: (Activation -> Bool) -> VarSet-                  -> [(Activation,VarSet)] -> VarSet-impRulesActiveFvs is_active bndr_set vs-  = foldr add emptyVarSet vs `intersectVarSet` bndr_set-  where-    add (act,vs) acc | is_active act = vs `unionVarSet` acc-                     | otherwise     = acc--{- Note [IMP-RULES: local rules for imported functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We quite often have-  * A /local/ rule-  * for an /imported/ function-like this:-  foo x = blah-  {-# RULE "map/foo" forall xs. map foo xs = xs #-}-We call them IMP-RULES.  They are important in practice, and occur a-lot in the libraries.--IMP-RULES are held in mg_rules of ModGuts, and passed in to-occurAnalysePgm.--Main Invariant:--* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS-  just like a RULE for f.--Note [IMP-RULES: unavoidable loops]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   f = /\a. B.g a-   RULE B.g Int = 1 + f Int-Note that-  * The RULE is for an imported function.-  * f is non-recursive-Now we-can get-   f Int --> B.g Int      Inlining f-         --> 1 + f Int    Firing RULE-and so the simplifier goes into an infinite loop. This-would not happen if the RULE was for a local function,-because we keep track of dependencies through rules.  But-that is pretty much impossible to do for imported Ids.  Suppose-f's definition had been-   f = /\a. C.h a-where (by some long and devious process), C.h eventually inlines to-B.g.  We could only spot such loops by exhaustively following-unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)-f.--We regard this potential infinite loop as a *programmer* error.-It's up the programmer not to write silly rules like-     RULE f x = f x-and the example above is just a more complicated version.--Note [Specialising imported functions] (referred to from Specialise)-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For *automatically-generated* rules, the programmer can't be-responsible for the "programmer error" in Note [IMP-RULES: unavoidable-loops].  In particular, consider specialising a recursive function-defined in another module.  If we specialise a recursive function B.g,-we get-  g_spec = .....(B.g Int).....-  RULE B.g Int = g_spec-Here, g_spec doesn't look recursive, but when the rule fires, it-becomes so.  And if B.g was mutually recursive, the loop might not be-as obvious as it is here.--To avoid this,- * When specialising a function that is a loop breaker,-   give a NOINLINE pragma to the specialised function--Note [Preventing loops due to imported functions rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-  import GHC.Base (foldr)--  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}-  filter p xs = build (\c n -> foldr (filterFB c p) n xs)-  filterFB c p = ...--  f = filter p xs--Note that filter is not a loop-breaker, so what happens is:-  f =          filter p xs-    = {inline} build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--We are in an infinite loop.--A more elaborate example (that I actually saw in practice when I went to-mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:-  {-# LANGUAGE RankNTypes #-}-  module GHCList where--  import Prelude hiding (filter)-  import GHC.Base (build)--  {-# INLINABLE filter #-}-  filter :: (a -> Bool) -> [a] -> [a]-  filter p [] = []-  filter p (x:xs) = if p x then x : filter p xs else filter p xs--  {-# NOINLINE [0] filterFB #-}-  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b-  filterFB c p x r | p x       = x `c` r-                   | otherwise = r--  {-# RULES-  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr-  (filterFB c p) n xs)-  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p-   #-}--Then (because RULES are applied inside INLINABLE unfoldings, but inlinings-are not), the unfolding given to "filter" in the interface file will be:-  filter p []     = []-  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                           else     build (\c n -> foldr (filterFB c p) n xs--Note that because this unfolding does not mention "filter", filter is not-marked as a strong loop breaker. Therefore at a use site in another module:-  filter p xs-    = {inline}-      case xs of []     -> []-                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                                  else     build (\c n -> foldr (filterFB c p) n xs)--  build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--And we are in an infinite loop again, except that this time the loop is producing an-infinitely large *term* (an unrolling of filter) and so the simplifier finally-dies with "ticks exhausted"--SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'-because it mentions 'filterFB' on the LHS.  This is the Main Invariant-in Note [IMP-RULES: local rules for imported functions].--So, during loop-breaker analysis:--- for each active RULE for a local function 'f' we add an edge between-  'f' and the local FVs of the rule RHS--- for each active RULE for an *imported* function we add dependency-  edges between the *local* FVS of the rule LHS and the *local* FVS of-  the rule RHS.--Even with this extra hack we aren't always going to get things-right. For example, it might be that the rule LHS mentions an imported-Id, and another module has a RULE that can rewrite that imported Id to-one of our local Ids.--Note [Plugin rules]-~~~~~~~~~~~~~~~~~~~-Conal Elliott (#11651) built a GHC plugin that added some-BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to-do some domain-specific transformations that could not be expressed-with an ordinary pattern-matching CoreRule.  But then we can't extract-the dependencies (in imp_rule_edges) from ru_rhs etc, because a-BuiltinRule doesn't have any of that stuff.--So we simply assume that BuiltinRules have no dependencies, and filter-them out from the imp_rule_edges comprehension.--Note [Glomming]-~~~~~~~~~~~~~~~-RULES for imported Ids can make something at the top refer to-something at the bottom:--        foo = ...(B.f @Int)...-        $sf = blah-        RULE:  B.f @Int = $sf--Applying this rule makes foo refer to $sf, although foo doesn't appear to-depend on $sf.  (And, as in Note [IMP-RULES: local rules for imported functions], the-dependency might be more indirect. For example, foo might mention C.t-rather than B.f, where C.t eventually inlines to B.f.)--NOTICE that this cannot happen for rules whose head is a-locally-defined function, because we accurately track dependencies-through RULES.  It only happens for rules whose head is an imported-function (B.f in the example above).--Solution:-  - When simplifying, bring all top level identifiers into-    scope at the start, ignoring the Rec/NonRec structure, so-    that when 'h' pops up in f's rhs, we find it in the in-scope set-    (as the simplifier generally expects). This happens in simplTopBinds.--  - In the occurrence analyser, if there are any out-of-scope-    occurrences that pop out of the top, which will happen after-    firing the rule:      f = \x -> h x-                          h = \y -> 3-    then just glom all the bindings into a single Rec, so that-    the *next* iteration of the occurrence analyser will sort-    them all out.   This part happens in occurAnalysePgm.--This is a legitimate situation where the need for glomming doesn't-point to any problems. However, when GHC is compiled with -DDEBUG, we-produce a warning addressed to the GHC developers just in case we-require glomming due to an out-of-order reference that is caused by-some earlier transformation stage misbehaving.--}--{--************************************************************************-*                                                                      *-                Bindings-*                                                                      *-************************************************************************--Note [Recursive bindings: the grand plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Loop breaking is surprisingly subtle.  First read the section 4 of-"Secrets of the GHC inliner".  This describes our basic plan.  We-avoid infinite inlinings by choosing loop breakers, and ensuring that-a loop breaker cuts each loop.--See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which-deals with a closely related source of infinite loops.--When we come across a binding group-  Rec { x1 = r1; ...; xn = rn }-we treat it like this (occAnalRecBind):--1. Note [Forming Rec groups]-   Occurrence-analyse each right hand side, and build a-   "Details" for each binding to capture the results.-   Wrap the details in a LetrecNode, ready for SCC analysis.-   All this is done by makeNode.--   The edges of this graph are the "scope edges".--2. Do SCC-analysis on these Nodes:-   - Each CyclicSCC will become a new Rec-   - Each AcyclicSCC will become a new NonRec--   The key property is that every free variable of a binding is-   accounted for by the scope edges, so that when we are done-   everything is still in scope.--3. For each AcyclicSCC, just make a NonRec binding.--4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we-   identify suitable loop-breakers to ensure that inlining terminates.-   This is done by occAnalRec.--   To do so, form the loop-breaker graph, do SCC analysis. For each-   CyclicSCC we choose a loop breaker, delete all edges to that node,-   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]-   for the details---Note [Dead code]-~~~~~~~~~~~~~~~~-Dropping dead code for a cyclic Strongly Connected Component is done-in a very simple way:--        the entire SCC is dropped if none of its binders are mentioned-        in the body; otherwise the whole thing is kept.--The key observation is that dead code elimination happens after-dependency analysis: so 'occAnalBind' processes SCCs instead of the-original term's binding groups.--Thus 'occAnalBind' does indeed drop 'f' in an example like--        letrec f = ...g...-               g = ...(...g...)...-        in-           ...g...--when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in-'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes-'AcyclicSCC f', where 'body_usage' won't contain 'f'.--Note [Forming Rec groups]-~~~~~~~~~~~~~~~~~~~~~~~~~-The key point about the "Forming Rec groups" step is that it /preserves-scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if-we start with-  Rec { f = ...h...-      ; g = ...f...-      ; h = ...f... }-we can split into SCCs-  Rec { f = ...h...-      ; h = ..f... }-  NonRec { g = ...f... }--We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g-uses f", no matter how indirectly.  We do a SCC analysis with an edge-f -> g if "f mentions g". That is, g is free in:-  a) the rhs 'ef'-  b) or the RHS of a rule for f, whether active or inactive-       Note [Rules are extra RHSs]-  c) or the LHS or a rule for f, whether active or inactive-       Note [Rule dependency info]-  d) the RHS of an /active/ local IMP-RULE-       Note [IMP-RULES: local rules for imported functions]--(b) and (c) apply regardless of the activation of the RULE, because even if-the rule is inactive its free variables must be bound.  But (d) doesn't need-to worry about this because IMP-RULES are always notionally at the bottom-of the file.--  * Note [Rules are extra RHSs]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"-    keeps the specialised "children" alive.  If the parent dies-    (because it isn't referenced any more), then the children will die-    too (unless they are already referenced directly).--    So in Example [eftInt], eftInt and eftIntFB will be put in the-    same Rec, even though their 'main' RHSs are both non-recursive.--    We must also include inactive rules, so that their free vars-    remain in scope.--  * Note [Rule dependency info]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    The VarSet in a RuleInfo is used for dependency analysis in the-    occurrence analyser.  We must track free vars in *both* lhs and rhs.-    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.-    Why both? Consider-        x = y-        RULE f x = v+4-    Then if we substitute y for x, we'd better do so in the-    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'-    as well as 'v'--  * Note [Rules are visible in their own rec group]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    We want the rules for 'f' to be visible in f's right-hand side.-    And we'd like them to be visible in other functions in f's Rec-    group.  E.g. in Note [Specialisation rules] we want f' rule-    to be visible in both f's RHS, and fs's RHS.--    This means that we must simplify the RULEs first, before looking-    at any of the definitions.  This is done by Simplify.simplRecBind,-    when it calls addLetIdInfo.--Note [Stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~-None of the above stuff about RULES applies to a stable unfolding-stored in a CoreUnfolding.  The unfolding, if any, is simplified-at the same time as the regular RHS of the function (ie *not* like-Note [Rules are visible in their own rec group]), so it should be-treated *exactly* like an extra RHS.--Or, rather, when computing loop-breaker edges,-  * If f has an INLINE pragma, and it is active, we treat the-    INLINE rhs as f's rhs-  * If it's inactive, we treat f as having no rhs-  * If it has no INLINE pragma, we look at f's actual rhs---There is a danger that we'll be sub-optimal if we see this-     f = ...f...-     [INLINE f = ..no f...]-where f is recursive, but the INLINE is not. This can just about-happen with a sufficiently odd set of rules; eg--        foo :: Int -> Int-        {-# INLINE [1] foo #-}-        foo x = x+1--        bar :: Int -> Int-        {-# INLINE [1] bar #-}-        bar x = foo x + 1--        {-# RULES "foo" [~1] forall x. foo x = bar x #-}--Here the RULE makes bar recursive; but it's INLINE pragma remains-non-recursive. It's tempting to then say that 'bar' should not be-a loop breaker, but an attempt to do so goes wrong in two ways:-   a) We may get-         $df = ...$cfoo...-         $cfoo = ...$df....-         [INLINE $cfoo = ...no-$df...]-      But we want $cfoo to depend on $df explicitly so that we-      put the bindings in the right order to inline $df in $cfoo-      and perhaps break the loop altogether.  (Maybe this-   b)---Example [eftInt]-~~~~~~~~~~~~~~~-Example (from GHC.Enum):--  eftInt :: Int# -> Int# -> [Int]-  eftInt x y = ...(non-recursive)...--  {-# INLINE [0] eftIntFB #-}-  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r-  eftIntFB c n x y = ...(non-recursive)...--  {-# RULES-  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)-  "eftIntList"  [1] eftIntFB  (:) [] = eftInt-   #-}--Note [Specialisation rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this group, which is typical of what SpecConstr builds:--   fs a = ....f (C a)....-   f  x = ....f (C a)....-   {-# RULE f (C a) = fs a #-}--So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).--But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:-  - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify-  - fs is inlined (say it's small)-  - now there's another opportunity to apply the RULE--This showed up when compiling Control.Concurrent.Chan.getChanContents.-Hence the transitive rule_fv_env stuff described in-Note [Rules and loop breakers].---------------------------------------------------------------Note [Finding join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It's the occurrence analyser's job to find bindings that we can turn into join-points, but it doesn't perform that transformation right away. Rather, it marks-the eligible bindings as part of their occurrence data, leaving it to the-simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.-The simplifier then eta-expands the RHS if needed and then updates the-occurrence sites. Dividing the work this way means that the occurrence analyser-still only takes one pass, yet one can always tell the difference between a-function call and a jump by looking at the occurrence (because the same pass-changes the 'IdDetails' and propagates the binders to their occurrence sites).--To track potential join points, we use the 'occ_tail' field of OccInfo. A value-of `AlwaysTailCalled n` indicates that every occurrence of the variable is a-tail call with `n` arguments (counting both value and type arguments). Otherwise-'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the-rest of 'OccInfo' until it goes on the binder.--Note [Join points and unfoldings/rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   let j2 y = blah-   let j x = j2 (x+x)-       {-# INLINE [2] j #-}-   in case e of { A -> j 1; B -> ...; C -> j 2 }--Before j is inlined, we'll have occurrences of j2 in-both j's RHS and in its stable unfolding.  We want to discover-j2 as a join point.  So we must do the adjustRhsUsage thing-on j's RHS.  That's why we pass mb_join_arity to calcUnfolding.--Same with rules. Suppose we have:--  let j :: Int -> Int-      j y = 2 * y-  let k :: Int -> Int -> Int-      {-# RULES "SPEC k 0" k 0 y = j y #-}-      k x y = x + 2 * y-  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }--We identify k as a join point, and we want j to be a join point too.-Without the RULE it would be, and we don't want the RULE to mess it-up.  So provided the join-point arity of k matches the args of the-rule we can allow the tail-call info from the RHS of the rule to-propagate.--* Wrinkle for Rec case. In the recursive case we don't know the-  join-point arity in advance, when calling occAnalUnfolding and-  occAnalRules.  (See makeNode.)  We don't want to pass Nothing,-  because then a recursive joinrec might lose its join-poin-hood-  when SpecConstr adds a RULE.  So we just make do with the-  *current* join-poin-hood, stored in the Id.--  In the non-recursive case things are simple: see occAnalNonRecBind--* Wrinkle for RULES.  Suppose the example was a bit different:-      let j :: Int -> Int-          j y = 2 * y-          k :: Int -> Int -> Int-          {-# RULES "SPEC k 0" k 0 = j #-}-          k x y = x + 2 * y-      in ...-  If we eta-expanded the rule all would be well, but as it stands the-  one arg of the rule don't match the join-point arity of 2.--  Conceivably we could notice that a potential join point would have-  an "undersaturated" rule and account for it. This would mean we-  could make something that's been specialised a join point, for-  instance. But local bindings are rarely specialised, and being-  overly cautious about rules only costs us anything when, for some `j`:--  * Before specialisation, `j` has non-tail calls, so it can't be a join point.-  * During specialisation, `j` gets specialised and thus acquires rules.-  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),-    and so now `j` *could* become a join point.--  This appears to be very rare in practice. TODO Perhaps we should gather-  statistics to be sure.--Note [Unfoldings and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We assume that anything in an unfolding occurs multiple times, since-unfoldings are often copied (that's the whole point!). But we still-need to track tail calls for the purpose of finding join points.----------------------------------------------------------------Note [Adjusting right-hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's a bit of a dance we need to do after analysing a lambda expression or-a right-hand side. In particular, we need to--  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot-     lambda, or a non-recursive join point; and-  b) call 'markAllNonTail' *unless* the binding is for a join point, and-     the RHS has the right arity; e.g.-        join j x y = case ... of-                       A -> j2 p-                       B -> j2 q-        in j a b-     Here we want the tail calls to j2 to be tail calls of the whole expression--Some examples, with how the free occurrences in e (assumed not to be a value-lambda) get marked:--                             inside lam    non-tail-called-  -------------------------------------------------------------  let x = e                  No            Yes-  let f = \x -> e            Yes           Yes-  let f = \x{OneShot} -> e   No            Yes-  \x -> e                    Yes           Yes-  join j x = e               No            No-  joinrec j x = e            Yes           No--There are a few other caveats; most importantly, if we're marking a binding as-'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so-that the effect cascades properly. Consequently, at the time the RHS is-analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must-return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once-join-point-hood has been decided.--Thus the overall sequence taking place in 'occAnalNonRecBind' and-'occAnalRecBind' is as follows:--  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.-  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make-     the binding a join point.-  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when-     recursive.)--(In the recursive case, this logic is spread between 'makeNode' and-'occAnalRec'.)--}---data WithUsageDetails a = WithUsageDetails !UsageDetails !a-----------------------------------------------------------------------                 occAnalBind---------------------------------------------------------------------occAnalBind :: OccEnv           -- The incoming OccEnv-            -> TopLevelFlag-            -> ImpRuleEdges-            -> CoreBind-            -> UsageDetails             -- Usage details of scope-            -> WithUsageDetails [CoreBind] -- Of the whole let(rec)--occAnalBind !env lvl top_env (NonRec binder rhs) body_usage-  = occAnalNonRecBind env lvl top_env binder rhs body_usage-occAnalBind env lvl top_env (Rec pairs) body_usage-  = occAnalRecBind env lvl top_env pairs body_usage--------------------occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr-                  -> UsageDetails -> WithUsageDetails [CoreBind]-occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage-  | isTyVar bndr      -- A type let; we don't gather usage info-  = WithUsageDetails body_usage [NonRec bndr rhs]--  | not (bndr `usedIn` body_usage)    -- It's not mentioned-  = WithUsageDetails body_usage []--  | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr rhs']-  where-    (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr-    final_bndr = tagged_bndr `setIdUnfolding` unf'-                             `setIdSpecialisation` mkRuleInfo rules'-    rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds--    -- Get the join info from the *new* decision-    -- See Note [Join points and unfoldings/rules]-    mb_join_arity = willBeJoinId_maybe tagged_bndr-    is_join_point = isJust mb_join_arity--    --------- Right hand side ----------    env1 | is_join_point    = env  -- See Note [Join point RHSs]-         | certainly_inline = env  -- See Note [Cascading inlines]-         | otherwise        = rhsCtxt env--    -- See Note [Sources of one-shot information]-    rhs_env = env1 { occ_one_shots = argOneShots dmd }-    (WithUsageDetails rhs_uds rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs--    --------- Unfolding ----------    -- See Note [Unfoldings and join points]-    unf | isId bndr = idUnfolding bndr-        | otherwise = NoUnfolding-    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf--    --------- Rules ----------    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]-    rules_w_uds  = occAnalRules rhs_env mb_join_arity bndr-    rules'       = map fstOf3 rules_w_uds-    imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)-         -- imp_rule_uds: consider-         --     h = ...-         --     g = ...-         --     RULE map g = h-         -- Then we want to ensure that h is in scope everywhere-         -- that g is (since the RULE might turn g into h), so-         -- we make g mention h.--    rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds-    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds--    -----------    occ = idOccInfo tagged_bndr-    certainly_inline -- See Note [Cascading inlines]-      = case occ of-          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }-            -> active && not_stable-          _ -> False--    dmd        = idDemandInfo bndr-    active     = isAlwaysActive (idInlineActivation bndr)-    not_stable = not (isStableUnfolding (idUnfolding bndr))--------------------occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]-               -> UsageDetails -> WithUsageDetails [CoreBind]--- For a recursive group, we---      * occ-analyse all the RHSs---      * compute strongly-connected components---      * feed those components to occAnalRec--- See Note [Recursive bindings: the grand plan]-occAnalRecBind !env lvl imp_rule_edges pairs body_usage-  = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs-  where-    sccs :: [SCC Details]-    sccs = {-# SCC "occAnalBind.scc" #-}-           stronglyConnCompFromEdgedVerticesUniq nodes--    nodes :: [LetrecNode]-    nodes = {-# SCC "occAnalBind.assoc" #-}-            map (makeNode rhs_env imp_rule_edges bndr_set) pairs--    bndrs    = map fst pairs-    bndr_set = mkVarSet bndrs-    rhs_env  = env `addInScope` bndrs---------------------------------occAnalRec :: OccEnv -> TopLevelFlag-           -> SCC Details-           -> WithUsageDetails [CoreBind]-           -> WithUsageDetails [CoreBind]--        -- The NonRec case is just like a Let (NonRec ...) above-occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs-                                  , nd_uds = rhs_uds }))-           (WithUsageDetails body_uds binds)-  | not (bndr `usedIn` body_uds)-  = WithUsageDetails body_uds binds -- See Note [Dead code]--  | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_uds' `andUDs` rhs_uds')-                     (NonRec tagged_bndr rhs : binds)-  where-    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr-    rhs_uds'      = adjustRhsUsage mb_join_arity rhs rhs_uds-    mb_join_arity = willBeJoinId_maybe tagged_bndr--        -- The Rec case is the interesting one-        -- See Note [Recursive bindings: the grand plan]-        -- See Note [Loop breaking]-occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)-  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds-  = WithUsageDetails body_uds binds     -- See Note [Dead code]--  | otherwise   -- At this point we always build a single Rec-  = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)-    WithUsageDetails final_uds (Rec pairs : binds)--  where-    bndrs      = map nd_bndr details_s-    all_simple = all nd_simple details_s--    -------------------------------    -- Make the nodes for the loop-breaker analysis-    -- See Note [Choosing loop breakers] for loop_breaker_nodes-    final_uds :: UsageDetails-    loop_breaker_nodes :: [LetrecNode]-    (WithUsageDetails final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s--    -------------------------------    weak_fvs :: VarSet-    weak_fvs = mapUnionVarSet nd_weak_fvs details_s--    ----------------------------    -- Now reconstruct the cycle-    pairs :: [(Id,CoreExpr)]-    pairs | all_simple = reOrderNodes   0 weak_fvs loop_breaker_nodes []-          | otherwise  = loopBreakNodes 0 weak_fvs loop_breaker_nodes []-          -- In the common case when all are "simple" (no rules at all)-          -- the loop_breaker_nodes will include all the scope edges-          -- so a SCC computation would yield a single CyclicSCC result;-          -- and reOrderNodes deals with exactly that case.-          -- Saves a SCC analysis in a common case---{- *********************************************************************-*                                                                      *-                Loop breaking-*                                                                      *-********************************************************************* -}--{- Note [Choosing loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does-loop-breaking on each CyclicSCC of the original program:--* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC--* loopBreakNodes: Do SCC analysis on it--* reOrderNodes: For each CyclicSCC, pick a loop breaker-    * Delete edges to that loop breaker-    * Do another SCC analysis on that reduced SCC-    * Repeat--To form the loop-breaker graph, we construct a new set of Nodes, the-"loop-breaker nodes", with the same details but different edges, the-"loop-breaker edges".  The loop-breaker nodes have both more and fewer-dependencies than the scope edges:--  More edges:-     If f calls g, and g has an active rule that mentions h then-     we add an edge from f -> h.  See Note [Rules and loop breakers].--  Fewer edges: we only include dependencies-     * only on /active/ rules,-     * on rule /RHSs/ (not LHSs)--The scope edges, by contrast, must be much more inclusive.--The nd_simple flag tracks the common case when a binding has no RULES-at all, in which case the loop-breaker edges will be identical to the-scope edges.--Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is-chosen as a loop breaker, because their RHSs don't mention each other.-And indeed both can be inlined safely.--Note [inl_fvs]-~~~~~~~~~~~~~~-Note that the loop-breaker graph includes edges for occurrences in-/both/ the RHS /and/ the stable unfolding.  Consider this, which actually-occurred when compiling BooleanFormula.hs in GHC:--  Rec { lvl1 = go-      ; lvl2[StableUnf = go] = lvl1-      ; go = ...go...lvl2... }--From the point of view of infinite inlining, we need only these edges:-   lvl1 :-> go-   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining-   go   :-> go, lvl2--But the danger is that, lacking any edge to lvl1, we'll put it at the-end thus-  Rec { lvl2[ StableUnf = go] = lvl1-      ; go[LoopBreaker] = ...go...lvl2... }-      ; lvl1[Occ=Once]  = go }--And now the Simplifer will try to use PreInlineUnconditionally on lvl1-(which occurs just once), but because it is last we won't actually-substitute in lvl2.  Sigh.--To avoid this possibility, we include edges from lvl2 to /both/ its-stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in-makeNode.  Maybe we could be more clever, but it's very much a corner-case.--Note [Weak loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~-There is a last nasty wrinkle.  Suppose we have--    Rec { f = f_rhs-          RULE f [] = g--          h = h_rhs-          g = h-          ...more... }--Remember that we simplify the RULES before any RHS (see Note-[Rules are visible in their own rec group] above).--So we must *not* postInlineUnconditionally 'g', even though-its RHS turns out to be trivial.  (I'm assuming that 'g' is-not chosen as a loop breaker.)  Why not?  Because then we-drop the binding for 'g', which leaves it out of scope in the-RULE!--Here's a somewhat different example of the same thing-    Rec { q = r-        ; r = ...p...-        ; p = p_rhs-          RULE p [] = q }-Here the RULE is "below" q, but we *still* can't postInlineUnconditionally-q, because the RULE for p is active throughout.  So the RHS of r-might rewrite to     r = ...q...-So q must remain in scope in the output program!--We "solve" this by:--    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)-    iff q is a mentioned in the RHS of any RULE (active on not)-    in the Rec group--Note the "active or not" comment; even if a RULE is inactive, we-want its RHS free vars to stay alive (#20820)!--A normal "strong" loop breaker has IAmLoopBreaker False.  So:--                                Inline  postInlineUnconditionally-strong   IAmLoopBreaker False    no      no-weak     IAmLoopBreaker True     yes     no-         other                   yes     yes--The **sole** reason for this kind of loop breaker is so that-postInlineUnconditionally does not fire.  Ugh.--Annoyingly, since we simplify the rules *first* we'll never inline-q into p's RULE.  That trivial binding for q will hang around until-we discard the rule.  Yuk.  But it's rare.--Note [Rules and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we form the loop-breaker graph (Step 4 in Note [Recursive-bindings: the grand plan]), we must be careful about RULEs.--For a start, we want a loop breaker to cut every cycle, so inactive-rules play no part; we need only consider /active/ rules.-See Note [Finding rule RHS free vars]--The second point is more subtle.  A RULE is like an equation for-'f' that is *always* inlined if it is applicable.  We do *not* disable-rules for loop-breakers.  It's up to whoever makes the rules to make-sure that the rules themselves always terminate.  See Note [Rules for-recursive functions] in GHC.Core.Opt.Simplify--Hence, if-    f's RHS (or its stable unfolding if it has one) mentions g, and-    g has a RULE that mentions h, and-    h has a RULE that mentions f--then we *must* choose f to be a loop breaker.  Example: see Note-[Specialisation rules]. So our plan is this:--   Take the free variables of f's RHS, and augment it with all the-   variables reachable by a transitive sequence RULES from those-   starting points.--That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.-Wrinkles:--* We only consider /active/ rules. See Note [Finding rule RHS free vars]--* We need only consider free vars that are also binders in this Rec-  group.  See also Note [Finding rule RHS free vars]--* We only consider variables free in the *RHS* of the rule, in-  contrast to the way we build the Rec group in the first place (Note-  [Rule dependency info])--* Why "transitive sequence of rules"?  Because active rules apply-  unconditionally, without checking loop-breaker-ness.- See Note [Loop breaker dependencies].--Note [Finding rule RHS free vars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this real example from Data Parallel Haskell-     tagZero :: Array Int -> Array Tag-     {-# INLINE [1] tagZeroes #-}-     tagZero xs = pmap (\x -> fromBool (x==0)) xs--     {-# RULES "tagZero" [~1] forall xs n.-         pmap fromBool <blah blah> = tagZero xs #-}-So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.-However, tagZero can only be inlined in phase 1 and later, while-the RULE is only active *before* phase 1.  So there's no problem.--To make this work, we look for the RHS free vars only for-*active* rules. That's the reason for the occ_rule_act field-of the OccEnv.--Note [loopBreakNodes]-~~~~~~~~~~~~~~~~~~~~~-loopBreakNodes is applied to the list of nodes for a cyclic strongly-connected component (there's guaranteed to be a cycle).  It returns-the same nodes, but-        a) in a better order,-        b) with some of the Ids having a IAmALoopBreaker pragma--The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means-that the simplifier can guarantee not to loop provided it never records an inlining-for these no-inline guys.--Furthermore, the order of the binds is such that if we neglect dependencies-on the no-inline Ids then the binds are topologically sorted.  This means-that the simplifier will generally do a good job if it works from top bottom,-recording inlinings for any Ids which aren't marked as "no-inline" as it goes.--}--type Binding = (Id,CoreExpr)---- See Note [loopBreakNodes]-loopBreakNodes :: Int-               -> VarSet        -- Binders whose dependencies may be "missing"-                                -- See Note [Weak loop breakers]-               -> [LetrecNode]-               -> [Binding]             -- Append these to the end-               -> [Binding]---- Return the bindings sorted into a plausible order, and marked with loop breakers.--- See Note [loopBreakNodes]-loopBreakNodes depth weak_fvs nodes binds-  = -- pprTrace "loopBreakNodes" (ppr nodes) $-    go (stronglyConnCompFromEdgedVerticesUniqR nodes)-  where-    go []         = binds-    go (scc:sccs) = loop_break_scc scc (go sccs)--    loop_break_scc scc binds-      = case scc of-          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds-          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds-------------------------------------reOrderNodes :: Int -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]-    -- Choose a loop breaker, mark it no-inline,-    -- and call loopBreakNodes on the rest-reOrderNodes _ _ []     _     = panic "reOrderNodes"-reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds-reOrderNodes depth weak_fvs (node : nodes) binds-  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen-    --                               , text "chosen" <+> ppr chosen_nodes ]) $-    loopBreakNodes new_depth weak_fvs unchosen $-    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)-  where-    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb-                                                 (nd_score (node_payload node))-                                                 [node] [] nodes--    approximate_lb = depth >= 2-    new_depth | approximate_lb = 0-              | otherwise      = depth+1-        -- After two iterations (d=0, d=1) give up-        -- and approximate, returning to d=0--nodeBinding :: (Id -> Id) -> LetrecNode -> Binding-nodeBinding set_id_occ (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})-  = (set_id_occ bndr, rhs)--mk_loop_breaker :: Id -> Id-mk_loop_breaker bndr-  = bndr `setIdOccInfo` occ'-  where-    occ'      = strongLoopBreaker { occ_tail = tail_info }-    tail_info = tailCallInfo (idOccInfo bndr)--mk_non_loop_breaker :: VarSet -> Id -> Id--- See Note [Weak loop breakers]-mk_non_loop_breaker weak_fvs bndr-  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'-  | otherwise                  = bndr-  where-    occ'      = weakLoopBreaker { occ_tail = tail_info }-    tail_info = tailCallInfo (idOccInfo bndr)-------------------------------------chooseLoopBreaker :: Bool             -- True <=> Too many iterations,-                                      --          so approximate-                  -> NodeScore            -- Best score so far-                  -> [LetrecNode]       -- Nodes with this score-                  -> [LetrecNode]       -- Nodes with higher scores-                  -> [LetrecNode]       -- Unprocessed nodes-                  -> ([LetrecNode], [LetrecNode])-    -- This loop looks for the bind with the lowest score-    -- to pick as the loop  breaker.  The rest accumulate in-chooseLoopBreaker _ _ loop_nodes acc []-  = (loop_nodes, acc)        -- Done--    -- If approximate_loop_breaker is True, we pick *all*-    -- nodes with lowest score, else just one-    -- See Note [Complexity of loop breaking]-chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)-  | approx_lb-  , rank sc == rank loop_sc-  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes--  | sc `betterLB` loop_sc  -- Better score so pick this new one-  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes--  | otherwise              -- Worse score so don't pick it-  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes-  where-    sc = nd_score (node_payload node)--{--Note [Complexity of loop breaking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The loop-breaking algorithm knocks out one binder at a time, and-performs a new SCC analysis on the remaining binders.  That can-behave very badly in tightly-coupled groups of bindings; in the-worst case it can be (N**2)*log N, because it does a full SCC-on N, then N-1, then N-2 and so on.--To avoid this, we switch plans after 2 (or whatever) attempts:-  Plan A: pick one binder with the lowest score, make it-          a loop breaker, and try again-  Plan B: pick *all* binders with the lowest score, make them-          all loop breakers, and try again-Since there are only a small finite number of scores, this will-terminate in a constant number of iterations, rather than O(N)-iterations.--You might thing that it's very unlikely, but RULES make it much-more likely.  Here's a real example from #1969:-  Rec { $dm = \d.\x. op d-        {-# RULES forall d. $dm Int d  = $s$dm1-                  forall d. $dm Bool d = $s$dm2 #-}--        dInt = MkD .... opInt ...-        dInt = MkD .... opBool ...-        opInt  = $dm dInt-        opBool = $dm dBool--        $s$dm1 = \x. op dInt-        $s$dm2 = \x. op dBool }-The RULES stuff means that we can't choose $dm as a loop breaker-(Note [Choosing loop breakers]), so we must choose at least (say)-opInt *and* opBool, and so on.  The number of loop breakers is-linear in the number of instance declarations.--Note [Loop breakers and INLINE/INLINABLE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Avoid choosing a function with an INLINE pramga as the loop breaker!-If such a function is mutually-recursive with a non-INLINE thing,-then the latter should be the loop-breaker.--It's vital to distinguish between INLINE and INLINABLE (the-Bool returned by hasStableCoreUnfolding_maybe).  If we start with-   Rec { {-# INLINABLE f #-}-         f x = ...f... }-and then worker/wrapper it through strictness analysis, we'll get-   Rec { {-# INLINABLE $wf #-}-         $wf p q = let x = (p,q) in ...f...--         {-# INLINE f #-}-         f x = case x of (p,q) -> $wf p q }--Now it is vital that we choose $wf as the loop breaker, so we can-inline 'f' in '$wf'.--Note [DFuns should not be loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's particularly bad to make a DFun into a loop breaker.  See-Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance--We give DFuns a higher score than ordinary CONLIKE things because-if there's a choice we want the DFun to be the non-loop breaker. Eg--rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)--      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)-      {-# DFUN #-}-      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)-    }--Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it-if we can't unravel the DFun first.--Note [Constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really really important to inline dictionaries.  Real-example (the Enum Ordering instance from GHC.Base):--     rec     f = \ x -> case d of (p,q,r) -> p x-             g = \ x -> case d of (p,q,r) -> q x-             d = (v, f, g)--Here, f and g occur just once; but we can't inline them into d.-On the other hand we *could* simplify those case expressions if-we didn't stupidly choose d as the loop breaker.-But we won't because constructor args are marked "Many".-Inlining dictionaries is really essential to unravelling-the loops in static numeric dictionaries, see GHC.Float.--Note [Closure conversion]-~~~~~~~~~~~~~~~~~~~~~~~~~-We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.-The immediate motivation came from the result of a closure-conversion transformation-which generated code like this:--    data Clo a b = forall c. Clo (c -> a -> b) c--    ($:) :: Clo a b -> a -> b-    Clo f env $: x = f env x--    rec { plus = Clo plus1 ()--        ; plus1 _ n = Clo plus2 n--        ; plus2 Zero     n = n-        ; plus2 (Succ m) n = Succ (plus $: m $: n) }--If we inline 'plus' and 'plus1', everything unravels nicely.  But if-we choose 'plus1' as the loop breaker (which is entirely possible-otherwise), the loop does not unravel nicely.---@occAnalUnfolding@ deals with the question of bindings where the Id is marked-by an INLINE pragma.  For these we record that anything which occurs-in its RHS occurs many times.  This pessimistically assumes that this-inlined binder also occurs many times in its scope, but if it doesn't-we'll catch it next time round.  At worst this costs an extra simplifier pass.-ToDo: try using the occurrence info for the inline'd binder.--[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.-[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.---************************************************************************-*                                                                      *-                   Making nodes-*                                                                      *-************************************************************************--}--type LetrecNode = Node Unique Details  -- Node comes from Digraph-                                       -- The Unique key is gotten from the Id-data Details-  = ND { nd_bndr :: Id          -- Binder--       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed--       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings-                                  -- ignoring phase (ie assuming all are active)-                                  -- See Note [Forming Rec groups]--       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS-                                -- but excluding any RULES-                                -- This is the IdSet that may be used if the Id is inlined--       , nd_simple :: Bool      -- True iff this binding has no local RULES-                                -- If all nodes are simple we don't need a loop-breaker-                                -- dep-anal before reconstructing.--       , nd_weak_fvs :: IdSet    -- Variables bound in this Rec group that are free-                                 -- in the RHS of any rule (active or not) for this bndr-                                 -- See Note [Weak loop breakers]--       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free-                                        -- in the RHS of an active rule for this bndr-                                        -- See Note [Rules and loop breakers]--       , nd_score :: NodeScore-  }--instance Outputable Details where-   ppr nd = text "ND" <> braces-             (sep [ text "bndr =" <+> ppr (nd_bndr nd)-                  , text "uds =" <+> ppr (nd_uds nd)-                  , text "inl =" <+> ppr (nd_inl nd)-                  , text "simple =" <+> ppr (nd_simple nd)-                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)-                  , text "score =" <+> ppr (nd_score nd)-             ])---- The NodeScore is compared lexicographically;---      e.g. lower rank wins regardless of size-type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker-                 , Int     -- Size of rhs: higher => more likely to be picked as LB-                           -- Maxes out at maxExprSize; we just use it to prioritise-                           -- small functions-                 , Bool )  -- Was it a loop breaker before?-                           -- True => more likely to be picked-                           -- Note [Loop breakers, node scoring, and stability]--rank :: NodeScore -> Int-rank (r, _, _) = r--makeNode :: OccEnv -> ImpRuleEdges -> VarSet-         -> (Var, CoreExpr) -> LetrecNode--- See Note [Recursive bindings: the grand plan]-makeNode !env imp_rule_edges bndr_set (bndr, rhs)-  = DigraphNode { node_payload      = details-                , node_key          = varUnique bndr-                , node_dependencies = nonDetKeysUniqSet scope_fvs }-    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR-    -- is still deterministic with edges in nondeterministic order as-    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.-  where-    details = ND { nd_bndr            = bndr'-                 , nd_rhs             = rhs'-                 , nd_uds             = scope_uds-                 , nd_inl             = inl_fvs-                 , nd_simple          = null rules_w_uds && null imp_rule_info-                 , nd_weak_fvs        = weak_fvs-                 , nd_active_rule_fvs = active_rule_fvs-                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }--    bndr' = bndr `setIdUnfolding`      unf'-                 `setIdSpecialisation` mkRuleInfo rules'--    inl_uds = rhs_uds `andUDs` unf_uds-    scope_uds = inl_uds `andUDs` rule_uds-                   -- Note [Rules are extra RHSs]-                   -- Note [Rule dependency info]-    scope_fvs = udFreeVars bndr_set scope_uds-    -- scope_fvs: all occurrences from this binder: RHS, unfolding,-    --            and RULES, both LHS and RHS thereof, active or inactive--    inl_fvs  = udFreeVars bndr_set inl_uds-    -- inl_fvs: vars that would become free if the function was inlined.-    -- We conservatively approximate that by thefree vars from the RHS-    -- and the unfolding together.-    -- See Note [inl_fvs]--    mb_join_arity = isJoinId_maybe bndr-    -- Get join point info from the *current* decision-    -- We don't know what the new decision will be!-    -- Using the old decision at least allows us to-    -- preserve existing join point, even RULEs are added-    -- See Note [Join points and unfoldings/rules]--    --------- Right hand side ----------    -- Constructing the edges for the main Rec computation-    -- See Note [Forming Rec groups]-    -- Do not use occAnalRhs because we don't yet know the final-    -- answer for mb_join_arity; instead, do the occAnalLam call from-    -- occAnalRhs, and postpone adjustRhsUsage until occAnalRec-    rhs_env                         = rhsCtxt env-    (WithUsageDetails rhs_uds rhs') = occAnalLam rhs_env rhs--    --------- Unfolding ----------    -- See Note [Unfoldings and join points]-    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness-                               -- here because that is what we are setting!-    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf--    --------- IMP-RULES ---------    is_active     = occ_rule_act env :: Activation -> Bool-    imp_rule_info = lookupImpRules imp_rule_edges bndr-    imp_rule_uds  = impRulesScopeUsage imp_rule_info-    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info--    --------- All rules ---------    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]-    rules_w_uds = occAnalRules rhs_env mb_join_arity bndr-    rules'      = map fstOf3 rules_w_uds--    rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds-    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds--    -------- active_rule_fvs -------------    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds-    add_active_rule (rule, _, rhs_uds) fvs-      | is_active (ruleActivation rule)-      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs-      | otherwise-      = fvs--    -------- weak_fvs -------------    -- See Note [Weak loop breakers]-    weak_fvs = foldr add_rule emptyVarSet rules_w_uds-    add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs--mkLoopBreakerNodes :: OccEnv -> TopLevelFlag-                   -> UsageDetails   -- for BODY of let-                   -> [Details]-                   -> WithUsageDetails [LetrecNode] -- adjusted--- See Note [Choosing loop breakers]--- This function primarily creates the Nodes for the--- loop-breaker SCC analysis.  More specifically:---   a) tag each binder with its occurrence info---   b) add a NodeScore to each node---   c) make a Node with the right dependency edges for---      the loop-breaker SCC analysis---   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-  = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')-  where-    (final_uds, bndrs') = tagRecBinders lvl body_uds details_s--    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr-      = DigraphNode { node_payload      = new_nd-                    , node_key          = varUnique old_bndr-                    , node_dependencies = nonDetKeysUniqSet lb_deps }-              -- It's OK to use nonDetKeysUniqSet here as-              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges-              -- in nondeterministic order as explained in-              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-      where-        new_nd = nd { nd_bndr = new_bndr, nd_score = score }-        score  = nodeScore env new_bndr lb_deps nd-        lb_deps = extendFvs_ rule_fv_env inl_fvs-        -- See Note [Loop breaker dependencies]--    rule_fv_env :: IdEnv IdSet-    -- Maps a variable f to the variables from this group-    --      reachable by a sequence of RULES starting with f-    -- Domain is *subset* of bound vars (others have no rule fvs)-    -- See Note [Finding rule RHS free vars]-    -- Why transClosureFV?  See Note [Loop breaker dependencies]-    rule_fv_env = transClosureFV $ mkVarEnv $-                  [ (b, rule_fvs)-                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s-                  , not (isEmptyVarSet rule_fvs) ]--{- Note [Loop breaker dependencies]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The loop breaker dependencies of x in a recursive-group { f1 = e1; ...; fn = en } are:--- The "inline free variables" of f: the fi free in-  f's stable unfolding and RHS; see Note [inl_fvs]--- Any fi reachable from those inline free variables by a sequence-  of RULE rewrites.  Remember, rule rewriting is not affected-  by fi being a loop breaker, so we have to take the transitive-  closure in case f is the only possible loop breaker in the loop.--  Hence rule_fv_env.  We need only account for /active/ rules.--}---------------------------------------------nodeScore :: OccEnv-          -> Id        -- Binder with new occ-info-          -> VarSet    -- Loop-breaker dependencies-          -> Details-          -> NodeScore-nodeScore !env new_bndr lb_deps-          (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })--  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker-  = (100, 0, False)--  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers-  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]--  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has-  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker--  | exprIsTrivial rhs-  = mk_score 10  -- Practically certain to be inlined-    -- Used to have also: && not (isExportedId bndr)-    -- But I found this sometimes cost an extra iteration when we have-    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }-    -- where df is the exported dictionary. Then df makes a really-    -- bad choice for loop breaker--  | DFunUnfolding { df_args = args } <- old_unf-    -- Never choose a DFun as a loop breaker-    -- Note [DFuns should not be loop breakers]-  = (9, length args, is_lb)--    -- Data structures are more important than INLINE pragmas-    -- so that dictionary/method recursion unravels--  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf-  = mk_score 6--  | is_con_app rhs   -- Data types help with cases:-  = mk_score 5       -- Note [Constructor applications]--  | isStableUnfolding old_unf-  , can_unfold-  = mk_score 3--  | isOneOcc (idOccInfo new_bndr)-  = mk_score 2  -- Likely to be inlined--  | can_unfold  -- The Id has some kind of unfolding-  = mk_score 1--  | otherwise-  = (0, 0, is_lb)--  where-    mk_score :: Int -> NodeScore-    mk_score rank = (rank, rhs_size, is_lb)--    -- is_lb: see Note [Loop breakers, node scoring, and stability]-    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)--    old_unf = realIdUnfolding old_bndr-    can_unfold = canUnfold old_unf-    rhs        = case old_unf of-                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }-                     | isStableSource src-                     -> unf_rhs-                   _ -> bind_rhs-       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding-    rhs_size = case old_unf of-                 CoreUnfolding { uf_guidance = guidance }-                    | UnfIfGoodArgs { ug_size = size } <- guidance-                    -> size-                 _  -> cheapExprSize rhs---        -- Checking for a constructor application-        -- Cheap and cheerful; the simplifier moves casts out of the way-        -- The lambda case is important to spot x = /\a. C (f a)-        -- which comes up when C is a dictionary constructor and-        -- f is a default method.-        -- Example: the instance for Show (ST s a) in GHC.ST-        ---        -- However we *also* treat (\x. C p q) as a con-app-like thing,-        --      Note [Closure conversion]-    is_con_app (Var v)    = isConLikeId v-    is_con_app (App f _)  = is_con_app f-    is_con_app (Lam _ e)  = is_con_app e-    is_con_app (Tick _ e) = is_con_app e-    is_con_app (Let _ e)  = is_con_app e  -- let x = let y = blah in (a,b)-    is_con_app _          = False         -- We will float the y out, so treat-                                          -- the x-binding as a con-app (#20941)--maxExprSize :: Int-maxExprSize = 20  -- Rather arbitrary--cheapExprSize :: CoreExpr -> Int--- Maxes out at maxExprSize-cheapExprSize e-  = go 0 e-  where-    go n e | n >= maxExprSize = n-           | otherwise        = go1 n e--    go1 n (Var {})        = n+1-    go1 n (Lit {})        = n+1-    go1 n (Type {})       = n-    go1 n (Coercion {})   = n-    go1 n (Tick _ e)      = go1 n e-    go1 n (Cast e _)      = go1 n e-    go1 n (App f a)       = go (go1 n f) a-    go1 n (Lam b e)-      | isTyVar b         = go1 n e-      | otherwise         = go (n+1) e-    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)-    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)--    gos n [] = n-    gos n (e:es) | n >= maxExprSize = n-                 | otherwise        = gos (go1 n e) es--betterLB :: NodeScore -> NodeScore -> Bool--- If  n1 `betterLB` n2  then choose n1 as the loop breaker-betterLB (rank1, size1, lb1) (rank2, size2, _)-  | rank1 < rank2 = True-  | rank1 > rank2 = False-  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker-  | size1 > size2 = True-  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it-  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]--{- Note [Self-recursion and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   rec { f = ...f...g...-       ; g = .....f...   }-then 'f' has to be a loop breaker anyway, so we may as well choose it-right away, so that g can inline freely.--This is really just a cheap hack. Consider-   rec { f = ...g...-       ; g = ..f..h...-      ;  h = ...f....}-Here f or g are better loop breakers than h; but we might accidentally-choose h.  Finding the minimal set of loop breakers is hard.--Note [Loop breakers, node scoring, and stability]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To choose a loop breaker, we give a NodeScore to each node in the SCC,-and pick the one with the best score (according to 'betterLB').--We need to be jolly careful (#12425, #12234) about the stability-of this choice. Suppose we have--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...f..-      False -> ..f...--In each iteration of the simplifier the occurrence analyser OccAnal-chooses a loop breaker. Suppose in iteration 1 it choose g as the loop-breaker. That means it is free to inline f.--Suppose that GHC decides to inline f in the branches of the case, but-(for some reason; eg it is not saturated) in the rhs of g. So we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...g...g.....-      False -> ..g..g....--Now suppose that, for some reason, in the next iteration the occurrence-analyser chooses f as the loop breaker, so it can freely inline g. And-again for some reason the simplifier inlines g at its calls in the case-branches, but not in the RHS of f. Then we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...(...f...f...)...(...f..f..).....-      False -> ..(...f...f...)...(..f..f...)....--You can see where this is going! Each iteration of the simplifier-doubles the number of calls to f or g. No wonder GHC is slow!--(In the particular example in comment:3 of #12425, f and g are the two-mutually recursive fmap instances for CondT and Result. They are both-marked INLINE which, oddly, is why they don't inline in each other's-RHS, because the call there is not saturated.)--The root cause is that we flip-flop on our choice of loop breaker. I-always thought it didn't matter, and indeed for any single iteration-to terminate, it doesn't matter. But when we iterate, it matters a-lot!!--So The Plan is this:-   If there is a tie, choose the node that-   was a loop breaker last time round--Hence the is_lb field of NodeScore--}--{- *********************************************************************-*                                                                      *-                  Lambda groups-*                                                                      *-********************************************************************* -}--{- Note [Occurrence analysis for lambda binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For value lambdas we do a special hack.  Consider-     (\x. \y. ...x...)-If we did nothing, x is used inside the \y, so would be marked-as dangerous to dup.  But in the common case where the abstraction-is applied to two arguments this is over-pessimistic, which delays-inlining x, which forces more simplifier iterations.--So the occurrence analyser collaborates with the simplifier to treat-a /lambda-group/ specially.   A lambda-group is a contiguous run of-lambda and casts, e.g.-    Lam x (Lam y (Cast (Lam z body) co))--* Occurrence analyser: we just mark each binder in the lambda-group-  (here: x,y,z) with its occurrence info in the *body* of the-  lambda-group.  See occAnalLam.--* Simplifier.  The simplifier is careful when partially applying-  lambda-groups. See the call to zapLambdaBndrs in-     GHC.Core.Opt.Simplify.simplExprF1-     GHC.Core.SimpleOpt.simple_app--* Why do we take care to account for intervening casts? Answer:-  currently we don't do eta-expansion and cast-swizzling in a stable-  unfolding (see Historical-note [Eta-expansion in stable unfoldings]).-  So we can get-    f = \x. ((\y. ...x...y...) |> co)-  Now, since the lambdas aren't together, the occurrence analyser will-  say that x is OnceInLam.  Now if we have a call-    (f e1 |> co) e2-  we'll end up with-    let x = e1 in ...x..e2...-  and it'll take an extra iteration of the Simplifier to substitute for x.--A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity-recognises except that the latter looks through (some) ticks.  Maybe a lambda-group should also look through (some) ticks?--}--isOneShotFun :: CoreExpr -> Bool--- The top level lambdas, ignoring casts, of the expression--- are all one-shot.  If there aren't any lambdas at all, this is True-isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e-isOneShotFun (Cast e _) = isOneShotFun e-isOneShotFun _          = True--zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr--- If (\xyz. t) appears under-applied to only two arguments,--- we must zap the occ-info on x,y, because they appear under the \z--- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal------ NB: `arg_count` includes both type and value args-zapLambdaBndrs fun arg_count-  = -- If the lambda is fully applied, leave it alone; if not-    -- zap the OccInfo on the lambdas that do have arguments,-    -- so they beta-reduce to use-many Lets rather than used-once ones.-    zap arg_count fun `orElse` fun-  where-    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr-    -- Nothing => No need to change the occ-info-    -- Just e  => Had to change-    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot-            | otherwise      = Just e   -- in which case no need to zap-    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }-    zap n (Lam b e)   = do { e' <- zap (n-1) e-                           ; return (Lam (zap_bndr b) e') }-    zap _ _           = Nothing  -- More arguments than lambdas--    zap_bndr b | isTyVar b = b-               | otherwise = zapLamIdInfo b--occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)--- See Note [Occurrence analysis for lambda binders]--- It does the following:---   * Sets one-shot info on the lambda binder from the OccEnv, and---     removes that one-shot info from the OccEnv---   * Sets the OccEnv to OccVanilla when going under a value lambda---   * Tags each lambda with its occurrence information---   * Walks through casts--- This function does /not/ do---   markAllInsideLam or---   markAllNonTail--- The caller does that, either in occAnal (Lam {}), or in adjustRhsUsage--- See Note [Adjusting right-hand sides]--occAnalLam env (Lam bndr expr)-  | isTyVar bndr-  = let env1 = addOneInScope env bndr-        WithUsageDetails usage expr' = occAnalLam env1 expr-    in WithUsageDetails usage (Lam bndr expr')-       -- Important: Keep the 'env' unchanged so that with a RHS like-       --   \(@ x) -> K @x (f @x)-       -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain-       -- from inlining f. See the beginning of Note [Cascading inlines].--  | otherwise  -- So 'bndr' is an Id-  = let (env_one_shots', bndr1)-           = case occ_one_shots env of-               []         -> ([],  bndr)-               (os : oss) -> (oss, updOneShotInfo bndr os)-               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing-               -- one-shot info might be better than what we can infer, e.g.-               -- due to explicit use of the magic 'oneShot' function.-               -- See Note [The oneShot function]--        env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }-        env2 = addOneInScope env1 bndr-        (WithUsageDetails usage expr') = occAnalLam env2 expr-        (usage', bndr2) = tagLamBinder usage bndr1-    in WithUsageDetails usage' (Lam bndr2 expr')---- For casts, keep going in the same lambda-group--- See Note [Occurrence analysis for lambda binders]-occAnalLam env (Cast expr co)-  = let  (WithUsageDetails usage expr') = occAnalLam env expr-         -- usage1: see Note [Gather occurrences of coercion variables]-         usage1 = addManyOccs usage (coVarsOfCo co)--         -- usage2: see Note [Occ-anal and cast worker/wrapper]-         usage2 = case expr of-                    Var {} | isRhsEnv env -> markAllMany usage1-                    _ -> usage1--         -- usage3: you might think this was not necessary, because of-         -- the markAllNonTail in adjustRhsUsage; but not so!  For a-         -- join point, adjustRhsUsage doesn't do this; yet if there is-         -- a cast, we must!  Also: why markAllNonTail?  See-         -- GHC.Core.Lint: Note Note [Join points and casts]-         usage3 = markAllNonTail usage2--    in WithUsageDetails usage3 (Cast expr' co)--occAnalLam env expr = occAnal env expr--{- Note [Occ-anal and cast worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   y = e; x = y |> co-If we mark y as used-once, we'll inline y into x, and the Cast-worker/wrapper transform will float it straight back out again.  See-Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.--So in this particular case we want to mark 'y' as Many.  It's very-ad-hoc, but it's also simple.  It's also what would happen if we gave-the binding for x a stable unfolding (as we usually do for wrappers, thus-      y = e-      {-# INLINE x #-}-      x = y |> co-Now y appears twice -- once in x's stable unfolding, and once in x's-RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable-unfolding, which would obviate this Note; but that seems a bit of a-heavyweight solution.)--We only need to this in occAnalLam, not occAnal, because the top leve-of a right hand side is handled by occAnalLam.--}---{- *********************************************************************-*                                                                      *-                   Right hand sides-*                                                                      *-********************************************************************* -}--occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity-           -> CoreExpr   -- RHS-           -> WithUsageDetails CoreExpr-occAnalRhs !env is_rec mb_join_arity rhs-  = let (WithUsageDetails usage rhs1) = occAnalLam env rhs-           -- We call occAnalLam here, not occAnalExpr, so that it doesn't-           -- do the markAllInsideLam and markNonTailCall stuff before-           -- we've had a chance to help with join points; that comes next-        rhs2      = markJoinOneShots is_rec mb_join_arity rhs1-        rhs_usage = adjustRhsUsage mb_join_arity rhs2 usage-    in WithUsageDetails rhs_usage rhs2----markJoinOneShots :: RecFlag -> Maybe JoinArity -> CoreExpr -> CoreExpr--- For a /non-recursive/ join point we can mark all--- its join-lambda as one-shot; and it's a good idea to do so-markJoinOneShots NonRecursive (Just join_arity) rhs-  = go join_arity rhs-  where-    go 0 rhs         = rhs-    go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)-                           (go (n-1) rhs)-    go _ rhs         = rhs  -- Not enough lambdas.  This can legitimately happen.-                            -- e.g.    let j = case ... in j True-                            -- This will become an arity-1 join point after the-                            -- simplifier has eta-expanded it; but it may not have-                            -- enough lambdas /yet/. (Lint checks that JoinIds do-                            -- have enough lambdas.)-markJoinOneShots _ _ rhs-  = rhs--occAnalUnfolding :: OccEnv-                 -> RecFlag-                 -> Maybe JoinArity   -- See Note [Join points and unfoldings/rules]-                 -> Unfolding-                 -> WithUsageDetails Unfolding--- Occurrence-analyse a stable unfolding;--- discard a non-stable one altogether.-occAnalUnfolding !env is_rec mb_join_arity unf-  = case unf of-      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })-        | isStableSource src ->-            let-              (WithUsageDetails usage rhs') = occAnalRhs env is_rec mb_join_arity rhs--              unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]-                   | otherwise         = unf { uf_tmpl = rhs' }-            in WithUsageDetails (markAllMany usage) unf'-              -- markAllMany: see Note [Occurrences in stable unfoldings]-        | otherwise          -> WithUsageDetails emptyDetails unf-              -- For non-Stable unfoldings we leave them undisturbed, but-              -- don't count their usage because the simplifier will discard them.-              -- We leave them undisturbed because nodeScore uses their size info-              -- to guide its decisions.  It's ok to leave un-substituted-              -- expressions in the tree because all the variables that were in-              -- scope remain in scope; there is no cloning etc.--      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-        -> WithUsageDetails final_usage (unf { df_args = args' })-        where-          env'            = env `addInScope` bndrs-          (WithUsageDetails usage args') = occAnalList env' args-          final_usage     = markAllManyNonTail (delDetailsList usage bndrs)-                            `addLamCoVarOccs` bndrs-                            `delDetailsList` bndrs-              -- delDetailsList; no need to use tagLamBinders because we-              -- never inline DFuns so the occ-info on binders doesn't matter--      unf -> WithUsageDetails emptyDetails unf--occAnalRules :: OccEnv-             -> Maybe JoinArity  -- See Note [Join points and unfoldings/rules]-             -> Id               -- Get rules from here-             -> [(CoreRule,      -- Each (non-built-in) rule-                  UsageDetails,  -- Usage details for LHS-                  UsageDetails)] -- Usage details for RHS-occAnalRules !env mb_join_arity bndr-  = map occ_anal_rule (idCoreRules bndr)-  where-    occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })-      = (rule', lhs_uds', rhs_uds')-      where-        env' = env `addInScope` bndrs-        rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]-              | otherwise         = rule { ru_args = args', ru_rhs = rhs' }--        (WithUsageDetails lhs_uds args') = occAnalList env' args-        lhs_uds'         = markAllManyNonTail (lhs_uds `delDetailsList` bndrs)-                           `addLamCoVarOccs` bndrs--        (WithUsageDetails rhs_uds rhs') = occAnal env' rhs-                            -- Note [Rules are extra RHSs]-                            -- Note [Rule dependency info]-        rhs_uds' = markAllNonTailIf (not exact_join) $-                   markAllMany                             $-                   rhs_uds `delDetailsList` bndrs--        exact_join = exactJoin mb_join_arity args-                     -- See Note [Join points and unfoldings/rules]--    occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails)--{- Note [Join point RHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   x = e-   join j = Just x--We want to inline x into j right away, so we don't want to give-the join point a RhsCtxt (#14137).  It's not a huge deal, because-the FloatIn pass knows to float into join point RHSs; and the simplifier-does not float things out of join point RHSs.  But it's a simple, cheap-thing to do.  See #14137.--Note [Occurrences in stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    f p = BIG-    {-# INLINE g #-}-    g y = not (f y)-where this is the /only/ occurrence of 'f'.  So 'g' will get a stable-unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule-or inlining f) so that it doesn't mention 'f' any more.  Now the last-remaining call to f is in g's Stable unfolding. But, even though there-is only one syntactic occurrence of f, we do /not/ want to do-preinlineUnconditionally here!--The INLINE pragma says "inline exactly this RHS"; perhaps the-programmer wants to expose that 'not', say. If we inline f that will make-the Stable unfoldign big, and that wasn't what the programmer wanted.--Another way to think about it: if we inlined g as-is into multiple-call sites, now there's be multiple calls to f.--Bottom line: treat all occurrences in a stable unfolding as "Many".--Note [Unfoldings and rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally unfoldings and rules are already occurrence-analysed, so we-don't want to reconstruct their trees; we just want to analyse them to-find how they use their free variables.--EXCEPT if there is a binder-swap going on, in which case we do want to-produce a new tree.--So we have a fast-path that keeps the old tree if the occ_bs_env is-empty.   This just saves a bit of allocation and reconstruction; not-a big deal.--This fast path exposes a tricky cornder, though (#22761). Supose we have-    Unfolding = \x. let y = foo in x+1-which includes a dead binding for `y`. In occAnalUnfolding we occ-anal-the unfolding and produce /no/ occurrences of `foo` (since `y` is-dead).  But if we discard the occ-analysed syntax tree (which we do on-our fast path), and use the old one, we still /have/ an occurrence of-`foo` -- and that can lead to out-of-scope variables (#22761).--Solution: always keep occ-analysed trees in unfoldings and rules, so they-have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.--Note [Cascading inlines]-~~~~~~~~~~~~~~~~~~~~~~~~-By default we use an rhsCtxt for the RHS of a binding.  This tells the-occ anal n that it's looking at an RHS, which has an effect in-occAnalApp.  In particular, for constructor applications, it makes-the arguments appear to have NoOccInfo, so that we don't inline into-them. Thus    x = f y-              k = Just x-we do not want to inline x.--But there's a problem.  Consider-     x1 = a0 : []-     x2 = a1 : x1-     x3 = a2 : x2-     g  = f x3-First time round, it looks as if x1 and x2 occur as an arg of a-let-bound constructor ==> give them a many-occurrence.-But then x3 is inlined (unconditionally as it happens) and-next time round, x2 will be, and the next time round x1 will be-Result: multiple simplifier iterations.  Sigh.--So, when analysing the RHS of x3 we notice that x3 will itself-definitely inline the next time round, and so we analyse x3's rhs in-an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.--Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.-If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and-   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"-then the simplifier iterates indefinitely:-        x = f y-        k = Just x   -- We decide that k is 'certainly_inline'-        v = ...k...  -- but preInlineUnconditionally doesn't inline it-inline ==>-        k = Just (f y)-        v = ...k...-float ==>-        x1 = f y-        k = Just x1-        v = ...k...--This is worse than the slow cascade, so we only want to say "certainly_inline"-if it really is certain.  Look at the note with preInlineUnconditionally-for the various clauses.---************************************************************************-*                                                                      *-                Expressions-*                                                                      *-************************************************************************--}--occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]-occAnalList !_   []    = WithUsageDetails emptyDetails []-occAnalList env (e:es) = let-                          (WithUsageDetails uds1 e') = occAnal env e-                          (WithUsageDetails uds2 es') = occAnalList env es-                         in WithUsageDetails (uds1 `andUDs` uds2) (e' : es')--occAnal :: OccEnv-        -> CoreExpr-        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids--occAnal !_   expr@(Lit _)  = WithUsageDetails emptyDetails expr--occAnal env expr@(Var _) = occAnalApp env (expr, [], [])-    -- At one stage, I gathered the idRuleVars for the variable here too,-    -- which in a way is the right thing to do.-    -- But that went wrong right after specialisation, when-    -- the *occurrences* of the overloaded function didn't have any-    -- rules in them, so the *specialised* versions looked as if they-    -- weren't used at all.--occAnal _ expr@(Type ty)-  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfType ty)) expr-occAnal _ expr@(Coercion co)-  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfCo co)) expr-        -- See Note [Gather occurrences of coercion variables]--{- Note [Gather occurrences of coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to gather info about what coercion variables appear, for two reasons:--1. So that we can sort them into the right place when doing dependency analysis.--2. So that we know when they are surely dead.--It is useful to know when they a coercion variable is surely dead,-when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.-For example (#20143):--  case unsafeEqualityProof @blah of-     UnsafeRefl cv -> ...no use of cv...--Here we can discard the case, since unsafeEqualityProof always terminates.-But only if the coercion variable 'cv' is unused.--Another example from #15696: we had something like-  case eq_sel d of co -> ...(typeError @(...co...) "urk")...-Then 'd' was substituted by a dictionary, so the expression-simpified to-  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...--We can only  drop the case altogether if 'cv' is unused, which is not-the case here.--Conclusion: we need accurate dead-ness info for CoVars.-We gather CoVar occurrences from:--  * The (Type ty) and (Coercion co) cases of occAnal--  * The type 'ty' of a lambda-binder (\(x:ty). blah)-    See addLamCoVarOccs--But it is not necessary to gather CoVars from the types of other binders.--* For let-binders, if the type mentions a CoVar, so will the RHS (since-  it has the same type)--* For case-alt binders, if the type mentions a CoVar, so will the scrutinee-  (since it has the same type)--}--occAnal env (Tick tickish body)-  | SourceNote{} <- tickish-  = WithUsageDetails usage (Tick tickish body')-                  -- SourceNotes are best-effort; so we just proceed as usual.-                  -- If we drop a tick due to the issues described below it's-                  -- not the end of the world.--  | tickish `tickishScopesLike` SoftScope-  = WithUsageDetails (markAllNonTail usage) (Tick tickish body')--  | Breakpoint _ _ ids <- tickish-  = WithUsageDetails (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')-    -- never substitute for any of the Ids in a Breakpoint--  | otherwise-  = WithUsageDetails usage_lam (Tick tickish body')-  where-    (WithUsageDetails usage body') = occAnal env body-    -- for a non-soft tick scope, we can inline lambdas only-    usage_lam = markAllNonTail (markAllInsideLam usage)-                  -- TODO There may be ways to make ticks and join points play-                  -- nicer together, but right now there are problems:-                  --   let j x = ... in tick<t> (j 1)-                  -- Making j a join point may cause the simplifier to drop t-                  -- (if the tick is put into the continuation). So we don't-                  -- count j 1 as a tail call.-                  -- See #14242.--occAnal env (Cast expr co)-  = let  (WithUsageDetails usage expr') = occAnal env expr-         usage1 = addManyOccs usage (coVarsOfCo co)-             -- usage2: see Note [Gather occurrences of coercion variables]-         usage2 = markAllNonTail usage1-             -- usage3: calls inside expr aren't tail calls any more-    in WithUsageDetails usage2 (Cast expr' co)--occAnal env app@(App _ _)-  = occAnalApp env (collectArgsTicks tickishFloatable app)--occAnal env expr@(Lam {})-  = let (WithUsageDetails usage expr') = occAnalLam env expr-        final_usage = markAllInsideLamIf (not (isOneShotFun expr')) $-                      markAllNonTail usage-    in WithUsageDetails final_usage expr'--occAnal env (Case scrut bndr ty alts)-  = let-      (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut-      alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr-      (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts-      alts_usage  = foldr orUDs emptyDetails alts_usage_s-      (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr-      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1-                    -- Alts can have tail calls, but the scrutinee can't-    in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')-  where-    do_alt !env (Alt con bndrs rhs)-      = let-          (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs-          (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs-        in                          -- See Note [Binders in case alternatives]-        (alt_usg, Alt con tagged_bndrs rhs1)--occAnal env (Let bind body)-  = let-      body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind-      (WithUsageDetails body_usage  body')  = occAnal body_env body-      (WithUsageDetails final_usage binds') = occAnalBind env NotTopLevel-                                                    noImpRuleEdges bind body_usage-    in WithUsageDetails final_usage (mkLets binds' body')--occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr--- The `fun` argument is just an accumulating parameter,--- the base for building the application we return-occAnalArgs !env fun args !one_shots-  = go emptyDetails fun args one_shots-  where-    go uds fun [] _ = WithUsageDetails uds fun-    go uds fun (arg:args) one_shots-      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'-      where-        !(WithUsageDetails arg_uds arg') = occAnal arg_env arg-        !(arg_env, one_shots')-            | isTypeArg arg = (env, one_shots)-            | otherwise     = valArgCtxt env one_shots--{--Applications are dealt with specially because we want-the "build hack" to work.--Note [Arguments of let-bound constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    f x = let y = expensive x in-          let z = (True,y) in-          (case z of {(p,q)->q}, case z of {(p,q)->q})-We feel free to duplicate the WHNF (True,y), but that means-that y may be duplicated thereby.--If we aren't careful we duplicate the (expensive x) call!-Constructors are rather like lambdas in this way.--}--occAnalApp :: OccEnv-           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])-           -> WithUsageDetails (Expr CoreBndr)--- Naked variables (not applied) end up here too-occAnalApp !env (Var fun, args, ticks)-  -- Account for join arity of runRW# continuation-  -- See Note [Simplification of runRW#]-  ---  -- NB: Do not be tempted to make the next (Var fun, args, tick)-  --     equation into an 'otherwise' clause for this equation-  --     The former has a bang-pattern to occ-anal the args, and-  --     we don't want to occ-anal them twice in the runRW# case!-  --     This caused #18296-  | fun `hasKey` runRWKey-  , [t1, t2, arg]  <- args-  , let (WithUsageDetails usage arg') = occAnalRhs env NonRecursive (Just 1) arg-  = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])--occAnalApp env (Var fun_id, args, ticks)-  = WithUsageDetails all_uds (mkTicks ticks app')-  where-    -- Lots of banged bindings: this is a very heavily bit of code,-    -- so it pays not to make lots of thunks here, all of which-    -- will ultimately be forced.-    !(fun', fun_id')  = lookupBndrSwap env fun_id-    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots--    fun_uds = mkOneOcc fun_id' int_cxt n_args-       -- NB: fun_uds is computed for fun_id', not fun_id-       -- See (BS1) in Note [The binder-swap substitution]--    all_uds = fun_uds `andUDs` final_args_uds--    !final_args_uds = markAllNonTail                              $-                      markAllInsideLamIf (isRhsEnv env && is_exp) $-                      args_uds-       -- We mark the free vars of the argument of a constructor or PAP-       -- as "inside-lambda", if it is the RHS of a let(rec).-       -- This means that nothing gets inlined into a constructor or PAP-       -- argument position, which is what we want.  Typically those-       -- constructor arguments are just variables, or trivial expressions.-       -- We use inside-lam because it's like eta-expanding the PAP.-       ---       -- This is the *whole point* of the isRhsEnv predicate-       -- See Note [Arguments of let-bound constructors]--    !n_val_args = valArgCount args-    !n_args     = length args-    !int_cxt    = case occ_encl env of-                   OccScrut -> IsInteresting-                   _other   | n_val_args > 0 -> IsInteresting-                            | otherwise      -> NotInteresting--    !is_exp     = isExpandableApp fun_id n_val_args-        -- See Note [CONLIKE pragma] in GHC.Types.Basic-        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs--    one_shots  = argsOneShots (idDmdSig fun_id) guaranteed_val_args-    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo-                                                         (occ_one_shots env))-        -- See Note [Sources of one-shot information], bullet point A']--occAnalApp env (fun, args, ticks)-  = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds))-                     (mkTicks ticks app')-  where-    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args []-    !(WithUsageDetails fun_uds fun')  = occAnal (addAppCtxt env args) fun-        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier-        -- often leaves behind beta redexs like-        --      (\x y -> e) a1 a2-        -- Here we would like to mark x,y as one-shot, and treat the whole-        -- thing much like a let.  We do this by pushing some OneShotLam items-        -- onto the context stack.--addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv-addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args-  | n_val_args > 0-  = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt-        , occ_encl      = OccVanilla }-          -- OccVanilla: the function part of the application-          -- is no longer on OccRhs or OccScrut-  | otherwise-  = env-  where-    n_val_args = valArgCount args---{--Note [Sources of one-shot information]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The occurrence analyser obtains one-shot-lambda information from two sources:--A:  Saturated applications:  eg   f e1 .. en--    In general, given a call (f e1 .. en) we can propagate one-shot info from-    f's strictness signature into e1 .. en, but /only/ if n is enough to-    saturate the strictness signature. A strictness signature like--          f :: C(1,C(1,L))LS--    means that *if f is applied to three arguments* then it will guarantee to-    call its first argument at most once, and to call the result of that at-    most once. But if f has fewer than three arguments, all bets are off; e.g.--          map (f (\x y. expensive) e2) xs--    Here the \x y abstraction may be called many times (once for each element of-    xs) so we should not mark x and y as one-shot. But if it was--          map (f (\x y. expensive) 3 2) xs--    then the first argument of f will be called at most once.--    The one-shot info, derived from f's strictness signature, is-    computed by 'argsOneShots', called in occAnalApp.--A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))-    where f is as above.--    In this case, f is only manifestly applied to one argument, so it does not-    look saturated. So by the previous point, we should not use its strictness-    signature to learn about the one-shotness of \x y. But in this case we can:-    build is fully applied, so we may use its strictness signature; and from-    that we learn that build calls its argument with two arguments *at most once*.--    So there is really only one call to f, and it will have three arguments. In-    that sense, f is saturated, and we may proceed as described above.--    Hence the computation of 'guaranteed_val_args' in occAnalApp, using-    '(occ_one_shots env)'.  See also #13227, comment:9--B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah-                        in (build f, build f)--    Propagate one-shot info from the demand-info on 'f' to the-    lambdas in its RHS (which may not be syntactically at the top)--    This information must have come from a previous run of the demand-    analyser.--Previously, the demand analyser would *also* set the one-shot information, but-that code was buggy (see #11770), so doing it only in on place, namely here, is-saner.--Note [OneShots]-~~~~~~~~~~~~~~~-When analysing an expression, the occ_one_shots argument contains information-about how the function is being used. The length of the list indicates-how many arguments will eventually be passed to the analysed expression,-and the OneShotInfo indicates whether this application is once or multiple times.--Example:-- Context of f                occ_one_shots when analysing f-- f 1 2                       [OneShot, OneShot]- map (f 1)                   [OneShot, NoOneShotInfo]- build f                     [OneShot, OneShot]- f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]--Note [Binders in case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    case x of y { (a,b) -> f y }-We treat 'a', 'b' as dead, because they don't physically occur in the-case alternative.  (Indeed, a variable is dead iff it doesn't occur in-its scope in the output of OccAnal.)  It really helps to know when-binders are unused.  See esp the call to isDeadBinder in-Simplify.mkDupableAlt--In this example, though, the Simplifier will bring 'a' and 'b' back to-life, because it binds 'y' to (a,b) (imagine got inlined and-scrutinised y).--}--{--************************************************************************-*                                                                      *-                    OccEnv-*                                                                      *-************************************************************************--}--data OccEnv-  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information-           , occ_one_shots  :: !OneShots     -- See Note [OneShots]-           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active-           , occ_rule_act   :: Activation -> Bool  -- Which rules are active-             -- See Note [Finding rule RHS free vars]--           -- See Note [The binder-swap substitution]-           -- If  x :-> (y, co)  is in the env,-           -- then please replace x by (y |> mco)-           -- Invariant of course: idType x = exprType (y |> mco)-           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))-                   -- Domain is Global and Local Ids-                   -- Range is just Local Ids-           , occ_bs_rng  :: !VarSet-                   -- Vars (TyVars and Ids) free in the range of occ_bs_env-    }----------------------------------- OccEncl is used to control whether to inline into constructor arguments--- For example:---      x = (p,q)               -- Don't inline p or q---      y = /\a -> (p a, q a)   -- Still don't inline p or q---      z = f (p,q)             -- Do inline p,q; it may make a rule fire--- So OccEncl tells enough about the context to know what to do when--- we encounter a constructor application or PAP.------ OccScrut is used to set the "interesting context" field of OncOcc--data OccEncl-  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda-                   -- Don't inline into constructor args here--  | OccScrut       -- Scrutintee of a case-                   -- Can inline into constructor args--  | OccVanilla     -- Argument of function, body of lambda, etc-                   -- Do inline into constructor args here--instance Outputable OccEncl where-  ppr OccRhs     = text "occRhs"-  ppr OccScrut   = text "occScrut"-  ppr OccVanilla = text "occVanilla"---- See Note [OneShots]-type OneShots = [OneShotInfo]--initOccEnv :: OccEnv-initOccEnv-  = OccEnv { occ_encl      = OccVanilla-           , occ_one_shots = []--                 -- To be conservative, we say that all-                 -- inlines and rules are active-           , occ_unf_act   = \_ -> True-           , occ_rule_act  = \_ -> True--           , occ_bs_env = emptyVarEnv-           , occ_bs_rng = emptyVarSet }--noBinderSwaps :: OccEnv -> Bool-noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env--scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv-scrutCtxt !env alts-  | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }-  | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }-  where-    interesting_alts = case alts of-                         []    -> False-                         [alt] -> not (isDefaultAlt alt)-                         _     -> True-     -- 'interesting_alts' is True if the case has at least one-     -- non-default alternative.  That in turn influences-     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!--rhsCtxt :: OccEnv -> OccEnv-rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] }--valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])-valArgCtxt !env []-  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])-valArgCtxt env (one_shots:one_shots_s)-  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)--isRhsEnv :: OccEnv -> Bool-isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of-                                          OccRhs -> True-                                          _      -> False--addOneInScope :: OccEnv -> CoreBndr -> OccEnv--- Needed for all Vars not just Ids--- See Note [The binder-swap substitution] (BS3)-addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr-  | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                  = env { occ_bs_env = swap_env `delVarEnv` bndr }--addInScope :: OccEnv -> [Var] -> OccEnv--- Needed for all Vars not just Ids--- See Note [The binder-swap substitution] (BS3)-addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs-  | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }------------------------transClosureFV :: VarEnv VarSet -> VarEnv VarSet--- If (f,g), (g,h) are in the input, then (f,h) is in the output---                                   as well as (f,g), (g,h)-transClosureFV env-  | no_change = env-  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)-  where-    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)-      -- It's OK to use nonDetUFMToList here because we'll forget the-      -- ordering by creating a new set with listToUFM-    bump no_change (b,fvs)-      | no_change_here = (no_change, (b,fvs))-      | otherwise      = (False,     (b,new_fvs))-      where-        (new_fvs, no_change_here) = extendFvs env fvs----------------extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet-extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag--extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)--- (extendFVs env s) returns---     (s `union` env(s), env(s) `subset` s)-extendFvs env s-  | isNullUFM env-  = (s, True)-  | otherwise-  = (s `unionVarSet` extras, extras `subVarSet` s)-  where-    extras :: VarSet    -- env(s)-    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $-      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes-             intersectUFM_C (\x _ -> x) env (getUniqSet s)--{--************************************************************************-*                                                                      *-                    Binder swap-*                                                                      *-************************************************************************--Note [Binder swap]-~~~~~~~~~~~~~~~~~~-The "binder swap" transformation swaps occurrence of the-scrutinee of a case for occurrences of the case-binder:-- (1)  case x of b { pi -> ri }-         ==>-      case x of b { pi -> ri[b/x] }-- (2)  case (x |> co) of b { pi -> ri }-        ==>-      case (x |> co) of b { pi -> ri[b |> sym co/x] }--The substitution ri[b/x] etc is done by the occurrence analyser.-See Note [The binder-swap substitution].--There are two reasons for making this swap:--(A) It reduces the number of occurrences of the scrutinee, x.-    That in turn might reduce its occurrences to one, so we-    can inline it and save an allocation.  E.g.-      let x = factorial y in case x of b { I# v -> ...x... }-    If we replace 'x' by 'b' in the alternative we get-      let x = factorial y in case x of b { I# v -> ...b... }-    and now we can inline 'x', thus-      case (factorial y) of b { I# v -> ...b... }--(B) The case-binder b has unfolding information; in the-    example above we know that b = I# v. That in turn allows-    nested cases to simplify.  Consider-       case x of b { I# v ->-       ...(case x of b2 { I# v2 -> rhs })...-    If we replace 'x' by 'b' in the alternative we get-       case x of b { I# v ->-       ...(case b of b2 { I# v2 -> rhs })...-    and now it is trivial to simplify the inner case:-       case x of b { I# v ->-       ...(let b2 = b in rhs)...--    The same can happen even if the scrutinee is a variable-    with a cast: see Note [Case of cast]--The reason for doing these transformations /here in the occurrence-analyser/ is because it allows us to adjust the OccInfo for 'x' and-'b' as we go.--  * Suppose the only occurrences of 'x' are the scrutinee and in the-    ri; then this transformation makes it occur just once, and hence-    get inlined right away.--  * If instead the Simplifier replaces occurrences of x with-    occurrences of b, that will mess up b's occurrence info. That in-    turn might have consequences.--There is a danger though.  Consider-      let v = x +# y-      in case (f v) of w -> ...v...v...-And suppose that (f v) expands to just v.  Then we'd like to-use 'w' instead of 'v' in the alternative.  But it may be too-late; we may have substituted the (cheap) x+#y for v in the-same simplifier pass that reduced (f v) to v.--I think this is just too bad.  CSE will recover some of it.--Note [The binder-swap substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The binder-swap is implemented by the occ_bs_env field of OccEnv.-There are two main pieces:--* Given    case x |> co of b { alts }-  we add [x :-> (b, sym co)] to the occ_bs_env environment; this is-  done by addBndrSwap.--* Then, at an occurrence of a variable, we look up in the occ_bs_env-  to perform the swap. This is done by lookupBndrSwap.--Some tricky corners:--(BS1) We do the substitution before gathering occurrence info. So in-      the above example, an occurrence of x turns into an occurrence-      of b, and that's what we gather in the UsageDetails.  It's as-      if the binder-swap occurred before occurrence analysis. See-      the computation of fun_uds in occAnalApp.--(BS2) When doing a lookup in occ_bs_env, we may need to iterate,-      as you can see implemented in lookupBndrSwap.  Why?-      Consider   case x of a { 1# -> e1; DEFAULT ->-                 case x of b { 2# -> e2; DEFAULT ->-                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}-      At the first case addBndrSwap will extend occ_bs_env with-          [x :-> a]-      At the second case we occ-anal the scrutinee 'x', which looks up-        'x in occ_bs_env, returning 'a', as it should.-      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding-         occ_bs_env = [x :-> a, a :-> b]-      At the third case we'll again look up 'x' which returns 'a'.-      But we don't want to stop the lookup there, else we'll end up with-                 case x of a { 1# -> e1; DEFAULT ->-                 case a of b { 2# -> e2; DEFAULT ->-                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}-      Instead, we want iterate the lookup in addBndrSwap, to give-                 case x of a { 1# -> e1; DEFAULT ->-                 case a of b { 2# -> e2; DEFAULT ->-                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}-      This makes a particular difference for case-merge, which works-      only if the scrutinee is the case-binder of the immediately enclosing-      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils-      See #19581 for the bug report that showed this up.--(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,-      and we encounter:-         (i) \x. blah-             Here we want to delete the x-binding from occ_bs_env--         (ii) \b. blah-              This is harder: we really want to delete all bindings that-              have 'b' free in the range.  That is a bit tiresome to implement,-              so we compromise.  We keep occ_bs_rng, which is the set of-              free vars of rng(occc_bs_env).  If a binder shadows any of these-              variables, we discard all of occ_bs_env.  Safe, if a bit-              brutal.  NB, however: the simplifer de-shadows the code, so the-              next time around this won't happen.--      These checks are implemented in addInScope.-      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)-      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we-      must not replace `x` by `...a...` under /\a. ...x..., or similarly-      under a case pattern match that binds `a`.--      An alternative would be for the occurrence analyser to do cloning as-      it goes.  In principle it could do so, but it'd make it a bit more-      complicated and there is no great benefit. The simplifer uses-      cloning to get a no-shadowing situation, the care-when-shadowing-      behaviour above isn't needed for long.--(BS4) The domain of occ_bs_env can include GlobaIds.  Eg-         case M.foo of b { alts }-      We extend occ_bs_env with [M.foo :-> b].  That's fine.--(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]--Note [Case of cast]-~~~~~~~~~~~~~~~~~~~-Consider        case (x `cast` co) of b { I# ->-                ... (case (x `cast` co) of {...}) ...-We'd like to eliminate the inner case.  That is the motivation for-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 scrutBinderSwap_maybe.-Consider this tricky example (#21229, #21470):--  class Sing (b :: Bool) where sing :: Bool-  instance Sing 'True  where sing = True-  instance Sing 'False where sing = False--  f :: forall a. Sing a => blah--  h = \ @(a :: Bool) ($dSing :: Sing a)-      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool-      case ($dSing |> the_co) of wild-        True  -> f @'True (True |> sym the_co)-        False -> f @a     dSing--Now do a binder-swap on the case-expression:--  h = \ @(a :: Bool) ($dSing :: Sing a)-      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool-      case ($dSing |> the_co) of wild-        True  -> f @'True (True |> sym the_co)-        False -> f @a     (wild |> sym the_co)--And now substitute `False` for `wild` (since wild=False in the False branch):--  h = \ @(a :: Bool) ($dSing :: Sing a)-      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool-      case ($dSing |> the_co) of wild-        True  -> f @'True (True  |> sym the_co)-        False -> f @a     (False |> sym the_co)--And now we have a problem.  The specialiser will specialise (f @a d)a (for all-vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using-Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.--The real problem is the binder-swap.  It swaps a dictionary variable $dSing-(of kind Constraint) for a term variable wild (of kind Type).  And that is-dangerous: a dictionary is a /singleton/ type whereas a general term variable is-not.  In this particular example, Bool is most certainly not a singleton type!--Conclusion:-  for a /dictionary variable/ do not perform-  the clever cast version of the binder-swap--Hence the subtle isDictId in scrutBinderSwap_maybe.--Note [Zap case binders in proxy bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-From the original-     case x of cb(dead) { p -> ...x... }-we will get-     case x of cb(live) { p -> ...cb... }--Core Lint never expects to find an *occurrence* of an Id marked-as Dead, so we must zap the OccInfo on cb before making the-binding x = cb.  See #5028.--NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier-doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.---}--addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv--- See Note [The binder-swap substitution]-addBndrSwap scrut case_bndr-            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })-  | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut-  , scrut_var /= case_bndr-      -- Consider: case x of x { ... }-      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop-  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)-        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'-                       `unionVarSet` tyCoVarsOfMCo mco }--  | otherwise-  = env-  where-    case_bndr' = zapIdOccInfo case_bndr-                 -- See Note [Zap case binders in proxy bindings]--scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion)--- If (scrutBinderSwap_maybe e = Just (v, mco), then---    v = e |> mco--- See Note [Case of cast]--- See Note [Care with binder-swap on dictionaries]------ We use this same function in SpecConstr, and Simplify.Iteration,--- when something binder-swap-like is happening-scrutBinderSwap_maybe (Var v)    = Just (v, MRefl)-scrutBinderSwap_maybe (Cast (Var v) co)-  | not (isDictId v)             = Just (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.-scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e  -- Drop ticks-scrutBinderSwap_maybe _          = Nothing--lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)--- See Note [The binder-swap substitution]--- Returns an expression of the same type as Id-lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr-  = case lookupVarEnv bs_env bndr of {-       Nothing           -> (Var bndr, bndr) ;-       Just (bndr1, mco) ->--    -- Why do we iterate here?-    -- See (BS2) in Note [The binder-swap substitution]-    case lookupBndrSwap env bndr1 of-      (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }---{- Historical note [Proxy let-bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to do the binder-swap transformation by introducing-a proxy let-binding, thus;--   case x of b { pi -> ri }-      ==>-   case x of b { pi -> let x = b in ri }--But that had two problems:--1. If 'x' is an imported GlobalId, we'd end up with a GlobalId-   on the LHS of a let-binding which isn't allowed.  We worked-   around this for a while by "localising" x, but it turned-   out to be very painful #16296,--2. In CorePrep we use the occurrence analyser to do dead-code-   elimination (see Note [Dead code in CorePrep]).  But that-   occasionally led to an unlifted let-binding-       case x of b { DEFAULT -> let x::Int# = b in ... }-   which disobeys one of CorePrep's output invariants (no unlifted-   let-bindings) -- see #5433.--Doing a substitution (via occ_bs_env) is much better.--Historical Note [no-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We *used* to suppress the binder-swap in case expressions when--fno-case-of-case is on.  Old remarks:-    "This happens in the first simplifier pass,-    and enhances full laziness.  Here's the bad case:-            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )-    If we eliminate the inner case, we trap it inside the I# v -> arm,-    which might prevent some full laziness happening.  I've seen this-    in action in spectral/cichelli/Prog.hs:-             [(m,n) | m <- [1..max], n <- [1..max]]-    Hence the check for NoCaseOfCase."-However, now the full-laziness pass itself reverses the binder-swap, so this-check is no longer necessary.--Historical Note [Suppressing the case binder-swap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This old note describes a problem that is also fixed by doing the-binder-swap in OccAnal:--    There is another situation when it might make sense to suppress the-    case-expression binde-swap. If we have--        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    We'll perform the binder-swap for the outer case, giving--        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    But there is no point in doing it for the inner case, because w1 can't-    be inlined anyway.  Furthermore, doing the case-swapping involves-    zapping w2's occurrence info (see paragraphs that follow), and that-    forces us to bind w2 when doing case merging.  So we get--        case x of w1 { A -> let w2 = w1 in e1-                       B -> let w2 = w1 in e2-                       ...other cases .... }--    This is plain silly in the common case where w2 is dead.--    Even so, I can't see a good way to implement this idea.  I tried-    not doing the binder-swap if the scrutinee was already evaluated-    but that failed big-time:--            data T = MkT !Int--            case v of w  { MkT x ->-            case x of x1 { I# y1 ->-            case x of x2 { I# y2 -> ...--    Notice that because MkT is strict, x is marked "evaluated".  But to-    eliminate the last case, we must either make sure that x (as well as-    x1) has unfolding MkT y1.  The straightforward thing to do is to do-    the binder-swap.  So this whole note is a no-op.--It's fixed by doing the binder-swap in OccAnal because we can do the-binder-swap unconditionally and still get occurrence analysis-information right.---************************************************************************-*                                                                      *-\subsection[OccurAnal-types]{OccEnv}-*                                                                      *-************************************************************************--Note [UsageDetails and zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On many occasions, we must modify all gathered occurrence data at once. For-instance, all occurrences underneath a (non-one-shot) lambda set the-'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but-that takes O(n) time and we will do this often---in particular, there are many-places where tail calls are not allowed, and each of these causes all variables-to get marked with 'NoTailCallInfo'.--Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along-with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"-recording which variables have been zapped in some way. Zapping all occurrence-info then simply means setting the corresponding zapped set to the whole-'OccInfoEnv', a fast O(1) operation.--}--type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage-                -- INVARIANT: never IAmDead-                -- (Deadness is signalled by not being in the map at all)--type ZappedSet = OccInfoEnv -- Values are ignored--data UsageDetails-  = UD { ud_env       :: !OccInfoEnv-       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these-       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these-       , ud_z_no_tail :: !ZappedSet } -- apply 'markNonTail' to these-  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv--instance Outputable UsageDetails where-  ppr ud = ppr (ud_env (flattenUsageDetails ud))------------------------ UsageDetails API--andUDs, orUDs-        :: UsageDetails -> UsageDetails -> UsageDetails-andUDs = combineUsageDetailsWith addOccInfo-orUDs  = combineUsageDetailsWith orOccInfo--mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails-mkOneOcc id int_cxt arity-  | isLocalId id-  = emptyDetails { ud_env = unitVarEnv id occ_info }-  | otherwise-  = emptyDetails-  where-    occ_info = OneOcc { occ_in_lam  = NotInsideLam-                      , occ_n_br    = oneBranch-                      , occ_int_cxt = int_cxt-                      , occ_tail    = AlwaysTailCalled arity }--addManyOccId :: UsageDetails -> Id -> UsageDetails--- Add the non-committal (id :-> noOccInfo) to the usage details-addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }---- Add several occurrences, assumed not to be tail calls-addManyOcc :: Var -> UsageDetails -> UsageDetails-addManyOcc v u | isId v    = addManyOccId u v-               | otherwise = u-        -- Give a non-committal binder info (i.e noOccInfo) because-        --   a) Many copies of the specialised thing can appear-        --   b) We don't want to substitute a BIG expression inside a RULE-        --      even if that's the only occurrence of the thing-        --      (Same goes for INLINE.)--addManyOccs :: UsageDetails -> VarSet -> UsageDetails-addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set-  -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes--addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails--- Add any CoVars free in the type of a lambda-binder--- See Note [Gather occurrences of coercion variables]-addLamCoVarOccs uds bndrs-  = uds `addManyOccs` coVarsOfTypes (map varType bndrs)--delDetails :: UsageDetails -> Id -> UsageDetails-delDetails ud bndr-  = ud `alterUsageDetails` (`delVarEnv` bndr)--delDetailsList :: UsageDetails -> [Id] -> UsageDetails-delDetailsList ud bndrs-  = ud `alterUsageDetails` (`delVarEnvList` bndrs)--emptyDetails :: UsageDetails-emptyDetails = UD { ud_env       = emptyVarEnv-                  , ud_z_many    = emptyVarEnv-                  , ud_z_in_lam  = emptyVarEnv-                  , ud_z_no_tail = emptyVarEnv }--isEmptyDetails :: UsageDetails -> Bool-isEmptyDetails = isEmptyVarEnv . ud_env--markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail-  :: UsageDetails -> UsageDetails-markAllMany          ud = ud { ud_z_many    = ud_env ud }-markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }--markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails--markAllInsideLamIf  True  ud = markAllInsideLam ud-markAllInsideLamIf  False ud = ud--markAllNonTailIf True  ud = markAllNonTail ud-markAllNonTailIf False ud = ud---markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo--lookupDetails :: UsageDetails -> Id -> OccInfo-lookupDetails ud id-  = case lookupVarEnv (ud_env ud) id of-      Just occ -> doZapping ud id occ-      Nothing  -> IAmDead--usedIn :: Id -> UsageDetails -> Bool-v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud--udFreeVars :: VarSet -> UsageDetails -> VarSet--- Find the subset of bndrs that are mentioned in uds-udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud)--restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet-restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs------------------------ Auxiliary functions for UsageDetails implementation--combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)-                        -> UsageDetails -> UsageDetails -> UsageDetails-combineUsageDetailsWith plus_occ_info ud1 ud2-  | isEmptyDetails ud1 = ud2-  | isEmptyDetails ud2 = ud1-  | otherwise-  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)-       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)-       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)-       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }--doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo-doZapping ud var occ-  = doZappingByUnique ud (varUnique var) occ--doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo-doZappingByUnique (UD { ud_z_many = many-                      , ud_z_in_lam = in_lam-                      , ud_z_no_tail = no_tail })-                  uniq occ-  = occ2-  where-    occ1 | uniq `elemVarEnvByKey` many    = markMany occ-         | uniq `elemVarEnvByKey` in_lam  = markInsideLam occ-         | otherwise                      = occ-    occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1-         | otherwise                      = occ1--alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails-alterUsageDetails !ud f-  = UD { ud_env       = f (ud_env       ud)-       , ud_z_many    = f (ud_z_many    ud)-       , ud_z_in_lam  = f (ud_z_in_lam  ud)-       , ud_z_no_tail = f (ud_z_no_tail ud) }--flattenUsageDetails :: UsageDetails -> UsageDetails-flattenUsageDetails ud@(UD { ud_env = env })-  = UD { ud_env       = mapUFM_Directly (doZappingByUnique ud) env-       , ud_z_many    = emptyVarEnv-       , ud_z_in_lam  = emptyVarEnv-       , ud_z_no_tail = emptyVarEnv }------------------------ See Note [Adjusting right-hand sides]-adjustRhsUsage :: Maybe JoinArity-               -> CoreExpr       -- Rhs, AFTER occ anal-               -> UsageDetails   -- From body of lambda-               -> UsageDetails-adjustRhsUsage mb_join_arity rhs usage-  = -- c.f. occAnal (Lam {})-    markAllInsideLamIf (not one_shot) $-    markAllNonTailIf (not exact_join) $-    usage-  where-    one_shot   = isOneShotFun rhs-    exact_join = exactJoin mb_join_arity bndrs-    (bndrs,_)  = collectBinders rhs--exactJoin :: Maybe JoinArity -> [a] -> Bool-exactJoin Nothing           _    = False-exactJoin (Just join_arity) args = args `lengthIs` join_arity-  -- Remember join_arity includes type binders--type IdWithOccInfo = Id--tagLamBinders :: UsageDetails          -- Of scope-              -> [Id]                  -- Binders-              -> (UsageDetails,        -- Details with binders removed-                 [IdWithOccInfo])    -- Tagged binders-tagLamBinders usage binders-  = usage' `seq` (usage', bndrs')-  where-    (usage', bndrs') = mapAccumR tagLamBinder usage binders--tagLamBinder :: UsageDetails       -- Of scope-             -> Id                 -- Binder-             -> (UsageDetails,     -- Details with binder removed-                 IdWithOccInfo)    -- Tagged binders--- Used for lambda and case binders--- It copes with the fact that lambda bindings can have a--- stable unfolding, used for join points-tagLamBinder usage bndr-  = (usage2, bndr')-  where-        occ    = lookupDetails usage bndr-        bndr'  = setBinderOcc (markNonTail occ) bndr-                   -- Don't try to make an argument into a join point-        usage1 = usage `delDetails` bndr-        usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)-                               -- This is effectively the RHS of a-                               -- non-join-point binding, so it's okay to use-                               -- addManyOccsSet, which assumes no tail calls-               | otherwise = usage1--tagNonRecBinder :: TopLevelFlag           -- At top level?-                -> UsageDetails           -- Of scope-                -> CoreBndr               -- Binder-                -> (UsageDetails,         -- Details with binder removed-                    IdWithOccInfo)        -- Tagged binder--tagNonRecBinder lvl usage binder- = let-     occ     = lookupDetails usage binder-     will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)-     occ'    | will_be_join = -- must already be marked AlwaysTailCalled-                              assert (isAlwaysTailCalled occ) occ-             | otherwise    = markNonTail occ-     binder' = setBinderOcc occ' binder-     usage'  = usage `delDetails` binder-   in-   usage' `seq` (usage', binder')--tagRecBinders :: TopLevelFlag           -- At top level?-              -> UsageDetails           -- Of body of let ONLY-              -> [Details]-              -> (UsageDetails,         -- Adjusted details for whole scope,-                                        -- with binders removed-                  [IdWithOccInfo])      -- Tagged binders--- Substantially more complicated than non-recursive case. Need to adjust RHS--- details *before* tagging binders (because the tags depend on the RHSes).-tagRecBinders lvl body_uds details_s- = let-     bndrs    = map nd_bndr details_s-     rhs_udss = map nd_uds  details_s--     -- 1. Determine join-point-hood of whole group, as determined by-     --    the *unadjusted* usage details-     unadj_uds     = foldr andUDs body_uds rhs_udss--     -- This is only used in `mb_join_arity`, to adjust each `Details` in `details_s`, thus,-     -- when `bndrs` is non-empty. So, we only write `maybe False` as `decideJoinPointHood`-     -- takes a `NonEmpty CoreBndr`; the default value `False` won't affect program behavior.-     will_be_joins = maybe False (decideJoinPointHood lvl unadj_uds) (nonEmpty bndrs)--     -- 2. Adjust usage details of each RHS, taking into account the-     --    join-point-hood decision-     rhs_udss' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds-                 | ND { nd_bndr = bndr, nd_uds = rhs_uds-                      , nd_rhs = rhs } <- details_s ]--     mb_join_arity :: Id -> Maybe JoinArity-     mb_join_arity bndr-         -- Can't use willBeJoinId_maybe here because we haven't tagged-         -- the binder yet (the tag depends on these adjustments!)-       | will_be_joins-       , let occ = lookupDetails unadj_uds bndr-       , AlwaysTailCalled arity <- tailCallInfo occ-       = Just arity-       | otherwise-       = assert (not will_be_joins) -- Should be AlwaysTailCalled if-         Nothing                   -- we are making join points!--     -- 3. Compute final usage details from adjusted RHS details-     adj_uds   = foldr andUDs body_uds rhs_udss'--     -- 4. Tag each binder with its adjusted details-     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr-                 | bndr <- bndrs ]--     -- 5. Drop the binders from the adjusted details and return-     usage'    = adj_uds `delDetailsList` bndrs-   in-   (usage', bndrs')--setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr-setBinderOcc occ_info bndr-  | isTyVar bndr      = bndr-  | isExportedId bndr = if isManyOccs (idOccInfo bndr)-                          then bndr-                          else setIdOccInfo bndr noOccInfo-            -- Don't use local usage info for visible-elsewhere things-            -- BUT *do* erase any IAmALoopBreaker annotation, because we're-            -- about to re-generate it and it shouldn't be "sticky"--  | otherwise = setIdOccInfo bndr occ_info---- | Decide whether some bindings should be made into join points or not.--- Returns `False` if they can't be join points. Note that it's an--- all-or-nothing decision, as if multiple binders are given, they're--- assumed to be mutually recursive.------ It must, however, be a final decision. If we say "True" for 'f',--- and then subsequently decide /not/ make 'f' into a join point, then--- the decision about another binding 'g' might be invalidated if (say)--- 'f' tail-calls 'g'.------ See Note [Invariants on join points] in "GHC.Core".-decideJoinPointHood :: TopLevelFlag -> UsageDetails-                    -> NonEmpty CoreBndr-                    -> Bool-decideJoinPointHood TopLevel _ _-  = False-decideJoinPointHood NotTopLevel usage bndrs-  | isJoinId (NE.head bndrs)-  = warnPprTrace (not all_ok)-                 "OccurAnal failed to rediscover join point(s)" (ppr bndrs)-                 all_ok-  | otherwise-  = all_ok-  where-    -- See Note [Invariants on join points]; invariants cited by number below.-    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.-    all_ok = -- Invariant 3: Either all are join points or none are-             all ok bndrs--    ok bndr-      | -- Invariant 1: Only tail calls, all same join arity-        AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)--      , -- Invariant 1 as applied to LHSes of rules-        all (ok_rule arity) (idCoreRules bndr)--        -- Invariant 2a: stable unfoldings-        -- See Note [Join points and INLINE pragmas]-      , ok_unfolding arity (realIdUnfolding bndr)--        -- Invariant 4: Satisfies polymorphism rule-      , isValidJoinPointType arity (idType bndr)-      = True--      | otherwise-      = False--    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans-    ok_rule join_arity (Rule { ru_args = args })-      = args `lengthIs` join_arity-        -- Invariant 1 as applied to LHSes of rules--    -- ok_unfolding returns False if we should /not/ convert a non-join-id-    -- into a join-id, even though it is AlwaysTailCalled-    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })-      = not (isStableSource src && join_arity > joinRhsArity rhs)-    ok_unfolding _ (DFunUnfolding {})-      = False-    ok_unfolding _ _-      = True--willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity-willBeJoinId_maybe bndr-  | isId bndr-  , AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)-  = Just arity-  | otherwise-  = isJoinId_maybe bndr---{- Note [Join points and INLINE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = let g = \x. not  -- Arity 1-             {-# INLINE g #-}-         in case x of-              A -> g True True-              B -> g True False-              C -> blah2--Here 'g' is always tail-called applied to 2 args, but the stable-unfolding captured by the INLINE pragma has arity 1.  If we try to-convert g to be a join point, its unfolding will still have arity 1-(since it is stable, and we don't meddle with stable unfoldings), and-Lint will complain (see Note [Invariants on join points], (2a), in-GHC.Core.  #13413.--Moreover, since g is going to be inlined anyway, there is no benefit-from making it a join point.--If it is recursive, and uselessly marked INLINE, this will stop us-making it a join point, which is annoying.  But occasionally-(notably in class methods; see Note [Instances and loop breakers] in-GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion-unravels; so ignoring INLINE pragmas on recursive things isn't good-either.--See Invariant 2a of Note [Invariants on join points] in GHC.Core---************************************************************************-*                                                                      *-\subsection{Operations over OccInfo}-*                                                                      *-************************************************************************--}--markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo--markMany IAmDead = IAmDead-markMany occ     = ManyOccs { occ_tail = occ_tail occ }--markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }-markInsideLam occ             = occ--markNonTail IAmDead = IAmDead-markNonTail occ     = occ { occ_tail = NoTailCallInfo }--addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo--addOccInfo a1 a2  = assert (not (isDeadOcc a1 || isDeadOcc a2)) $-                    ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                          tailCallInfo a2 }-                                -- Both branches are at least One-                                -- (Argument is never IAmDead)---- (orOccInfo orig new) is used--- when combining occurrence info from branches of a case--orOccInfo (OneOcc { occ_in_lam  = in_lam1-                  , occ_n_br    = nbr1-                  , occ_int_cxt = int_cxt1-                  , occ_tail    = tail1 })-          (OneOcc { occ_in_lam  = in_lam2-                  , occ_n_br    = nbr2-                  , occ_int_cxt = int_cxt2-                  , occ_tail    = tail2 })-  = OneOcc { occ_n_br    = nbr1 + nbr2-           , occ_in_lam  = in_lam1 `mappend` in_lam2-           , occ_int_cxt = int_cxt1 `mappend` int_cxt2-           , occ_tail    = tail1 `andTailCallInfo` tail2 }--orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $-                  ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                        tailCallInfo a2 }+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}++{-# OPTIONS_GHC -fmax-worker-args=12 #-}+-- The -fmax-worker-args=12 is there because the main functions+-- are strict in the OccEnv, and it turned out that with the default settting+-- some functions would unbox the OccEnv ad some would not, depending on how+-- many /other/ arguments the function has.  Inconsistent unboxing is very+-- bad for performance, so I increased the limit to allow it to unbox+-- consistently.++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++module GHC.Core.Opt.OccurAnal (+    occurAnalysePgm,+    occurAnalyseExpr,+    zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap+  ) where++import GHC.Prelude hiding ( head, init, last, tail )++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          mkCastMCo, mkTicks )+import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )+import GHC.Core.Coercion+import GHC.Core.Type+import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )++import GHC.Data.Maybe( orElse )+import GHC.Data.Graph.Directed ( SCC(..), Node(..)+                               , stronglyConnCompFromEdgedVerticesUniq+                               , stronglyConnCompFromEdgedVerticesUniqR )+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Demand ( argOneShots, argsOneShots, isDeadEndSig )++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Builtin.Names( runRWKey )+import GHC.Unit.Module( Module )++import Data.List (mapAccumL)+import Data.List.NonEmpty (NonEmpty (..))++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++-- | Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr :: CoreExpr -> CoreExpr+occurAnalyseExpr expr = expr'+  where+    WUD _ expr' = occAnal initOccEnv expr++occurAnalysePgm :: Module         -- Used only in debug output+                -> (Id -> Bool)         -- Active unfoldings+                -> (Activation -> Bool) -- Active rules+                -> [CoreRule]           -- Local rules for imported Ids+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_unf active_rule imp_rules binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))+    occ_anald_glommed_binds+  where+    init_env = initOccEnv { occ_rule_act = active_rule+                          , occ_unf_act  = active_unf }++    WUD final_usage occ_anald_binds = go binds init_env+    WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.++    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)+    -- The RULES declarations keep things alive!++    -- imp_rule_edges maps a top-level local binder 'f' to the+    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,+    -- where 'f' appears on the LHS+    --   e.g.  RULE foldr f = blah+    --         imp_rule_edges contains f :-> fvs(blah)+    -- We treat such RULES as extra rules for 'f'+    -- See Note [Preventing loops due to imported functions rules]+    imp_rule_edges :: ImpRuleEdges+    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv+                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $+                             exprsFreeIds args `delVarSetList` bndrs+                           | Rule { ru_act = act, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs } <- imp_rules+                                   -- Not BuiltinRules; see Note [Plugin rules]+                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]++    go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]+    go []           _   = WUD initial_uds []+    go (bind:binds) env = occAnalBind env TopLevel+                           imp_rule_edges bind (go binds) (++)++{- *********************************************************************+*                                                                      *+                IMP-RULES+         Local rules for imported functions+*                                                                      *+********************************************************************* -}++type ImpRuleEdges = IdEnv [(Activation, VarSet)]+    -- Mapping from a local Id 'f' to info about its IMP-RULES,+    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS+    -- We record (a) its Activation and (b) the RHS free vars+    -- See Note [IMP-RULES: local rules for imported functions]++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]+lookupImpRules imp_rule_edges bndr+  = case lookupVarEnv imp_rule_edges bndr of+      Nothing -> []+      Just vs -> vs++impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails+-- Variable mentioned in RHS of an IMP-RULE for the bndr,+-- whether active or not+impRulesScopeUsage imp_rules_info+  = foldr add emptyDetails imp_rules_info+  where+    add (_,vs) usage = addManyOccs usage vs++impRulesActiveFvs :: (Activation -> Bool) -> VarSet+                  -> [(Activation,VarSet)] -> VarSet+impRulesActiveFvs is_active bndr_set vs+  = foldr add emptyVarSet vs `intersectVarSet` bndr_set+  where+    add (act,vs) acc | is_active act = vs `unionVarSet` acc+                     | otherwise     = acc++{- Note [IMP-RULES: local rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We quite often have+  * A /local/ rule+  * for an /imported/ function+like this:+  foo x = blah+  {-# RULE "map/foo" forall xs. map foo xs = xs #-}+We call them IMP-RULES.  They are important in practice, and occur a+lot in the libraries.++IMP-RULES are held in mg_rules of ModGuts, and passed in to+occurAnalysePgm.++Main Invariant:++* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS+  just like a RULE for f.++Note [IMP-RULES: unavoidable loops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [IMP-RULES: unavoidable+loops].  In particular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+  g_spec = .....(B.g Int).....+  RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might not be+as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'+because it mentions 'filterFB' on the LHS.  This is the Main Invariant+in Note [IMP-RULES: local rules for imported functions].++So, during loop-breaker analysis:++- for each active RULE for a local function 'f' we add an edge between+  'f' and the local FVs of the rule RHS++- for each active RULE for an *imported* function we add dependency+  edges between the *local* FVS of the rule LHS and the *local* FVS of+  the rule RHS.++Even with this extra hack we aren't always going to get things+right. For example, it might be that the rule LHS mentions an imported+Id, and another module has a RULE that can rewrite that imported Id to+one of our local Ids.++Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~+Conal Elliott (#11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to+something at the bottom:++        foo = ...(B.f @Int)...+        $sf = blah+        RULE:  B.f @Int = $sf++Applying this rule makes foo refer to $sf, although foo doesn't appear to+depend on $sf.  (And, as in Note [IMP-RULES: local rules for imported functions], the+dependency might be more indirect. For example, foo might mention C.t+rather than B.f, where C.t eventually inlines to B.f.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.f in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.++This is a legitimate situation where the need for glomming doesn't+point to any problems. However, when GHC is compiled with -DDEBUG, we+produce a warning addressed to the GHC developers just in case we+require glomming due to an out-of-order reference that is caused by+some earlier transformation stage misbehaving.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.  We+avoid infinite inlinings by choosing loop breakers, and ensuring that+a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which+deals with a closely related source of infinite loops.++When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Note [Forming Rec groups]+   Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.+   Wrap the details in a LetrecNode, ready for SCC analysis.+   All this is done by makeNode.++   The edges of this graph are the "scope edges".++2. Do SCC-analysis on these Nodes:+   - Each CyclicSCC will become a new Rec+   - Each AcyclicSCC will become a new NonRec++   The key property is that every free variable of a binding is+   accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each AcyclicSCC, just make a NonRec binding.++4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++   To do so, form the loop-breaker graph, do SCC analysis. For each+   CyclicSCC we choose a loop breaker, delete all edges to that node,+   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]+   for the details+++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+The key point about the "Forming Rec groups" step is that it /preserves+scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if+we start with+  Rec { f = ...h...+      ; g = ...f...+      ; h = ...f... }+we can split into SCCs+  Rec { f = ...h...+      ; h = ..f... }+  NonRec { g = ...f... }++We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g+uses f", no matter how indirectly.  We do a SCC analysis with an edge+f -> g if "f mentions g". That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f, whether active or inactive+       Note [Rules are extra RHSs]+  c) or the LHS or a rule for f, whether active or inactive+       Note [Rule dependency info]+  d) the RHS of an /active/ local IMP-RULE+       Note [IMP-RULES: local rules for imported functions]++(b) and (c) apply regardless of the activation of the RULE, because even if+the rule is inactive its free variables must be bound.  But (d) doesn't need+to worry about this because IMP-RULES are always notionally at the bottom+of the file.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    So in Example [eftInt], eftInt and eftIntFB will be put in the+    same Rec, even though their 'main' RHSs are both non-recursive.++    We must also include inactive rules, so that their free vars+    remain in scope.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++Note [TailUsageDetails when forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is+computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`.+That is because the binding might still become a *non-recursive join point* in+the AcyclicSCC case of dependency analysis!+Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get+a regular, adjusted UsageDetails.+See Note [Join points and unfoldings/rules] for more details on the contract.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to a stable unfolding+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.+Hence the transitive rule_fv_env stuff described in+Note [Rules and loop breakers].++Note [Occurrence analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two somewhat artificial programs (#22404)++  Program (P1)                      Program (P2)+  ------------------------------    -------------------------------------+  let v = <small thunk> in          let v = <small thunk> in+                                    join j = case v of (a,b) -> a+  in case x of                      in case x of+        A -> case v of (a,b) -> a         A -> j+        B -> case v of (a,b) -> a         B -> j+        C -> case v of (a,b) -> b         C -> case v of (a,b) -> b+        D -> []                           D -> []++In (P1), `v` gets allocated, as a thunk, every time this code is executed.  But+notice that `v` occurs at most once in any case branch; the occurrence analyser+spots this and returns a OneOcc{ occ_n_br = 3 } for `v`.  Then the code in+GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three+use sites, and discards the let-binding.  That way, we avoid allocating `v` in+the A,B,C branches (though we still compute it of course), and branch D+doesn't involve <small thunk> at all.  This sometimes makes a Really Big+Difference.++In (P2) we have shared the common RHS of A, B, in a join point `j`.  We would+like to inline `v` in just the same way as in (P1).  But the usual strategy+for let bindings is conservative and uses `andUDs` to combine usage from j's+RHS to its body; as if `j` was called on every code path (once, albeit).  In+the case of (P2), we'll get ManyOccs for `v`.  Important optimisation lost!++Solving this problem makes the Simplifier less fragile.  For example,+the Simplifier might inline `j`, and convert (P2) into (P1)... or it might+not, depending in a perhaps-fragile way on the size of the join point.+I was motivated to implement this feature of the occurrence analyser+when trying to make optimisation join points simpler and more robust+(see e.g. #23627).++The occurrence analyser therefore has clever code that behaves just as+if you inlined `j` at all its call sites.  Here is a tricky variant+to keep in mind:++  Program (P3)+  -------------------------------+    join j = case v of (a,b) -> a+    in case f v of+          A -> j+          B -> j+          C -> []++If you mentally inline `j` you'll see that `v` is used twice on the path+through A, so it should have ManyOcc.  Bear this case in mind!++* We treat /non-recursive/ join points specially. Recursive join points are+  treated like any other letrec, as before.  Moreover, we only give this special+  treatment to /pre-existing/ non-recursive join points, not the ones that we+  discover for the first time in this sweep of the occurrence analyser.++* In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps+  each in-scope non-recursive join point, such as `j` above, to+  a "zeroed form" of its RHS's usage details. The "zeroed form"+    * deletes ManyOccs+    * maps a OneOcc to OneOcc{ occ_n_br = 0 }+  In our example, occ_join_points will be extended with+      [j :-> [v :-> OneOcc{occ_n_br=0}]]+  See addJoinPoint.++* At an occurrence of a join point, we do everything as normal, but add in the+  UsageDetails from the occ_join_points.  See mkOneOcc.++* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use+  `orUDs`, not `andUDs` to combine the usage from the RHS with the usage from+  the body.++Here are the consequences++* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed+  form, the occ_n_br field of a OneOcc binder still counts the number of+  /actual lexical occurrences/ of the variable.  In Program P2, for example,+  `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3.+  There are two lexical occurrences of `v`!+  (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.)++* In the tricky (P3) we'll get an `andUDs` of+    * OneOcc{occ_n_br=0} from the occurrences of `j`)+    * OneOcc{occ_n_br=1} from the (f v)+  These are `andUDs` together in `addOccInfo`, and hence+  `v` gets ManyOccs, just as it should.  Clever!++There are a couple of tricky wrinkles++(W1) Consider this example which shadows `j`:+          join j = rhs in+          in case x of { K j -> ..j..; ... }+     Clearly when we come to the pattern `K j` we must drop the `j`+     entry in occ_join_points.++     This is done by `drop_shadowed_joins` in `addInScope`.++(W2) Consider this example which shadows `v`:+          join j = ...v...+          in case x of { K v -> ..j..; ... }++     We can't make j's occurrences in the K alternative give rise to an+     occurrence of `v` (via occ_join_points), because it'll just be deleted by+     the `K v` pattern.  Yikes.  This is rare because shadowing is rare, but+     it definitely can happen.  Solution: when bringing `v` into scope at+     the `K v` pattern, chuck out of occ_join_points any elements whose+     UsageDetails mentions `v`.  Instead, just `andUDs` all that usage in+     right here.++     This requires work in two places.+     * In `preprocess_env`, we detect if the newly-bound variables intersect+       the free vars of occ_join_points.  (These free vars are conveniently+       simply the domain of the OccInfoEnv for that join point.) If so,+       we zap the entire occ_join_points.+     * In `postprcess_uds`, we add the chucked-out join points to the+       returned UsageDetails, with `andUDs`.++(W3) Consider this example, which shadows `j`, but this time in an argument+              join j = rhs+              in f (case x of { K j -> ...; ... })+     We can zap the entire occ_join_points when looking at the argument,+     because `j` can't posibly occur -- it's a join point!  And the smaller+     occ_join_points is, the better.  Smaller to look up in mkOneOcc, and+     more important, less looking-up when checking (W2).++     This is done in setNonTailCtxt.  It's important /not/ to do this for+     join-point RHS's because of course `j` can occur there!++     NB: this is just about efficiency: it is always safe /not/ to zap the+     occ_join_points.++(W4) What if the join point binding has a stable unfolding, or RULES?+     They are just alternative right-hand sides, and at each call site we+     will use only one of them. So again, we can use `orUDs` to combine+     usage info from all these alternatives RHSs.++Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3).++Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Join arity prediction based on joinRhsArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, the join arity from tail occurrences of a join point (O) may be+higher or lower than the manifest join arity of the join body (M). E.g.,++  -- M > O:+  let f x y = x + y              -- M = 2+  in if b then f 1 else f 2      -- O = 1+  ==> { Contify for join arity 1 }+  join f x = \y -> x + y+  in if b then jump f 1 else jump f 2++  -- M < O+  let f = id                     -- M = 0+  in if ... then f 12 else f 13  -- O = 1+  ==> { Contify for join arity 1, eta-expand f }+  join f x = id x+  in if b then jump f 12 else jump f 13++But for *recursive* let, it is crucial that both arities match up, consider++  letrec f x y = if ... then f x else True+  in f 42++Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump+would not happen in a tail context! Contification is invalid here.+So indeed it is crucial to demand that M=O.++(Side note: Actually, we could be more specific: Let O1 be the join arity of+occurrences from the letrec RHS and O2 the join arity from the let body. Then+we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later.+M=O is the specific case where we don't want to eta-expand. Neither the join+points paper nor GHC does this at the moment.)++We can capitalise on this observation and conclude that *if* f could become a+joinrec (without eta-expansion), it will have join arity M.+Now, M is just the result of 'joinRhsArity', a rather simple, local analysis.+It is also the join arity inside the 'TailUsageDetails' returned by+'occAnalLamTail', so we can predict join arity without doing any fixed-point+iteration or really doing any deep traversal of let body or RHS at all.+We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'.++All this is quite apparent if you look at the contification transformation in+Fig. 5 of "Compiling without Continuations" (which does not account for+eta-expansion at all, mind you). The letrec case looks like this++  letrec f = /\as.\xs. L[us] in L'[es]+    ... and a bunch of conditions establishing that f only occurs+        in app heads of join arity (len as + len xs) inside us and es ...++The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However,+for non-recursive functions, this is the definition of contification from the+paper:++  let f = /\as.\xs.u in L[es]     ... conditions ...++Note that u could be a lambda itself, as we have seen. No relationship between M+and O to exploit here.++Note [Join points and unfoldings/rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let j2 y = blah+   let j x = j2 (x+x)+       {-# INLINE [2] j #-}+   in case e of { A -> j 1; B -> ...; C -> j 2 }++Before j is inlined, we'll have occurrences of j2 in+both j's RHS and in its stable unfolding.  We want to discover+j2 as a join point. So 'occAnalUnfolding' returns an unadjusted+'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the+unfolding to the actual join arity using the same 'adjustTailArity' as for+the RHS, see Note [Adjusting right-hand sides].++Same with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+  let k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 y = j y #-}+      k x y = x + 2 * y+  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }++We identify k as a join point, and we want j to be a join point too.+Without the RULE it would be, and we don't want the RULE to mess it+up.  So provided the join-point arity of k matches the args of the+rule we can allow the tail-call info from the RHS of the rule to+propagate.++* Note that the join arity of the RHS and that of the unfolding or RULE might+  mismatch:++    let j x y = j2 (x+x)+        {-# INLINE[2] j = \x. g #-}+        {-# RULE forall x y z. j x y z = h 17 #-}+    in j 1 2++  So it is crucial that we adjust each TailUsageDetails individually+  with the actual join arity 2 here before we combine with `andUDs`.+  Here, that means losing tail call info on `g` and `h`.++* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for+  RHS, unfolding and RULE combined. Clearly, if they don't agree on their join+  arity, we have to do some adjusting. We choose to adjust to the join arity+  of the RHS, because that is likely the join arity that the join point will+  have; see Note [Join arity prediction based on joinRhsArity].++  If the guess is correct, then tail calls in the RHS are preserved; a necessary+  condition for the whole binding becoming a joinrec.+  The guess can only be incorrect in the 'AcyclicSCC' case when the binding+  becomes a non-recursive join point with a different join arity. But then the+  eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will+  be with a different join arity and destroy unsound tail call info with+  'markNonTail'.++* Wrinkle for RULES.  Suppose the example was a bit different:+      let j :: Int -> Int+          j y = 2 * y+          k :: Int -> Int -> Int+          {-# RULES "SPEC k 0" k 0 = j #-}+          k x y = x + 2 * y+      in ...+  If we eta-expanded the rule all would be well, but as it stands the+  one arg of the rule don't match the join-point arity of 2.++  Conceivably we could notice that a potential join point would have+  an "undersaturated" rule and account for it. This would mean we+  could make something that's been specialised a join point, for+  instance. But local bindings are rarely specialised, and being+  overly cautious about rules only costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++  This appears to be very rare in practice. TODO Perhaps we should gather+  statistics to be sure.++------------------------------------------------------------+Note [Adjusting right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllNonTail' *unless* the binding is for a join point, and+     the TailUsageDetails from the RHS has the right join arity; e.g.+        join j x y = case ... of+                       A -> j2 p+                       B -> j2 q+        in j a b+     Here we want the tail calls to j2 to be tail calls of the whole expression+  b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must+return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage'+once join-point-hood has been decided and eventual one-shot annotations have+been added through 'markNonRecJoinOneShots'.++It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed+perform a similar sequence of steps. Thus, here is an interleaving of events+of both functions, serving as a specification:++  1. Call 'occAnalLamTail' to find usage information for the RHS.+     Recursive case:     'makeNode'+     Non-recursive case: 'occAnalNonRecBind'+  2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`.+      Same whether recursive or not.)+  3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+     Cyclic  Recursive case:  'mkLoopBreakerNodes'+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`+     Non-recursive case:      'occAnalNonRecBind'+  4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g.,+     FloatOut sees one-shot annotations on lambdas+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`  calls 'adjustNonRecRhs'+     Non-recursive case:      'occAnalNonRecBind'        calls 'adjustNonRecRhs'+  5. Call 'adjustTailUsage' accordingly.+     Cyclic Recursive case:   'tagRecBinders'+     Acyclic Recursive case:  'adjustNonRecRhs'+     Non-recursive case:      'adjustNonRecRhs'+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind+  :: OccEnv+  -> TopLevelFlag+  -> ImpRuleEdges+  -> CoreBind+  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+  -> ([CoreBind] -> r -> r)          -- How to combine the scope with new binds+  -> WithUsageDetails r              -- Of the whole let(rec)++occAnalBind env lvl ire (Rec pairs) thing_inside combine+  = addInScopeList env (map fst pairs) $ \env ->+    let WUD body_uds body'  = thing_inside env+        WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds+    in WUD bind_uds (combine binds' body')++occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine+  | isTyVar bndr      -- A type let; we don't gather usage info+  = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside+    in WUD body_uds (combine [NonRec bndr rhs] res)++  -- /Existing/ non-recursive join points+  -- See Note [Occurrence analysis for join points]+  | mb_join@(JoinPoint {}) <- idJoinPointHood bndr+  = -- Analyse the RHS and /then/ the body+    let -- Analyse the rhs first, generating rhs_uds+        !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs+        rhs_uds = foldr1 orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of+                                           -- Note [Occurrence analysis for join points]++        -- Now analyse the body, adding the join point+        -- into the environment with addJoinPoint+        !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env ->+                                      thing_inside (addJoinPoint env bndr' rhs_uds)+    in+    if isDeadOcc occ     -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else WUD (rhs_uds `orUDs` body_uds)    -- Note `orUDs`+             (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']+                      body)++  -- The normal case, including newly-discovered join points+  -- Analyse the body and /then/ the RHS+  | WUD body_uds (occ,body) <- occAnalNonRecBody env bndr thing_inside+  = if isDeadOcc occ   -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else let+        -- Get the join info from the *new* decision; NB: bndr is not already a JoinId+        -- See Note [Join points and unfoldings/rules]+        -- => join arity O of Note [Join arity prediction based on joinRhsArity]+        (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr++        !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs+    in WUD (foldr andUDs body_uds rhs_uds_s)      -- Note `andUDs`+           (combine [NonRec final_bndr rhs'] body)++-----------------+occAnalNonRecBody :: OccEnv -> Id+                  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+                  -> (WithUsageDetails (OccInfo, r))+occAnalNonRecBody env bndr thing_inside+  = addInScopeOne env bndr $ \env ->+    let !(WUD inner_uds res) = thing_inside env+        !occ = lookupLetOccInfo inner_uds bndr+    in WUD inner_uds (occ, res)++-----------------+occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges+                -> JoinPointHood -> 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 )+  | otherwise+  = ( 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+    --    join j = Just (f x) in ...+    -- we do not want to float the (f x) to+    --    let y = f x in join j = Just y in ...+    -- That's that OccRhs would do; but there's no point because+    -- j will never be scrutinised.+    rhs_env  = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs+    rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf++    -- See Note [Join arity prediction based on joinRhsArity]+    -- Match join arity O from mb_join_arity with manifest join arity M as+    -- returned by of occAnalLamTail. It's totally OK for them to mismatch;+    -- hence adjust the UDs from the RHS+    WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $+                                occAnalLamTail rhs_env rhs+    final_bndr_with_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdSpecialisation` mkRuleInfo rules'+                                 `setIdUnfolding` unf1+    final_bndr_no_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdUnfolding` unf1++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = idUnfolding bndr+    WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity mb_join unf_tuds++    --------- Rules ---------+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    -- and Note [Join points and unfoldings/rules]+    rules        = idCoreRules bndr+    rules_w_uds  = map (occAnalRule rhs_env) rules+    rules'       = map fstOf3 rules_w_uds+    imp_rule_infos = lookupImpRules imp_rule_edges bndr+    imp_rule_uds   = [impRulesScopeUsage imp_rule_infos]+         -- imp_rule_uds: consider+         --     h = ...+         --     g = ...+         --     RULE map g = h+         -- Then we want to ensure that h is in scope everywhere+         -- that g is (since the RULE might turn g into h), so+         -- we make g mention h.++    adj_rule_uds :: [UsageDetails]+    adj_rule_uds = imp_rule_uds +++                   [ l `andUDs` adjustTailArity mb_join r+                   | (_,l,r) <- rules_w_uds ]++mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl+-- Precondition: Id is not a join point+mkNonRecRhsCtxt lvl bndr unf+  | certainly_inline = OccVanilla -- See Note [Cascading inlines]+  | otherwise        = OccRhs+  where+    certainly_inline -- See Note [Cascading inlines]+      = -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind+        -- has set the OccInfo for this binder before calling occAnalNonRecRhs+        case idOccInfo bndr of+          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }+            -> active && not stable_unf && not top_bottoming+          _ -> False++    active     = isAlwaysActive (idInlineActivation bndr)+    stable_unf = isStableUnfolding unf+    top_bottoming = isTopLevel lvl && isDeadEndId bndr++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> WithUsageDetails [CoreBind]+-- For a recursive group, we+--      * occ-analyse all the RHSs+--      * compute strongly-connected components+--      * feed those components to occAnalRec+-- See Note [Recursive bindings: the grand plan]+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs+  where+    sccs :: [SCC NodeDetails]+    sccs = stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs++    bndrs    = map fst pairs+    bndr_set = mkVarSet bndrs++-----------------------------+occAnalRec :: OccEnv -> TopLevelFlag+           -> SCC NodeDetails+           -> WithUsageDetails [CoreBind]+           -> WithUsageDetails [CoreBind]++-- The NonRec case is just like a Let (NonRec ...) above+occAnalRec !_ lvl+           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))+           (WUD body_uds binds)+  | isDeadOcc occ  -- Check for dead code: see Note [Dead code]+  = WUD body_uds binds+  | otherwise+  = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr+        !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds+    in WUD (body_uds `andUDs` rhs_uds')+           (NonRec bndr' rhs' : binds)+  where+    occ = lookupLetOccInfo body_uds bndr++-- The Rec case is the interesting one+-- See Note [Recursive bindings: the grand plan]+-- See Note [Loop breaking]+occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds)+  | not (any needed details_s)+  = -- Check for dead code: see Note [Dead code]+    -- NB: Only look at body_uds, ignoring uses in the SCC+    WUD body_uds binds++  | otherwise+  = WUD final_uds (Rec pairs : binds)+  where+    all_simple = all nd_simple details_s++    needed :: NodeDetails -> Bool+    needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env+    body_env = ud_env body_uds++    ------------------------------+    -- Make the nodes for the loop-breaker analysis+    -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LoopBreakerNode]+    WUD final_uds loop_breaker_nodes = mkLoopBreakerNodes env lvl body_uds details_s++    ------------------------------+    weak_fvs :: VarSet+    weak_fvs = mapUnionVarSet nd_weak_fvs details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | all_simple = reOrderNodes   0 weak_fvs loop_breaker_nodes []+          | otherwise  = loopBreakNodes 0 weak_fvs loop_breaker_nodes []+          -- In the common case when all are "simple" (no rules at all)+          -- the loop_breaker_nodes will include all the scope edges+          -- so a SCC computation would yield a single CyclicSCC result;+          -- and reOrderNodes deals with exactly that case.+          -- Saves a SCC analysis in a common case+++{- *********************************************************************+*                                                                      *+                Loop breaking+*                                                                      *+********************************************************************* -}++{- Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does+loop-breaking on each CyclicSCC of the original program:++* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC++* loopBreakNodes: Do SCC analysis on it++* reOrderNodes: For each CyclicSCC, pick a loop breaker+    * Delete edges to that loop breaker+    * Do another SCC analysis on that reduced SCC+    * Repeat++To form the loop-breaker graph, we construct a new set of Nodes, the+"loop-breaker nodes", with the same details but different edges, the+"loop-breaker edges".  The loop-breaker nodes have both more and fewer+dependencies than the scope edges:++  More edges:+     If f calls g, and g has an active rule that mentions h then+     we add an edge from f -> h.  See Note [Rules and loop breakers].++  Fewer edges: we only include dependencies+     * only on /active/ rules,+     * on rule /RHSs/ (not LHSs)++The scope edges, by contrast, must be much more inclusive.++The nd_simple flag tracks the common case when a binding has no RULES+at all, in which case the loop-breaker edges will be identical to the+scope edges.++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note [inl_fvs]+~~~~~~~~~~~~~~+Note that the loop-breaker graph includes edges for occurrences in+/both/ the RHS /and/ the stable unfolding.  Consider this, which actually+occurred when compiling BooleanFormula.hs in GHC:++  Rec { lvl1 = go+      ; lvl2[StableUnf = go] = lvl1+      ; go = ...go...lvl2... }++From the point of view of infinite inlining, we need only these edges:+   lvl1 :-> go+   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining+   go   :-> go, lvl2++But the danger is that, lacking any edge to lvl1, we'll put it at the+end thus+  Rec { lvl2[ StableUnf = go] = lvl1+      ; go[LoopBreaker] = ...go...lvl2... }+      ; lvl1[Occ=Once]  = go }++And now the Simplifer will try to use PreInlineUnconditionally on lvl1+(which occurs just once), but because it is last we won't actually+substitute in lvl2.  Sigh.++To avoid this possibility, we include edges from lvl2 to /both/ its+stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in+makeNode.  Maybe we could be more clever, but it's very much a corner+case.++Note [Weak loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is a last nasty wrinkle.  Suppose we have++    Rec { f = f_rhs+          RULE f [] = g++          h = h_rhs+          g = h+          ...more... }++Remember that we simplify the RULES before any RHS (see Note+[Rules are visible in their own rec group] above).++So we must *not* postInlineUnconditionally 'g', even though+its RHS turns out to be trivial.  (I'm assuming that 'g' is+not chosen as a loop breaker.)  Why not?  Because then we+drop the binding for 'g', which leaves it out of scope in the+RULE!++Here's a somewhat different example of the same thing+    Rec { q = r+        ; r = ...p...+        ; p = p_rhs+          RULE p [] = q }+Here the RULE is "below" q, but we *still* can't postInlineUnconditionally+q, because the RULE for p is active throughout.  So the RHS of r+might rewrite to     r = ...q...+So q must remain in scope in the output program!++We "solve" this by:++    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+    iff q is a mentioned in the RHS of any RULE (active on not)+    in the Rec group++Note the "active or not" comment; even if a RULE is inactive, we+want its RHS free vars to stay alive (#20820)!++A normal "strong" loop breaker has IAmLoopBreaker False.  So:++                                Inline  postInlineUnconditionally+strong   IAmLoopBreaker False    no      no+weak     IAmLoopBreaker True     yes     no+         other                   yes     yes++The **sole** reason for this kind of loop breaker is so that+postInlineUnconditionally does not fire.  Ugh.++Annoyingly, since we simplify the rules *first* we'll never inline+q into p's RULE.  That trivial binding for q will hang around until+we discard the rule.  Yuk.  But it's rare.++Note [Rules and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we form the loop-breaker graph (Step 4 in Note [Recursive+bindings: the grand plan]), we must be careful about RULEs.++For a start, we want a loop breaker to cut every cycle, so inactive+rules play no part; we need only consider /active/ rules.+See Note [Finding rule RHS free vars]++The second point is more subtle.  A RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in GHC.Core.Opt.Simplify++Hence, if+    f's RHS (or its stable unfolding if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules]. So our plan is this:++   Take the free variables of f's RHS, and augment it with all the+   variables reachable by a transitive sequence RULES from those+   starting points.++That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.+Wrinkles:++* We only consider /active/ rules. See Note [Finding rule RHS free vars]++* We need only consider free vars that are also binders in this Rec+  group.  See also Note [Finding rule RHS free vars]++* We only consider variables free in the *RHS* of the rule, in+  contrast to the way we build the Rec group in the first place (Note+  [Rule dependency info])++* Why "transitive sequence of rules"?  Because active rules apply+  unconditionally, without checking loop-breaker-ness.+ See Note [Loop breaker dependencies].++Note [Finding rule RHS free vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this real example from Data Parallel Haskell+     tagZero :: Array Int -> Array Tag+     {-# INLINE [1] tagZeroes #-}+     tagZero xs = pmap (\x -> fromBool (x==0)) xs++     {-# RULES "tagZero" [~1] forall xs n.+         pmap fromBool <blah blah> = tagZero xs #-}+So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.+However, tagZero can only be inlined in phase 1 and later, while+the RULE is only active *before* phase 1.  So there's no problem.++To make this work, we look for the RHS free vars only for+*active* rules. That's the reason for the occ_rule_act field+of the OccEnv.++Note [loopBreakNodes]+~~~~~~~~~~~~~~~~~~~~~+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++type Binding = (Id,CoreExpr)++-- See Note [loopBreakNodes]+loopBreakNodes :: Int+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LoopBreakerNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+-- See Note [loopBreakNodes]+loopBreakNodes depth weak_fvs nodes binds+  = -- pprTrace "loopBreakNodes" (ppr nodes) $+    go (stronglyConnCompFromEdgedVerticesUniqR nodes)+  where+    go []         = binds+    go (scc:sccs) = loop_break_scc scc (go sccs)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds+          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds+reOrderNodes depth weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen+    --                               , text "chosen" <+> ppr chosen_nodes ]) $+    loopBreakNodes new_depth weak_fvs unchosen $+    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (snd_score (node_payload node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding+nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs})+  = (set_id_occ bndr, rhs)++mk_loop_breaker :: Id -> Id+mk_loop_breaker bndr+  = bndr `setIdOccInfo` occ'+  where+    occ'      = strongLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> Id -> Id+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs bndr+  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'+  | otherwise                  = bndr+  where+    occ'      = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool                -- True <=> Too many iterations,+                                         --          so approximate+                  -> NodeScore           -- Best score so far+                  -> [LoopBreakerNode]   -- Nodes with this score+                  -> [LoopBreakerNode]   -- Nodes with higher scores+                  -> [LoopBreakerNode]   -- Unprocessed nodes+                  -> ([LoopBreakerNode], [LoopBreakerNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = snd_score (node_payload node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakers is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'.+-- The Unique key is gotten from the Id.+type LetrecNode = Node Unique NodeDetails++-- | Node details as consumed by 'occAnalRec'.+data NodeDetails+  = ND { nd_bndr :: Id          -- Binder++       , nd_rhs  :: !(WithTailUsageDetails CoreExpr)+         -- ^ RHS, already occ-analysed+         -- With TailUsageDetails from RHS, and RULES, and stable unfoldings,+         -- ignoring phase (ie assuming all are active).+         -- NB: Unadjusted TailUsageDetails, as if this Node becomes a+         -- non-recursive join point!+         -- See Note [TailUsageDetails when forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_simple :: Bool      -- True iff this binding has no local RULES+                                -- If all nodes are simple we don't need a loop-breaker+                                -- dep-anal before reconstructing.++       , nd_weak_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                 -- in the RHS of any rule (active or not) for this bndr+                                 -- See Note [Weak loop breakers]++       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                        -- in the RHS of an active rule for this bndr+                                        -- See Note [Rules and loop breakers]+  }++instance Outputable NodeDetails where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr uds+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "simple =" <+> ppr (nd_simple nd)+                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)+             ])+            where+               WTUD uds _ = nd_rhs nd++-- | Digraph with simplified and completely occurrence analysed+-- 'SimpleNodeDetails', retaining just the info we need for breaking loops.+type LoopBreakerNode = Node Unique SimpleNodeDetails++-- | Condensed variant of 'NodeDetails' needed during loop breaking.+data SimpleNodeDetails+  = SND { snd_bndr  :: IdWithOccInfo  -- OccInfo accurate+        , snd_rhs   :: CoreExpr       -- properly occur-analysed+        , snd_score :: NodeScore+        }++instance Outputable SimpleNodeDetails where+   ppr nd = text "SND" <> braces+             (sep [ text "bndr =" <+> ppr (snd_bndr nd)+                  , text "score =" <+> ppr (snd_score nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode !env imp_rule_edges bndr_set (bndr, rhs)+  = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $+    DigraphNode { node_payload      = details+                , node_key          = varUnique bndr+                , node_dependencies = nonDetKeysUniqSet scope_fvs }+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.+  where+    details = ND { nd_bndr            = bndr'+                 , nd_rhs             = WTUD (TUD rhs_ja unadj_scope_uds) rhs'+                 , nd_inl             = inl_fvs+                 , nd_simple          = null rules_w_uds && null imp_rule_info+                 , nd_weak_fvs        = weak_fvs+                 , nd_active_rule_fvs = active_rule_fvs }++    bndr' | noBinderSwaps env = bndr  -- See Note [Unfoldings and rules]+          | otherwise         = bndr `setIdUnfolding`      unf'+                                     `setIdSpecialisation` mkRuleInfo rules'++    -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the+    --     JoinArity rhs_ja of unadj_rhs_uds.+    unadj_inl_uds   = unadj_rhs_uds `andUDs` adj_unf_uds+    unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    scope_fvs = udFreeVars bndr_set unadj_scope_uds+    -- scope_fvs: all occurrences from this binder: RHS, unfolding,+    --            and RULES, both LHS and RHS thereof, active or inactive++    inl_fvs  = udFreeVars bndr_set unadj_inl_uds+    -- inl_fvs: vars that would become free if the function was inlined.+    -- We conservatively approximate that by the free vars from the RHS+    -- and the unfolding together.+    -- See Note [inl_fvs]+++    --------- Right hand side ---------+    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    -- and Note [TailUsageDetails when forming Rec groups]+    -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because+    --   (a) we don't yet know the final joinpointhood. It might not become a+    --       join point after all!+    --   (b) we don't even know whether it stays a recursive RHS after the SCC+    --       analysis we are about to seed! So we can't markAllInsideLam in+    --       advance, because if it ends up as a non-recursive join point we'll+    --       consider it as one-shot and don't need to markAllInsideLam.+    -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage+    -- until occAnalRec. In effect, we pretend that the RHS becomes a+    -- non-recursive join point and fix up later with adjustTailUsage.+    rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs+            -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint),+            -- it's safe to zap the occ_join_points, because they can't occur in RHS.+    WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs+      -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness+                               -- here because that is what we are setting!+    WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds+      -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M+      -- of Note [Join arity prediction based on joinRhsArity]++    --------- IMP-RULES --------+    is_active     = occ_rule_act env :: Activation -> Bool+    imp_rule_info = lookupImpRules imp_rule_edges bndr+    imp_rule_uds  = impRulesScopeUsage imp_rule_info+    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info++    --------- All rules --------+    -- See Note [Join points and unfoldings/rules]+    -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M+    -- of Note [Join arity prediction based on joinRhsArity]+    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds)+                  | rule <- idCoreRules bndr+                  , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ]+    rules'      = map fstOf3 rules_w_uds++    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds++    -------- active_rule_fvs ------------+    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds+    add_active_rule (rule, _, rhs_uds) fvs+      | is_active (ruleActivation rule)+      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs+      | otherwise+      = fvs++    -------- weak_fvs ------------+    -- See Note [Weak loop breakers]+    weak_fvs = foldr add_rule emptyVarSet rules_w_uds+    add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs++mkLoopBreakerNodes :: OccEnv -> TopLevelFlag+                   -> UsageDetails   -- for BODY of let+                   -> [NodeDetails]+                   -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date+-- See Note [Choosing loop breakers]+-- This function primarily creates the Nodes for the+-- loop-breaker SCC analysis.  More specifically:+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   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 mk_lb_node details_s bndrs')+  where+    WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s++    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs+                      , nd_rhs = WTUD _ rhs }) new_bndr+      = DigraphNode { node_payload      = simple_nd+                    , node_key          = varUnique old_bndr+                    , node_dependencies = nonDetKeysUniqSet lb_deps }+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+      where+        simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score }+        score  = nodeScore env new_bndr lb_deps nd+        lb_deps = extendFvs_ rule_fv_env inl_fvs+        -- See Note [Loop breaker dependencies]++    rule_fv_env :: IdEnv IdSet+    -- Maps a variable f to the variables from this group+    --      reachable by a sequence of RULES starting with f+    -- Domain is *subset* of bound vars (others have no rule fvs)+    -- See Note [Finding rule RHS free vars]+    -- Why transClosureFV?  See Note [Loop breaker dependencies]+    rule_fv_env = transClosureFV $ mkVarEnv $+                  [ (b, rule_fvs)+                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+                  , not (isEmptyVarSet rule_fvs) ]++{- Note [Loop breaker dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop breaker dependencies of x in a recursive+group { f1 = e1; ...; fn = en } are:++- The "inline free variables" of f: the fi free in+  f's stable unfolding and RHS; see Note [inl_fvs]++- Any fi reachable from those inline free variables by a sequence+  of RULE rewrites.  Remember, rule rewriting is not affected+  by fi being a loop breaker, so we have to take the transitive+  closure in case f is the only possible loop breaker in the loop.++  Hence rule_fv_env.  We need only account for /active/ rules.+-}++------------------------------------------+nodeScore :: OccEnv+          -> Id        -- Binder with new occ-info+          -> VarSet    -- Loop-breaker dependencies+          -> NodeDetails+          -> NodeScore+nodeScore !env new_bndr lb_deps+          (ND { nd_bndr = old_bndr, nd_rhs = WTUD _ bind_rhs })++  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has+  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- old_unf+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding old_unf+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    -- is_lb: see Note [Loop breakers, node scoring, and stability]+    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)++    old_unf = realIdUnfolding old_bndr+    can_unfold = canUnfold old_unf+    rhs        = case old_unf of+                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                     | isStableSource src+                     -> unf_rhs+                   _ -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case old_unf of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs+++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app (Let _ e)  = is_con_app e  -- let x = let y = blah in (a,b)+    is_con_app _          = False         -- We will float the y out, so treat+                                          -- the x-binding as a con-app (#20941)++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (#12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore+-}++{- *********************************************************************+*                                                                      *+                  Lambda groups+*                                                                      *+********************************************************************* -}++{- Note [Occurrence analysis for lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For value lambdas we do a special hack.  Consider+     (\x. \y. ...x...)+If we did nothing, x is used inside the \y, so would be marked+as dangerous to dup.  But in the common case where the abstraction+is applied to two arguments this is over-pessimistic, which delays+inlining x, which forces more simplifier iterations.++So the occurrence analyser collaborates with the simplifier to treat+a /lambda-group/ specially.   A lambda-group is a contiguous run of+lambda and casts, e.g.+    Lam x (Lam y (Cast (Lam z body) co))++* Occurrence analyser: we just mark each binder in the lambda-group+  (here: x,y,z) with its occurrence info in the *body* of the+  lambda-group.  See occAnalLamTail.++* Simplifier.  The simplifier is careful when partially applying+  lambda-groups. See the call to zapLambdaBndrs in+     GHC.Core.Opt.Simplify.simplExprF1+     GHC.Core.SimpleOpt.simple_app++* Why do we take care to account for intervening casts? Answer:+  currently we don't do eta-expansion and cast-swizzling in a stable+  unfolding (see Historical-note [Eta-expansion in stable unfoldings]).+  So we can get+    f = \x. ((\y. ...x...y...) |> co)+  Now, since the lambdas aren't together, the occurrence analyser will+  say that x is OnceInLam.  Now if we have a call+    (f e1 |> co) e2+  we'll end up with+    let x = e1 in ...x..e2...+  and it'll take an extra iteration of the Simplifier to substitute for x.++A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity+recognises except that the latter looks through (some) ticks.  Maybe a lambda+group should also look through (some) ticks?+-}++isOneShotFun :: CoreExpr -> Bool+-- The top level lambdas, ignoring casts, of the expression+-- are all one-shot.  If there aren't any lambdas at all, this is True+isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e+isOneShotFun (Cast e _) = isOneShotFun e+isOneShotFun _          = True++zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear under the \z+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: `arg_count` includes both type and value args+zapLambdaBndrs fun arg_count+  = -- If the lambda is fully applied, leave it alone; if not+    -- zap the OccInfo on the lambdas that do have arguments,+    -- so they beta-reduce to use-many Lets rather than used-once ones.+    zap arg_count fun `orElse` fun+  where+    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr+    -- Nothing => No need to change the occ-info+    -- Just e  => Had to change+    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot+            | otherwise      = Just e   -- in which case no need to zap+    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }+    zap n (Lam b e)   = do { e' <- zap (n-1) e+                           ; return (Lam (zap_bndr b) e') }+    zap _ _           = Nothing  -- More arguments than lambdas++    zap_bndr b | isTyVar b = b+               | otherwise = zapLamIdInfo b++occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr+-- ^ See Note [Occurrence analysis for lambda binders].+-- It does the following:+--   * Sets one-shot info on the lambda binder from the OccEnv, and+--     removes that one-shot info from the OccEnv+--   * Sets the OccEnv to OccVanilla when going under a value lambda+--   * Tags each lambda with its occurrence information+--   * Walks through casts+--   * Package up the analysed lambda with its manifest join arity+--+-- This function does /not/ do+--   markAllInsideLam or+--   markAllNonTail+-- The caller does that, via adjustTailUsage (mostly calls go through+-- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call+-- adjustTailUsage to discharge the assumed join arity.+--+-- In effect, the analysis result is for a non-recursive join point with+-- manifest arity and adjustTailUsage does the fixup.+-- See Note [Adjusting right-hand sides]+occAnalLamTail env expr+  = let !(WUD usage expr') = occ_anal_lam_tail env expr+    in WTUD (TUD (joinRhsArity expr) usage) expr'++occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr+-- Does not markInsideLam etc for the outmost batch of lambdas+occ_anal_lam_tail env expr@(Lam {})+  = go env [] expr+  where+    go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr+    go env rev_bndrs (Lam bndr body)+      | isTyVar bndr+      = go env (bndr:rev_bndrs) body+              -- Important: Unlike a value binder, do not modify occ_encl+              -- to OccVanilla, so that with a RHS like+              --   \(@ x) -> K @x (f @x)+              -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain+              -- from inlining f. See the beginning of Note [Cascading inlines].++      | otherwise+      = let (env_one_shots', bndr')+              = case occ_one_shots env of+                  []         -> ([],  bndr)+                  (os : oss) -> (oss, updOneShotInfo bndr os)+                  -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+                  -- one-shot info might be better than what we can infer, e.g.+                  -- due to explicit use of the magic 'oneShot' function.+                  -- See Note [oneShot magic]+            env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }+         in go env' (bndr':rev_bndrs) body++    go env rev_bndrs body+      = addInScope env rev_bndrs $ \env ->+        let !(WUD usage body') = occ_anal_lam_tail env body+            wrap_lam body bndr = Lam (tagLamBinder usage bndr) body+        in WUD (usage `addLamCoVarOccs` rev_bndrs)+               (foldl' wrap_lam body' rev_bndrs)++-- For casts, keep going in the same lambda-group+-- See Note [Occurrence analysis for lambda binders]+occ_anal_lam_tail env (Cast expr co)+  = let  WUD usage expr' = occ_anal_lam_tail env expr+         -- usage1: see Note [Gather occurrences of coercion variables]+         usage1 = addManyOccs usage (coVarsOfCo co)++         -- usage2: see Note [Occ-anal and cast worker/wrapper]+         usage2 = case expr of+                    Var {} | isRhsEnv env -> markAllMany usage1+                    _ -> usage1++         -- usage3: you might think this was not necessary, because of+         -- the markAllNonTail in adjustTailUsage; but not so!  For a+         -- join point, adjustTailUsage doesn't do this; yet if there is+         -- a cast, we must!  Also: why markAllNonTail?  See+         -- GHC.Core.Lint: Note Note [Join points and casts]+         usage3 = markAllNonTail usage2++    in WUD usage3 (Cast expr' co)++occ_anal_lam_tail env expr  -- Not Lam, not Cast+  = occAnal env expr++{- Note [Occ-anal and cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   y = e; x = y |> co+If we mark y as used-once, we'll inline y into x, and the Cast+worker/wrapper transform will float it straight back out again.  See+Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.++So in this particular case we want to mark 'y' as Many.  It's very+ad-hoc, but it's also simple.  It's also what would happen if we gave+the binding for x a stable unfolding (as we usually do for wrappers, thus+      y = e+      {-# INLINE x #-}+      x = y |> co+Now y appears twice -- once in x's stable unfolding, and once in x's+RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable+unfolding, which would obviate this Note; but that seems a bit of a+heavyweight solution.)++We only need to this in occAnalLamTail, not occAnal, because the top leve+of a right hand side is handled by occAnalLamTail.+-}+++{- *********************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+********************************************************************* -}++occAnalUnfolding :: OccEnv+                 -> Unfolding+                 -> WithTailUsageDetails Unfolding+-- Occurrence-analyse a stable unfolding;+-- discard a non-stable one altogether and return empty usage details.+occAnalUnfolding !env unf+  = case unf of+      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })+        | isStableSource src ->+            let+              WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs+              unf' = unf { uf_tmpl = rhs' }+            in WTUD (TUD rhs_ja (markAllMany uds)) unf'+              -- markAllMany: see Note [Occurrences in stable unfoldings]++        | otherwise -> WTUD (TUD 0 emptyDetails) unf+              -- For non-Stable unfoldings we leave them undisturbed, but+              -- don't count their usage because the simplifier will discard them.+              -- We leave them undisturbed because nodeScore uses their size info+              -- to guide its decisions.  It's ok to leave un-substituted+              -- expressions in the tree because all the variables that were in+              -- scope remain in scope; there is no cloning etc.++      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+        -> let WUD uds args' = addInScopeList env bndrs $ \ env ->+                               occAnalList env args+           in WTUD (TUD 0 uds) (unf { df_args = args' })+              -- No need to use tagLamBinders because we+              -- never inline DFuns so the occ-info on binders doesn't matter++      unf -> WTUD (TUD 0 emptyDetails) unf++occAnalRule :: OccEnv+             -> CoreRule+             -> (CoreRule,         -- Each (non-built-in) rule+                 UsageDetails,     -- Usage details for LHS+                 TailUsageDetails) -- Usage details for RHS+occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+  = (rule', lhs_uds', TUD rhs_ja rhs_uds')+  where+    rule' = rule { ru_args = args', ru_rhs = rhs' }++    WUD lhs_uds args' = addInScopeList env bndrs $ \env ->+                        occAnalList env args++    lhs_uds' = markAllManyNonTail lhs_uds+    WUD rhs_uds rhs' = addInScopeList env bndrs $ \env ->+                       occAnal env rhs+                          -- Note [Rules are extra RHSs]+                          -- Note [Rule dependency info]+    rhs_uds' = markAllMany rhs_uds+    rhs_ja = length args -- See Note [Join points and unfoldings/rules]++occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)++{- Note [Occurrences in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f p = BIG+    {-# INLINE g #-}+    g y = not (f y)+where this is the /only/ occurrence of 'f'.  So 'g' will get a stable+unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule+or inlining f) so that it doesn't mention 'f' any more.  Now the last+remaining call to f is in g's Stable unfolding. But, even though there+is only one syntactic occurrence of f, we do /not/ want to do+preinlineUnconditionally here!++The INLINE pragma says "inline exactly this RHS"; perhaps the+programmer wants to expose that 'not', say. If we inline f that will make+the Stable unfoldign big, and that wasn't what the programmer wanted.++Another way to think about it: if we inlined g as-is into multiple+call sites, now there's be multiple calls to f.++Bottom line: treat all occurrences in a stable unfolding as "Many".+We still leave tail call information intact, though, as to not spoil+potential join points.++Note [Unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally unfoldings and rules are already occurrence-analysed, so we+don't want to reconstruct their trees; we just want to analyse them to+find how they use their free variables.++EXCEPT if there is a binder-swap going on, in which case we do want to+produce a new tree.++So we have a fast-path that keeps the old tree if the occ_bs_env is+empty.   This just saves a bit of allocation and reconstruction; not+a big deal.++Two tricky corners:++* Dead bindings (#22761). Supose we have+    Unfolding = \x. let y = foo in x+1+  which includes a dead binding for `y`. In occAnalUnfolding we occ-anal+  the unfolding and produce /no/ occurrences of `foo` (since `y` is+  dead).  But if we discard the occ-analysed syntax tree (which we do on+  our fast path), and use the old one, we still /have/ an occurrence of+  `foo` -- and that can lead to out-of-scope variables (#22761).++  Solution: always keep occ-analysed trees in unfoldings and rules, so they+  have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.++* One-shot binders. Consider+     {- f has Stable unfolding \p q -> blah+        Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -}+     f = \x y. blah++   Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has+          occ_one_shots = [NoOneShortInfo, OneShotLam]+   This will put OneShotLam on the \y.  And it'll put it on the \q.  But the+   noBinderSwap check will mean that we discard this new occ-anal'd unfolding+   and keep the old one, with no OneShotInfo.++   This looks a little inconsistent, but the Stable unfolding is just used for+   inlinings; OneShotInfo isn't a lot of use here.++Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an OccRhs for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an OccVanilla context, not OccRhs.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"+then the simplifier iterates indefinitely:+        x = f y+        k = Just x   -- We decide that k is 'certainly_inline'+        v = ...k...  -- but preInlineUnconditionally doesn't inline it+inline ==>+        k = Just (f y)+        v = ...k...+float ==>+        x1 = f y+        k = Just x1+        v = ...k...++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.  See #24582 for an example of the two getting out of sync.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]+occAnalList !_   []    = WUD emptyDetails []+occAnalList env (e:es) = let+                          (WUD uds1 e') = occAnal env e+                          (WUD uds2 es') = occAnalList env es+                         in WUD (uds1 `andUDs` uds2) (e' : es')++occAnal :: OccEnv+        -> CoreExpr+        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids++occAnal !_   expr@(Lit _)  = WUD emptyDetails expr++occAnal env expr@(Var _) = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ expr@(Type ty)+  = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr+occAnal _ expr@(Coercion co)+  = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr+        -- See Note [Gather occurrences of coercion variables]++{- Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, for two reasons:++1. So that we can sort them into the right place when doing dependency analysis.++2. So that we know when they are surely dead.++It is useful to know when they a coercion variable is surely dead,+when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.+For example (#20143):++  case unsafeEqualityProof @blah of+     UnsafeRefl cv -> ...no use of cv...++Here we can discard the case, since unsafeEqualityProof always terminates.+But only if the coercion variable 'cv' is unused.++Another example from #15696: we had something like+  case eq_sel d of co -> ...(typeError @(...co...) "urk")...+Then 'd' was substituted by a dictionary, so the expression+simpified to+  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...++We can only  drop the case altogether if 'cv' is unused, which is not+the case here.++Conclusion: we need accurate dead-ness info for CoVars.+We gather CoVar occurrences from:++  * The (Type ty) and (Coercion co) cases of occAnal++  * The type 'ty' of a lambda-binder (\(x:ty). blah)+    See addCoVarOccs++But it is not necessary to gather CoVars from the types of other binders.++* For let-binders, if the type mentions a CoVar, so will the RHS (since+  it has the same type)++* For case-alt binders, if the type mentions a CoVar, so will the scrutinee+  (since it has the same type)+-}++occAnal env (Tick tickish body)+  = WUD usage' (Tick tickish body')+  where+    WUD usage body' = occAnal env body++    usage'+      | tickish `tickishScopesLike` SoftScope+      = usage  -- For soft-scoped ticks (including SourceNotes) we don't want+               -- to lose join-point-hood, so we don't mess with `usage` (#24078)++      -- 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+      = -- Never substitute for any of the Ids in a Breakpoint+        addManyOccs usage_lam (mkVarSet ids)++      | otherwise+      = usage_lam++    usage_lam = markAllNonTail (markAllInsideLam usage)++    -- TODO There may be ways to make ticks and join points play+    -- nicer together, but right now there are problems:+    --   let j x = ... in tick<t> (j 1)+    -- Making j a join point may cause the simplifier to drop t+    -- (if the tick is put into the continuation). So we don't+    -- count j 1 as a tail call.+    -- See #14242.++occAnal env (Cast expr co)+  = let  (WUD usage expr') = occAnal env expr+         usage1 = addManyOccs usage (coVarsOfCo co)+             -- usage2: see Note [Gather occurrences of coercion variables]+         usage2 = markAllNonTail usage1+             -- usage3: calls inside expr aren't tail calls any more+    in WUD usage2 (Cast expr' co)++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++occAnal env expr@(Lam {})+  = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail+    occAnalLamTail env expr++occAnal env (Case scrut bndr ty alts)+  = let+      WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut++      WUD alts_usage (tagged_bndr, alts')+         = addInScopeOne env bndr $ \env ->+           let alt_env = addBndrSwap scrut' bndr $+                         setTailCtxt env  -- Kill off OccRhs+               WUD alts_usage alts' = do_alts alt_env alts+               tagged_bndr = tagLamBinder alts_usage bndr+           in WUD alts_usage (tagged_bndr, alts')++      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage+                    -- Alts can have tail calls, but the scrutinee can't++    in WUD total_usage (Case scrut' tagged_bndr ty alts')+  where+    do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]+    do_alts _   []         = WUD emptyDetails []+    do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts')+      where+        WUD uds1 alt'  = do_alt  env alt+        WUD uds2 alts' = do_alts env alts++    do_alt !env (Alt con bndrs rhs)+      = addInScopeList env bndrs $ \ env ->+        let WUD rhs_usage rhs' = occAnal env rhs+            tagged_bndrs = tagLamBinders rhs_usage bndrs+        in                 -- See Note [Binders in case alternatives]+        WUD rhs_usage (Alt con tagged_bndrs rhs')++occAnal env (Let bind body)+  = occAnalBind env NotTopLevel noImpRuleEdges bind+                (\env -> occAnal env body) mkLets++occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr]+            -> [OneShots]  -- Very commonly empty, notably prior to dmd anal+            -> WithUsageDetails CoreExpr+-- The `fun` argument is just an accumulating parameter,+-- the base for building the application we return+occAnalArgs !env fun args !one_shots+  = go emptyDetails fun args one_shots+  where+    env_args = setNonTailCtxt encl env++    -- Make bottoming functions interesting+    -- See Note [Bottoming function calls]+    encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut+         | otherwise                               = OccVanilla++    go uds fun [] _ = WUD uds fun+    go uds fun (arg:args) one_shots+      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'+      where+        !(WUD arg_uds arg') = occAnal arg_env arg+        !(arg_env, one_shots')+            | isTypeArg arg+            = (env_args, one_shots)+            | otherwise+            = case one_shots of+                []                -> (env_args, []) -- Fast path; one_shots is often empty+                (os : one_shots') -> (setOneShots os env_args, one_shots')++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Bottoming function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let x = (a,b) in+   case p of+      A -> ...(error x)..+      B -> ...(ertor x)...++postInlineUnconditionally may duplicate x's binding, but sometimes it+does so only if the use site IsInteresting.  Pushing allocation into error+branches is good, so we try to make bottoming calls look interesting, by+setting occ_encl = OccScrut for such calls.++The slightly-artificial test T21128 is a good example.  It's probably+not a huge deal.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])+           -> WithUsageDetails (Expr CoreBndr)+-- Naked variables (not applied) end up here too+occAnalApp !env (Var fun, args, ticks)+  -- Account for join arity of runRW# continuation+  -- See Note [Simplification of runRW#]+  --+  -- NB: Do not be tempted to make the next (Var fun, args, tick)+  --     equation into an 'otherwise' clause for this equation+  --     The former has a bang-pattern to occ-anal the args, and+  --     we don't want to occ-anal them twice in the runRW# case!+  --     This caused #18296+  | fun `hasKey` runRWKey+  , [t1, t2, arg]  <- args+  , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg+  = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])++occAnalApp env (Var fun_id, args, ticks)+  = WUD all_uds (mkTicks ticks app')+  where+    -- Lots of banged bindings: this is a very heavily bit of code,+    -- so it pays not to make lots of thunks here, all of which+    -- will ultimately be forced.+    !(fun', fun_id')  = lookupBndrSwap env fun_id+    !(WUD args_uds app') = occAnalArgs env fun' args one_shots++    fun_uds = mkOneOcc env fun_id' int_cxt n_args+       -- NB: fun_uds is computed for fun_id', not fun_id+       -- See (BS1) in Note [The binder-swap substitution]++    all_uds = fun_uds `andUDs` final_args_uds++    !final_args_uds = markAllNonTail                              $+                      markAllInsideLamIf (isRhsEnv env && is_exp) $+                        -- isRhsEnv: see Note [OccEncl]+                      args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    !n_val_args = valArgCount args+    !n_args     = length args+    !int_cxt    = case occ_encl env of+                   OccScrut -> IsInteresting+                   _other   | n_val_args > 0 -> IsInteresting+                            | otherwise      -> NotInteresting++    !is_exp     = isExpandableApp fun_id n_val_args+        -- See Note [CONLIKE pragma] in GHC.Types.Basic+        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs++    one_shots  = argsOneShots (idDmdSig fun_id) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = WUD (markAllNonTail (fun_uds `andUDs` args_uds))+                     (mkTicks ticks app')+  where+    !(WUD args_uds app') = occAnalArgs env fun' args []+    !(WUD fun_uds fun')  = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexes like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some OneShotLam items+        -- onto the context stack.++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  | n_val_args > 0+  = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt+        , occ_encl      = OccVanilla }+          -- OccVanilla: the function part of the application+          -- is no longer on OccRhs or OccScrut+  | otherwise+  = env+  where+    n_val_args = valArgCount args+++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C(1,C(1,L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, because it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active+           , occ_rule_act   :: Activation -> Bool  -- Which rules are active+             -- See Note [Finding rule RHS free vars]++           -- See Note [The binder-swap substitution]+           -- If  x :-> (y, co)  is in the env,+           -- then please replace x by (y |> mco)+           -- Invariant of course: idType x = exprType (y |> mco)+           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))+              -- Domain is Global and Local Ids+              -- Range is just Local Ids+           , occ_bs_rng  :: !VarSet+               -- Vars (TyVars and Ids) free in the range of occ_bs_env++             -- Usage details of the RHS of in-scope non-recursive join points+             -- Invariant: no Id maps to an empty OccInfoEnv+             -- See Note [Occurrence analysis for join points]+           , occ_join_points :: !JoinPointInfo+    }++type JoinPointInfo = IdEnv OccInfoEnv++-----------------------------+{- Note [OccEncl]+~~~~~~~~~~~~~~~~~+OccEncl is used to control whether to inline into constructor arguments.++* OccRhs: consider+     let p = <blah> in+     let x = Just p+     in ...case p of ...++  Here `p` occurs syntactically once, but we want to mark it as InsideLam+  to stop `p` inlining.  We want to leave the x-binding as a constructor+  applied to variables, so that the Simplifier can simplify that inner `case`.++  The OccRhs just tells occAnalApp to mark occurrences in constructor args++* OccScrut: consider (case x of ...).  Here we want to give `x` OneOcc+  with "interesting context" field int_cxt = True.  The OccScrut tells+  occAnalApp (which deals with lone variables too) when to set this field+  to True.+-}++data OccEncl -- See Note [OccEncl]+  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda+  | OccScrut       -- Scrutintee of a case+  | OccVanilla     -- Everything else++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccScrut   = text "occScrut"+  ppr OccVanilla = text "occVanilla"++-- See Note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: OccEnv+initOccEnv+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []++                 -- To be conservative, we say that all+                 -- inlines and rules are active+           , occ_unf_act   = \_ -> True+           , occ_rule_act  = \_ -> True++           , occ_join_points = emptyVarEnv+           , occ_bs_env = emptyVarEnv+           , occ_bs_rng = emptyVarSet }++noBinderSwaps :: OccEnv -> Bool+noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env++setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv+setScrutCtxt !env alts+  = setNonTailCtxt encl env+  where+    encl | interesting_alts = OccScrut+         | otherwise        = OccVanilla++    interesting_alts = case alts of+                         []    -> False+                         [alt] -> not (isDefaultAlt alt)+                         _     -> True+     -- 'interesting_alts' is True if the case has at least one+     -- non-default alternative.  That in turn influences+     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!++{- Note [The OccEnv for a right hand side]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we create the OccEnv for a RHS (in mkRhsOccEnv)?++For a non-join point binding, x = rhs++  * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles++  * occ_join_points: zap them!++  * occ_one_shots: initialise from the idDemandInfo;+    see Note [Sources of one-shot information]++For a join point binding,  j x = rhs++  * occ_encl: Consider+       x = e+       join j = Just x+    We want to inline x into j right away, so we don't want to give the join point+    a OccRhs (#14137); we want OccVanilla.  It's not a huge deal, because the+    FloatIn pass knows to float into join point RHSs; and the simplifier does not+    float things out of join point RHSs.  But it's a simple, cheap thing to do.++  * occ_join_points: no need to zap.++  * occ_one_shots: we start with one-shot-info from the context, which indeed+    applies to the /body/ of the join point, after walking past the binders.+    So we add to the front a OneShotInfo for each value-binder of the join+    point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point+    binders caused #25096.)++    For the join point binders themselves, of a /non-recursive/ join point,+    we make the binder a OneShotLam.  Again see `extendOneShotsForJoinPoint`.++    These one-shot infos then get attached to the binder by `occAnalLamTail`.+-}++setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv+setNonTailCtxt ctxt !env+  = env { occ_encl        = ctxt+        , occ_one_shots   = []+        , occ_join_points = zapJoinPointInfo (occ_join_points env) }++setTailCtxt :: OccEnv -> OccEnv+setTailCtxt !env = env { occ_encl = OccVanilla }+    -- Preserve occ_one_shots, occ_join points+    -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):++mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv+-- See Note [The OccEnv for a right hand side]+-- For a join point:+--   - Keep occ_one_shots, occ_joinPoints from the context+--   - But push enough OneShotInfo onto occ_one_shots to account+--     for the join-point value binders+--   - Set occ_encl to OccVanilla+-- For non-join points+--   - Zap occ_one_shots and occ_join_points+--   - Set occ_encl to specified OccEncl+mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points })+            is_rec encl jp_hood bndr rhs+  | JoinPoint join_arity <- jp_hood+  = env { occ_encl        = OccVanilla+        , occ_one_shots   = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots+        , occ_join_points = ctxt_join_points }++  | otherwise+  = env { occ_encl        = encl+        , occ_one_shots   = argOneShots (idDemandInfo bndr)+                            -- argOneShots: see Note [Sources of one-shot information]+        , occ_join_points = zapJoinPointInfo ctxt_join_points }++zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo+-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped).+-- See (W3) of Note [Occurrence analysis for join points]+--+-- Zapping improves efficiency, slightly, if you accidentally introduce a bug,+-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you+-- might lose those uds, and that might mean we don't record all occurrencs, and+-- that means we duplicate a redex....  a very nasty bug (which I encountered!).+-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it+-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this+-- bug before it does any damage.+#ifdef DEBUG+zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info+#else+zapJoinPointInfo _       = emptyVarEnv+#endif++extendOneShotsForJoinPoint+  :: RecFlag -> JoinArity -> CoreExpr+  -> [OneShotInfo] -> [OneShotInfo]+-- Push enough OneShortInfos on the front of ctxt_one_shots+-- to account for the value lambdas of the join point+extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots+  = go join_arity rhs+  where+    -- For a /non-recursive/ join point we can mark all+    -- its join-lambda as one-shot; and it's a good idea to do so+    -- But not so for recursive ones+    os = case is_rec of+           NonRecursive -> OneShotLam+           Recursive    -> NoOneShotInfo++    go 0 _        = ctxt_one_shots+    go n (Lam b rhs)+      | isId b    = os : go (n-1) rhs+      | otherwise =      go (n-1) rhs+    go _ _        = []  -- Not enough lambdas.  This can legitimately happen.+                        -- e.g.    let j = case ... in j True+                        -- This will become an arity-1 join point after the+                        -- simplifier has eta-expanded it; but it may not have+                        -- enough lambdas /yet/. (Lint checks that JoinIds do+                        -- have enough lambdas.)++setOneShots :: OneShots -> OccEnv -> OccEnv+setOneShots os !env+  | null os   = env  -- Fast path for common case+  | otherwise = env { occ_one_shots = os }++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of+                                          OccRhs -> True+                                          _      -> False++addInScopeList :: OccEnv -> [Var]+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeList #-}+addInScopeList env bndrs thing_inside+ | null bndrs = thing_inside env  -- E.g. nullary constructors in a `case`+ | otherwise  = addInScope env bndrs thing_inside++addInScopeOne :: OccEnv -> Id+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeOne #-}+addInScopeOne env bndr = addInScope env [bndr]++addInScope :: OccEnv -> [Var]+           -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScope #-}+-- This function is called a lot, so we want to inline the fast path+-- so we don't have to allocate thing_inside and call it+-- The bndrs must include TyVars as well as Ids, because of+--     (BS3) in Note [Binder swap]+-- We do not assume that the bndrs are in scope order; in fact the+-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order++-- Fast path when the is no environment-munging to do+-- This is rather common: notably at top level, but nested too+addInScope env bndrs thing_inside+  | isEmptyVarEnv (occ_bs_env env)+  , isEmptyVarEnv (occ_join_points env)+  , WUD uds res <- thing_inside env+  = WUD (delBndrsFromUDs bndrs uds) res++addInScope env bndrs thing_inside+  = WUD uds' res+  where+    bndr_set           = mkVarSet bndrs+    !(env', bad_joins) = preprocess_env env bndr_set+    !(WUD uds res)     = thing_inside env'+    uds'               = postprocess_uds bndrs bad_joins uds++preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)+preprocess_env env@(OccEnv { occ_join_points = join_points+                           , occ_bs_rng = bs_rng_vars })+               bndr_set+  | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points)+  | otherwise = (drop_shadowed_swaps env,                       emptyVarEnv)+  where+    drop_shadowed_swaps :: OccEnv -> OccEnv+    -- See Note [The binder-swap substitution] (BS3)+    drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env })+      | isEmptyVarEnv swap_env+      = env+      | bs_rng_vars `intersectsVarSet` bndr_set+      = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }+      | otherwise+      = env { occ_bs_env = swap_env `minusUFM` bndr_fm }++    drop_shadowed_joins :: OccEnv -> OccEnv+    -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2)+    drop_shadowed_joins env = env { occ_join_points = emptyVarEnv }++    -- bad_joins is true if it would be wrong to push occ_join_points inwards+    --  (a) `bndrs` includes any of the occ_join_points+    --  (b) `bndrs` includes any variables free in the RHSs of occ_join_points+    bad_joins :: Bool+    bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points++    bndr_fm :: UniqFM Var Var+    bndr_fm = getUniqSet bndr_set++    is_bad :: Unique -> OccInfoEnv -> Bool -> Bool+    is_bad uniq join_uds rest+      = uniq `elemUniqSet_Directly` bndr_set ||+        not (bndr_fm `disjointUFM` join_uds) ||+        rest++postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails+postprocess_uds bndrs bad_joins uds+  = add_bad_joins (delBndrsFromUDs bndrs uds)+  where+    add_bad_joins :: UsageDetails -> UsageDetails+    -- Add usage info for occ_join_points that we cannot push inwards+    -- because of shadowing+    -- See Note [Occurrence analysis for join points] wrinkle (W2)+    add_bad_joins uds+       | isEmptyVarEnv bad_joins = uds+       | otherwise               = modifyUDEnv extend_with_bad_joins uds++    extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv+    extend_with_bad_joins env+       = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins++    add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv+    -- Behave like `andUDs` when adding in the bad_joins+    add_bad_join uniq join_env env+      | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env+      | otherwise                  = env++addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv+addJoinPoint env bndr rhs_uds+  | isEmptyVarEnv zeroed_form+  = env+  | otherwise+  = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }+  where+    zeroed_form = mkZeroedForm rhs_uds++mkZeroedForm :: UsageDetails -> OccInfoEnv+-- See Note [Occurrence analysis for join points] for "zeroed form"+mkZeroedForm (UD { ud_env = rhs_occs })+  = mapMaybeUFM do_one rhs_occs+  where+    do_one :: LocalOcc -> Maybe LocalOcc+    do_one (ManyOccL {})    = Nothing+    do_one occ@(OneOccL {}) = Just (occ { lo_n_br = 0 })++--------------------+transClosureFV :: VarEnv VarSet -> VarEnv VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+The "binder swap" transformation swaps occurrence of the+scrutinee of a case for occurrences of the case-binder:++ (1)  case x of b { pi -> ri }+         ==>+      case x of b { pi -> ri[b/x] }++ (2)  case (x |> co) of b { pi -> ri }+        ==>+      case (x |> co) of b { pi -> ri[b |> sym co/x] }++The substitution ri[b/x] etc is done by the occurrence analyser.+See Note [The binder-swap substitution].++There are two reasons for making this swap:++(A) It reduces the number of occurrences of the scrutinee, x.+    That in turn might reduce its occurrences to one, so we+    can inline it and save an allocation.  E.g.+      let x = factorial y in case x of b { I# v -> ...x... }+    If we replace 'x' by 'b' in the alternative we get+      let x = factorial y in case x of b { I# v -> ...b... }+    and now we can inline 'x', thus+      case (factorial y) of b { I# v -> ...b... }++(B) The case-binder b has unfolding information; in the+    example above we know that b = I# v. That in turn allows+    nested cases to simplify.  Consider+       case x of b { I# v ->+       ...(case x of b2 { I# v2 -> rhs })...+    If we replace 'x' by 'b' in the alternative we get+       case x of b { I# v ->+       ...(case b of b2 { I# v2 -> rhs })...+    and now it is trivial to simplify the inner case:+       case x of b { I# v ->+       ...(let b2 = b in rhs)...++    The same can happen even if the scrutinee is a variable+    with a cast: see Note [Case of cast]++The reason for doing these transformations /here in the occurrence+analyser/ is because it allows us to adjust the OccInfo for 'x' and+'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If instead the Simplifier replaces occurrences of x with+    occurrences of b, that will mess up b's occurrence info. That in+    turn might have consequences.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [The binder-swap substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The binder-swap is implemented by the occ_bs_env field of OccEnv.+There are two main pieces:++* Given    case x |> co of b { alts }+  we add [x :-> (b, sym co)] to the occ_bs_env environment; this is+  done by addBndrSwap.++* Then, at an occurrence of a variable, we look up in the occ_bs_env+  to perform the swap. This is done by lookupBndrSwap.++Some tricky corners:++(BS1) We do the substitution before gathering occurrence info. So in+      the above example, an occurrence of x turns into an occurrence+      of b, and that's what we gather in the UsageDetails.  It's as+      if the binder-swap occurred before occurrence analysis. See+      the computation of fun_uds in occAnalApp.++(BS2) When doing a lookup in occ_bs_env, we may need to iterate,+      as you can see implemented in lookupBndrSwap.  Why?+      Consider   case x of a { 1# -> e1; DEFAULT ->+                 case x of b { 2# -> e2; DEFAULT ->+                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}+      At the first case addBndrSwap will extend occ_bs_env with+          [x :-> a]+      At the second case we occ-anal the scrutinee 'x', which looks up+        'x in occ_bs_env, returning 'a', as it should.+      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding+         occ_bs_env = [x :-> a, a :-> b]+      At the third case we'll again look up 'x' which returns 'a'.+      But we don't want to stop the lookup there, else we'll end up with+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}+      Instead, we want iterate the lookup in addBndrSwap, to give+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}+      This makes a particular difference for case-merge, which works+      only if the scrutinee is the case-binder of the immediately enclosing+      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils+      See #19581 for the bug report that showed this up.++(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,+      and we encounter:+         (i) \x. blah+             Here we want to delete the x-binding from occ_bs_env++         (ii) \b. blah+              This is harder: we really want to delete all bindings that+              have 'b' free in the range.  That is a bit tiresome to implement,+              so we compromise.  We keep occ_bs_rng, which is the set of+              free vars of rng(occc_bs_env).  If a binder shadows any of these+              variables, we discard all of occ_bs_env.  Safe, if a bit+              brutal.  NB, however: the simplifer de-shadows the code, so the+              next time around this won't happen.++      These checks are implemented in addInScope.+      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)+      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we+      must not replace `x` by `...a...` under /\a. ...x..., or similarly+      under a case pattern match that binds `a`.++      An alternative would be for the occurrence analyser to do cloning as+      it goes.  In principle it could do so, but it'd make it a bit more+      complicated and there is no great benefit. The simplifer uses+      cloning to get a no-shadowing situation, the care-when-shadowing+      behaviour above isn't needed for long.++(BS4) The domain of occ_bs_env can include GlobaIds.  Eg+         case M.foo of b { alts }+      We extend occ_bs_env with [M.foo :-> b].  That's fine.++(BS5) We have to apply the occ_bs_env substitution uniformly,+      including to (local) rules and unfoldings.++(BS6) For interest (only),+      see Historical Note [Care with binder-swap on dictionaries]++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++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+  instance Sing 'True  where sing = True+  instance Sing 'False where sing = False++  f :: forall a. Sing a => blah++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     dSing++Now do a binder-swap on the case-expression:++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     (wild |> sym the_co)++And now substitute `False` for `wild` (since wild=False in the False branch):++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True  |> sym the_co)+        False -> f @a     (False |> sym the_co)++And now we have a problem.  The specialiser will specialise (f @a d)a (for all+vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using+Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.++The real problem is the binder-swap.  It swaps a dictionary variable $dSing+(of kind Constraint) for a term variable wild (of kind Type).  And that is+dangerous: a dictionary is a /singleton/ type whereas a general term variable is+not.  In this particular example, Bool is most certainly not a singleton type!++Conclusion:+  for a /dictionary variable/ do not perform+  the clever cast version of the binder-swap++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+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> ...cb... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See #5028.++NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier+doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.++-}++addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv+-- See Note [The binder-swap substitution]+addBndrSwap scrut case_bndr+            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })+  | DoBinderSwap scrut_var mco <- scrutOkForBinderSwap scrut+  , scrut_var /= case_bndr+      -- Consider: case x of x { ... }+      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop+  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)+        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'+                       `unionVarSet` tyCoVarsOfMCo mco }++  | otherwise+  = env+  where+    case_bndr' = zapIdOccInfo case_bndr+                 -- See Note [Zap case binders in proxy bindings]++-- | See bBinderSwaOk.+data BinderSwapDecision+  = NoBinderSwap+  | DoBinderSwap OutVar MCoercion++scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision+-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then+--    v = e |> mco+-- See Note [Case of cast]+-- 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 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]+-- Returns an expression of the same type as Id+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr+  = case lookupVarEnv bs_env bndr of {+       Nothing           -> (Var bndr, bndr) ;+       Just (bndr1, mco) ->++    -- Why do we iterate here?+    -- See (BS2) in Note [The binder-swap substitution]+    case lookupBndrSwap env bndr1 of+      (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }++{- Historical note [Proxy let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to do the binder-swap transformation by introducing+a proxy let-binding, thus;++   case x of b { pi -> ri }+      ==>+   case x of b { pi -> let x = b in ri }++But that had two problems:++1. If 'x' is an imported GlobalId, we'd end up with a GlobalId+   on the LHS of a let-binding which isn't allowed.  We worked+   around this for a while by "localising" x, but it turned+   out to be very painful #16296,++2. In CorePrep we use the occurrence analyser to do dead-code+   elimination (see Note [Dead code in CorePrep]).  But that+   occasionally led to an unlifted let-binding+       case x of b { DEFAULT -> let x::Int# = b in ... }+   which disobeys one of CorePrep's output invariants (no unlifted+   let-bindings) -- see #5433.++Doing a substitution (via occ_bs_env) is much better.++Historical Note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical Note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+++************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.++Note [LocalOcc]+~~~~~~~~~~~~~~~+LocalOcc is used purely internally, in the occurrence analyser.  It differs from+GHC.Types.Basic.OccInfo because it has only OneOcc and ManyOcc; it does not need+IAmDead or IAmALoopBreaker.++Note that `OneOccL` doesn't meant that it occurs /syntactially/ only once; it+means that it is /used/ only once. It might occur syntactically many times.+For example, in (case x of A -> y; B -> y; C -> True),+* `y` is used only once+* but it occurs syntactically twice++-}++type OccInfoEnv = IdEnv LocalOcc  -- A finite map from an expression's+                                  -- free variables to their usage++data LocalOcc  -- See Note [LocalOcc]+     = OneOccL { lo_n_br  :: {-# UNPACK #-} !BranchCount  -- Number of syntactic occurrences+               , lo_tail  :: !TailCallInfo+                   -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)+                   -- gives NoTailCallInfo+              , lo_int_cxt :: !InterestingCxt }+    | ManyOccL !TailCallInfo++instance Outputable LocalOcc where+  ppr (OneOccL { lo_n_br = n, lo_tail = tci })+    = text "OneOccL" <> braces (ppr n <> comma <> ppr tci)+  ppr (ManyOccL tci) = text "ManyOccL" <> braces (ppr tci)++localTailCallInfo :: LocalOcc -> TailCallInfo+localTailCallInfo (OneOccL  { lo_tail = tci }) = tci+localTailCallInfo (ManyOccL tci)               = tci++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_tail    :: !ZappedSet   -- zap tail-call info for these+       }+  -- INVARIANT: All three zapped sets are subsets of ud_env++instance Outputable UsageDetails where+  ppr ud@(UD { ud_env = env, ud_z_tail = z_tail })+    = text "UD" <+> (braces $ fsep $ punctuate comma $+      [ ppr uq <+> text ":->" <+> ppr (lookupOccInfoByUnique ud uq)+      | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ])+      $$ nest 2 (text "ud_z_tail" <+> ppr z_tail)+    where+      do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]+      do_one uniq occ occs = (uniq, occ) : occs++---------------------+-- | TailUsageDetails captures the result of applying 'occAnalLamTail'+--   to a function `\xyz.body`. The TailUsageDetails pairs together+--   * the number of lambdas (including type lambdas: a JoinArity)+--   * UsageDetails for the `body` of the lambda, unadjusted by `adjustTailUsage`.+-- If the binding turns out to be a join point with the indicated join+-- arity, this unadjusted usage details is just what we need; otherwise we+-- need to discard tail calls. That's what `adjustTailUsage` does.+data TailUsageDetails = TUD !JoinArity !UsageDetails++instance Outputable TailUsageDetails where+  ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds++---------------------+data WithUsageDetails     a = WUD  !UsageDetails     !a+data WithTailUsageDetails a = WTUD !TailUsageDetails !a++-------------------+-- UsageDetails API++andUDs, orUDs+        :: UsageDetails -> UsageDetails -> UsageDetails+andUDs = combineUsageDetailsWith andLocalOcc+orUDs  = combineUsageDetailsWith orLocalOcc++mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc !env id int_cxt arity+  | not (isLocalId id)+  = emptyDetails++  | Just join_uds <- lookupVarEnv (occ_join_points env) id+  = -- See Note [Occurrence analysis for join points]+    assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $+       -- We only put non-empty join-points into occ_join_points+    mkSimpleDetails (extendVarEnv join_uds id occ)++  | otherwise+  = mkSimpleDetails (unitVarEnv id occ)++  where+    occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt+                  , lo_tail = AlwaysTailCalled arity }++-- Add several occurrences, assumed not to be tail calls+add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv+add_many_occ v env | isId v    = extendVarEnv env v (ManyOccL NoTailCallInfo)+                   | otherwise = env+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++addManyOccs :: UsageDetails -> VarSet -> UsageDetails+addManyOccs uds var_set+  | isEmptyVarSet var_set = uds+  | otherwise             = uds { ud_env = add_to (ud_env uds) }+  where+    add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set+    -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes++addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails+-- Add any CoVars free in the type of a lambda-binder+-- See Note [Gather occurrences of coercion variables]+addLamCoVarOccs uds bndrs+  = foldr add uds bndrs+  where+    add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr)++emptyDetails :: UsageDetails+emptyDetails = mkSimpleDetails emptyVarEnv++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env++mkSimpleDetails :: OccInfoEnv -> UsageDetails+mkSimpleDetails env = UD { ud_env       = env+                         , ud_z_many    = emptyVarEnv+                         , ud_z_in_lam  = emptyVarEnv+                         , ud_z_tail    = emptyVarEnv }++modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails+modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }++delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails+-- Delete these binders from the UsageDetails+delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many+                          , ud_z_in_lam  = z_in_lam, ud_z_tail = z_tail })+  = UD { ud_env       = env      `delVarEnvList` bndrs+       , ud_z_many    = z_many   `delVarEnvList` bndrs+       , ud_z_in_lam  = z_in_lam `delVarEnvList` bndrs+       , ud_z_tail    = z_tail   `delVarEnvList` bndrs }++markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail+  :: UsageDetails -> UsageDetails+markAllMany      ud@(UD { ud_env = env }) = ud { ud_z_many   = env }+markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }+markAllNonTail   ud@(UD { ud_env = env }) = ud { ud_z_tail   = env }+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo++markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails++markAllInsideLamIf  True  ud = markAllInsideLam ud+markAllInsideLamIf  False ud = ud++markAllNonTailIf True  ud = markAllNonTail ud+markAllNonTailIf False ud = ud++lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo+lookupTailCallInfo uds id+  | UD { ud_z_tail = z_tail, ud_env = env } <- uds+  , not (id `elemVarEnv` z_tail)+  , Just occ <- lookupVarEnv env id+  = localTailCallInfo occ+  | otherwise+  = NoTailCallInfo++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env++restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet+restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)+                        -> UsageDetails -> UsageDetails -> UsageDetails+{-# INLINE combineUsageDetailsWith #-}+combineUsageDetailsWith plus_occ_info+    uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })+    uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })+  | isEmptyVarEnv env1 = uds2+  | isEmptyVarEnv env2 = uds1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2+       , ud_z_many    = plusVarEnv z_many1   z_many2+       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2+       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }++lookupLetOccInfo :: UsageDetails -> Id -> OccInfo+-- Don't use locally-generated occ_info for exported (visible-elsewhere)+-- things.  Instead just give noOccInfo.+-- NB: setBinderOcc will (rightly) erase any LoopBreaker info;+--     we are about to re-generate it and it shouldn't be "sticky"+lookupLetOccInfo ud id+ | isExportedId id = noOccInfo+ | otherwise       = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfo :: UsageDetails -> Id -> OccInfo+lookupOccInfo ud id = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo+lookupOccInfoByUnique (UD { ud_env       = env+                          , ud_z_many    = z_many+                          , ud_z_in_lam  = z_in_lam+                          , ud_z_tail    = z_tail })+                  uniq+  = case lookupVarEnv_Directly env uniq of+      Nothing -> IAmDead+      Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt+                    , lo_tail = tail_info })+          | uniq `elemVarEnvByKey`z_many+          -> ManyOccs { occ_tail = mk_tail_info tail_info }+          | otherwise+          -> OneOcc { occ_in_lam  = in_lam+                    , occ_n_br    = n_br+                    , occ_int_cxt = int_cxt+                    , occ_tail    = mk_tail_info tail_info }+         where+           in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam+                  | otherwise                       = NotInsideLam++      Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info }+  where+    mk_tail_info ti+        | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo+        | otherwise                     = ti++++-------------------+-- See Note [Adjusting right-hand sides]++adjustNonRecRhs :: JoinPointHood+                -> WithTailUsageDetails CoreExpr+                -> WithUsageDetails CoreExpr+-- ^ This function concentrates shared logic between occAnalNonRecBind and the+-- AcyclicSCC case of occAnalRec.+-- It returns the adjusted rhs UsageDetails combined with the body usage+adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)+  = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs+++adjustTailUsage :: JoinPointHood+                -> WithTailUsageDetails CoreExpr    -- Rhs usage, AFTER occAnalLamTail+                -> UsageDetails+adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)+  = -- c.f. occAnal (Lam {})+    markAllInsideLamIf (not one_shot) $+    markAllNonTailIf (not exact_join) $+    uds+  where+    one_shot   = isOneShotFun rhs+    exact_join = mb_join_arity == JoinPoint rhs_ja++adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails+adjustTailArity mb_rhs_ja (TUD ja usage)+  = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails        -- Of scope+              -> [Id]                -- Binders+              -> [IdWithOccInfo]     -- Tagged binders+tagLamBinders usage binders+  = map (tagLamBinder usage) binders++tagLamBinder :: UsageDetails       -- Of scope+             -> Id                 -- Binder+             -> IdWithOccInfo      -- Tagged binders+-- Used for lambda and case binders+-- No-op on TyVars+-- A lambda binder never has an unfolding, so no need to look for that+tagLamBinder usage bndr+  = setBinderOcc (markNonTail occ) bndr+      -- markNonTail: don't try to make an argument into a join point+  where+    occ = lookupOccInfo usage bndr++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> OccInfo                -- Of scope+                -> CoreBndr               -- Binder+                -> (IdWithOccInfo, JoinPointHood)  -- Tagged binder+-- No-op on TyVars+-- Precondition: OccInfo is not IAmDead+tagNonRecBinder lvl occ bndr+  | okForJoinPoint lvl bndr tail_call_info+  , AlwaysTailCalled ar <- tail_call_info+  = (setBinderOcc occ bndr,        JoinPoint ar)+  | otherwise+  = (setBinderOcc zapped_occ bndr, NotJoinPoint)+ where+    tail_call_info = tailCallInfo occ+    zapped_occ     = markNonTail occ++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [NodeDetails]+              -> WithUsageDetails       -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo]       -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds details_s+ = let+     bndrs = map nd_bndr details_s++     -- 1. See Note [Join arity prediction based on joinRhsArity]+     --    Determine possible join-point-hood of whole group, by testing for+     --    manifest join arity M.+     --    This (re-)asserts that makeNode had made tuds for that same arity M!+     unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s+     test_manifest_arity ND{nd_rhs = WTUD tuds rhs}+       = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds++     will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs++     mb_join_arity :: Id -> JoinPointHood+     -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]+     -- This is the source O+     mb_join_arity bndr+         -- Can't use willBeJoinId_maybe here because we haven't tagged+         -- the binder yet (the tag depends on these adjustments!)+       | will_be_joins+       , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr+       = JoinPoint arity+       | otherwise+       = assert (not will_be_joins) -- Should be AlwaysTailCalled if+         NotJoinPoint               -- we are making join points!++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds+                     -- Matching occAnalLamTail in makeNode+                 | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ]++     -- 3. Compute final usage details from adjusted RHS details+     adj_uds = foldr andUDs body_uds rhs_udss'++     -- 4. Tag each binder with its adjusted details+     bndrs'    = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr+                 | bndr <- bndrs ]++   in+   WUD adj_uds bndrs'++setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr+setBinderOcc occ_info bndr+  | isTyVar bndr               = bndr+  | occ_info == idOccInfo bndr = bndr+  | otherwise                  = setIdOccInfo bndr occ_info++-- | Decide whether some bindings should be made into join points or not, based+-- on its occurrences. This is+-- Returns `False` if they can't be join points. Note that it's an+-- all-or-nothing decision, as if multiple binders are given, they're+-- assumed to be mutually recursive.+--+-- It must, however, be a final decision. If we say `True` for 'f',+-- and then subsequently decide /not/ make 'f' into a join point, then+-- the decision about another binding 'g' might be invalidated if (say)+-- 'f' tail-calls 'g'.+--+-- See Note [Invariants on join points] in "GHC.Core".+decideRecJoinPointHood :: TopLevelFlag -> UsageDetails+                       -> [CoreBndr] -> Bool+decideRecJoinPointHood lvl usage bndrs+  = all ok bndrs  -- Invariant 3: Either all are join points or none are+  where+    ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)++okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool+    -- See Note [Invariants on join points]; invariants cited by number below.+    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.+okForJoinPoint lvl bndr tail_call_info+  | isJoinId bndr        -- A current join point should still be one!+  = warnPprTrace lost_join "Lost join point" lost_join_doc $+    True+  | valid_join+  = True+  | otherwise+  = False+  where+    valid_join | NotTopLevel <- lvl+               , AlwaysTailCalled arity <- tail_call_info++               , -- Invariant 1 as applied to LHSes of rules+                 all (ok_rule arity) (idCoreRules bndr)++                 -- Invariant 2a: stable unfoldings+                  -- See Note [Join points and INLINE pragmas]+               , ok_unfolding arity (realIdUnfolding bndr)++                 -- Invariant 4: Satisfies polymorphism rule+               , isValidJoinPointType arity (idType bndr)+               = True+               | otherwise+               = False++    lost_join | JoinPoint ja <- idJoinPointHood bndr+              = not valid_join ||+                (case tail_call_info of  -- Valid join but arity differs+                   AlwaysTailCalled ja' -> ja /= ja'+                   _                    -> False)+              | otherwise = False++    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans+    ok_rule join_arity (Rule { ru_args = args })+      = args `lengthIs` join_arity+        -- Invariant 1 as applied to LHSes of rules++    -- ok_unfolding returns False if we should /not/ convert a non-join-id+    -- into a join-id, even though it is AlwaysTailCalled+    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })+      = not (isStableSource src && join_arity > joinRhsArity rhs)+    ok_unfolding _ (DFunUnfolding {})+      = False+    ok_unfolding _ _+      = True++    lost_join_doc+      = vcat [ text "bndr:" <+> ppr bndr+             , text "tc:" <+> ppr tail_call_info+             , text "rules:" <+> ppr (idCoreRules bndr)+             , case tail_call_info of+                 AlwaysTailCalled arity ->+                    vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr))+                         , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ]+                 _ -> empty ]++{- Note [Join points and INLINE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = let g = \x. not  -- Arity 1+             {-# INLINE g #-}+         in case x of+              A -> g True True+              B -> g True False+              C -> blah2++Here 'g' is always tail-called applied to 2 args, but the stable+unfolding captured by the INLINE pragma has arity 1.  If we try to+convert g to be a join point, its unfolding will still have arity 1+(since it is stable, and we don't meddle with stable unfoldings), and+Lint will complain (see Note [Invariants on join points], (2a), in+GHC.Core.  #13413.++Moreover, since g is going to be inlined anyway, there is no benefit+from making it a join point.++If it is recursive, and uselessly marked INLINE, this will stop us+making it a join point, which is annoying.  But occasionally+(notably in class methods; see Note [Instances and loop breakers] in+GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion+unravels; so ignoring INLINE pragmas on recursive things isn't good+either.++See Invariant 2a of Note [Invariants on join points] in GHC.Core+++************************************************************************+*                                                                      *+\subsection{Operations over OccInfo}+*                                                                      *+************************************************************************+-}++markNonTail :: OccInfo -> OccInfo+markNonTail IAmDead = IAmDead+markNonTail occ     = occ { occ_tail = NoTailCallInfo }++andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+andLocalOcc occ1 occ2 = ManyOccL (tci1 `andTailCallInfo` tci2)+  where+    !tci1 = localTailCallInfo occ1+    !tci2 = localTailCallInfo occ2++orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+-- (orLocalOcc occ1 occ2) is used+-- when combining occurrence info from branches of a case+orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 })+           (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 })+  = OneOccL { lo_n_br    = nbr1 + nbr2+            , lo_int_cxt = int_cxt1 `mappend` int_cxt2+            , lo_tail    = tci1 `andTailCallInfo` tci2 }+orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2  andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)
compiler/GHC/Core/Opt/Simplify.hs view
@@ -17,7 +17,8 @@ import GHC.Core.Utils   ( mkTicks, stripTicksTop ) import GHC.Core.Lint    ( LintPassResultConfig, dumpPassResult, lintPassResult ) import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules )-import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding )+import GHC.Core.Opt.Simplify.Utils  ( activeRule )+import GHC.Core.Opt.Simplify.Inline ( activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Stats ( simplCountN )@@ -43,10 +44,6 @@ import Control.Monad import Data.Foldable ( for_ ) -#if __GLASGOW_HASKELL__ <= 810-import GHC.Utils.Panic ( panic )-#endif- {- ************************************************************************ *                                                                      *@@ -202,7 +199,7 @@                  -- Subtract 1 from iteration_no to get the                 -- number of iterations we actually completed-        return ( "Simplifier baled out", iteration_no - 1+        return ( "Simplifier bailed out", iteration_no - 1                , totalise counts_so_far                , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) @@ -285,9 +282,6 @@                 -- Loop            do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1            } }-#if __GLASGOW_HASKELL__ <= 810-      | otherwise = panic "do_iteration"-#endif       where         -- Remember the counts_so_far are reversed         totalise :: [SimplCount] -> SimplCount
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -8,29 +8,31 @@  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,+        mkSimplEnv, extendIdSubst, extendCvIdSubst,         extendTvSubst, extendCvSubst,         zapSubstEnv, setSubstEnv, bumpCaseDepth,         getInScope, setInScopeFromE, setInScopeFromF,         setInScopeSet, modifyInScope, addNewInScopeIds,         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@@ -58,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@@ -84,7 +87,6 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.List ( intersperse, mapAccumL )@@ -155,6 +157,17 @@     | Set by user                | SimplMode    | TopEnvConfig    |     | Computed on initialization | SimplEnv     | SimplTopEnv     | +Note [Inline depth]+~~~~~~~~~~~~~~~~~~~+When we inline an /already-simplified/ unfolding, we+* Zap the substitution environment; the inlined thing is an OutExpr+* Bump the seInlineDepth in the SimplEnv+Both these tasks are done in zapSubstEnv.++The seInlineDepth tells us how deep in inlining we are.  Currently,+seInlineDepth is used for just one purpose: when we encounter a+coercion we don't apply optCoercion to it if seInlineDepth>0.+Reason: it has already been optimised once, no point in doing so again. -}  data SimplEnv@@ -184,9 +197,26 @@         -- They are all OutVars, and all bound in this module       , seInScope   :: !InScopeSet       -- OutVars only -      , seCaseDepth :: !Int  -- Depth of multi-branch case alternatives+      , seCaseDepth   :: !Int  -- Depth of multi-branch case alternatives++      , seInlineDepth :: !Int  -- 0 initially, 1 when we inline an already-simplified+                               -- unfolding, and simplify again; and so on+                               -- 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) @@ -220,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) @@ -277,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) @@ -377,7 +401,7 @@  -- | A substitution result. data SimplSR-  = DoneEx OutExpr (Maybe JoinArity)+  = DoneEx OutExpr JoinPointHood        -- If  x :-> DoneEx e ja   is in the SimplIdSubst        -- then replace occurrences of x by e        -- and  ja = Just a <=> x is a join-point of arity a@@ -402,8 +426,8 @@   ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e     where       pp_mj = case mj of-                Nothing -> empty-                Just n  -> parens (int n)+                NotJoinPoint -> empty+                JoinPoint n  -> parens (int n)    ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,                                 ppr (filter_env tv), ppr (filter_env id) -}]@@ -492,14 +516,15 @@  mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv mkSimplEnv mode fam_envs-  = SimplEnv { seMode      = mode-             , seFamEnvs   = fam_envs-             , seInScope   = init_in_scope-             , seTvSubst   = emptyVarEnv-             , seCvSubst   = emptyVarEnv-             , seIdSubst   = emptyVarEnv-             , seRecIds    = emptyUnVarSet-             , seCaseDepth = 0 }+  = SimplEnv { seMode        = mode+             , seFamEnvs     = fam_envs+             , seInScope     = init_in_scope+             , seTvSubst     = emptyVarEnv+             , seCvSubst     = emptyVarEnv+             , seIdSubst     = emptyVarEnv+             , seRecIds      = emptyUnVarSet+             , seCaseDepth   = 0+             , seInlineDepth = 0 }         -- The top level "enclosing CC" is "SUBSUMED".  init_in_scope :: InScopeSet@@ -535,6 +560,9 @@ bumpCaseDepth :: SimplEnv -> SimplEnv bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 } +reSimplifying :: SimplEnv -> Bool+reSimplifying (SimplEnv { seInlineDepth = n }) = n>0+ --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res@@ -551,6 +579,10 @@   = assert (isCoVar var) $     env {seCvSubst = extendVarEnv csubst var co} +extendCvIdSubst :: SimplEnv -> Id -> OutExpr -> SimplEnv+extendCvIdSubst env bndr (Coercion co) = extendCvSubst env bndr co+extendCvIdSubst env bndr rhs           = extendIdSubst env bndr (DoneEx rhs NotJoinPoint)+ --------------------- getInScope :: SimplEnv -> InScopeSet getInScope env = seInScope env@@ -620,7 +652,12 @@  --------------------- zapSubstEnv :: SimplEnv -> SimplEnv-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}+-- See Note [Inline depth]+-- We call zapSubstEnv precisely when we are about to+-- simplify an already-simplified term+zapSubstEnv env@(SimplEnv { seInlineDepth = n })+  = env { seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv+        , seInlineDepth = n+1 }  setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }@@ -1237,34 +1274,47 @@ ************************************************************************ -} -getSubst :: SimplEnv -> Subst-getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env-                      , seCvSubst = cv_env })-  = mkSubst in_scope tv_env cv_env emptyIdSubstEnv+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@@ -1280,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/Inline.hs view
@@ -0,0 +1,751 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998++This module contains inlining logic used by the simplifier.+-}++++module GHC.Core.Opt.Simplify.Inline (+        -- * Cheap and cheerful inlining checks.+        couldBeSmallEnoughToInline,+        smallEnoughToInline, activeUnfolding,++        -- * The smart inlining decisions are made by callSiteInline+        callSiteInline, CallCtxt(..),+    ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core.Opt.Simplify.Env++import GHC.Core+import GHC.Core.Unfold+import GHC.Core.FVs( exprFreeIds )++import GHC.Types.Id+import GHC.Types.Var.Env( InScopeSet, lookupInScope )+import GHC.Types.Var.Set+import GHC.Types.Basic  ( Arity, RecFlag(..), isActive )+import GHC.Utils.Logger+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Name++import Data.List (isPrefixOf)++{-+************************************************************************+*                                                                      *+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}+*                                                                      *+************************************************************************++We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that+we ``couldn't possibly use'' on the other side.  Can be overridden w/+flaggery.  Just the same as smallEnoughToInline, except that it has no+actual arguments.+-}++couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool+couldBeSmallEnoughToInline opts threshold rhs+  = case sizeExpr opts threshold [] body of+       TooBig -> False+       _      -> True+  where+    (_, body) = collectBinders rhs++----------------+smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool+smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance})+  = case guidance of+       UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts+       UnfWhen {} -> True+       UnfNever   -> False+smallEnoughToInline _ _+  = False++{-+************************************************************************+*                                                                      *+\subsection{callSiteInline}+*                                                                      *+************************************************************************++This is the key function.  It decides whether to inline a variable at a call site++callSiteInline is used at call sites, so it is a bit more generous.+It's a very important function that embodies lots of heuristics.+A non-WHNF can be inlined if it doesn't occur inside a lambda,+and occurs exactly once or+    occurs once in each branch of a case and is small++If the thing is in WHNF, there's no danger of duplicating work,+so we can inline if it occurs once, or is small++NOTE: we don't want to inline top-level functions that always diverge.+It just makes the code bigger.  Tt turns out that the convenient way to prevent+them inlining is to give them a NOINLINE pragma, which we do in+StrictAnal.addStrictnessInfoToTopId+-}++callSiteInline :: SimplEnv+               -> Logger+               -> Id                    -- The Id+               -> Bool                  -- True if there are no arguments at all (incl type args)+               -> [ArgSummary]          -- One for each value arg; True if it is interesting+               -> CallCtxt              -- True <=> continuation is interesting+               -> Maybe CoreExpr        -- Unfolding, if any+callSiteInline env logger id lone_variable arg_infos cont_info+  = case idUnfolding id of+      -- idUnfolding checks for loop-breakers, returning NoUnfolding+      -- Things with an INLINE pragma may have an unfolding *and*+      -- be a loop breaker  (maybe the knot is not yet untied)+        CoreUnfolding { uf_tmpl = unf_template+                      , uf_cache = unf_cache+                      , uf_guidance = guidance }+          | active_unf -> tryUnfolding env logger id lone_variable+                                    arg_infos cont_info unf_template+                                    unf_cache guidance+          | otherwise -> traceInline logger uf_opts id "Inactive unfolding:" (ppr id) Nothing+        NoUnfolding      -> Nothing+        BootUnfolding    -> Nothing+        OtherCon {}      -> Nothing+        DFunUnfolding {} -> Nothing     -- Never unfold a DFun+  where+    uf_opts    = seUnfoldingOpts env+    active_unf = activeUnfolding (seMode env) id++activeUnfolding :: SimplMode -> Id -> Bool+activeUnfolding mode id+  | isCompulsoryUnfolding (realIdUnfolding id)+  = True   -- Even sm_inline can't override compulsory unfoldings+  | otherwise+  = isActive (sm_phase mode) (idInlineActivation id)+  && sm_inline mode+      -- `or` isStableUnfolding (realIdUnfolding id)+      -- Inline things when+      --  (a) they are active+      --  (b) sm_inline says so, except that for stable unfoldings+      --                         (ie pragmas) we inline anyway++-- | Report the inlining of an identifier's RHS to the user, if requested.+traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a+traceInline logger opts inline_id str doc result+  -- We take care to ensure that doc is used in only one branch, ensuring that+  -- the simplifier can push its allocation into the branch. See Note [INLINE+  -- conditional tracing utilities].+  | enable    = logTraceMsg logger str doc result+  | otherwise = result+  where+    enable+      | logHasDumpFlag logger Opt_D_dump_verbose_inlinings+      = True+      | Just prefix <- unfoldingReportPrefix opts+      = prefix `isPrefixOf` occNameString (getOccName inline_id)+      | otherwise+      = False+{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities]++{- Note [Avoid inlining into deeply nested cases]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Also called "exponential inlining".++Consider a function f like this: (#18730)++  f arg1 arg2 =+    case ...+      ... -> g arg1+      ... -> g arg2++This function is small. So should be safe to inline.+However sometimes this doesn't quite work out like that.+Consider this code:++    f1 arg1 arg2 ... = ...+        case _foo of+          alt1 -> ... f2 arg1 ...+          alt2 -> ... f2 arg2 ...++    f2 arg1 arg2 ... = ...+        case _foo of+          alt1 -> ... f3 arg1 ...+          alt2 -> ... f3 arg2 ...++    f3 arg1 arg2 ... = ...++    ... repeats up to n times. And then f1 is+    applied to some arguments:++    foo = ... f1 <interestingArgs> ...++Initially f2..fn are not interesting to inline so we don't.  However we see+that f1 is applied to interesting args.  So it's an obvious choice to inline+those:++    foo = ...+          case _foo of+            alt1 -> ... f2 <interestingArg> ...+            alt2 -> ... f2 <interestingArg> ...++As a result we go and inline f2 both mentions of f2 in turn are now applied to+interesting arguments and f2 is small:++    foo = ...+          case _foo of+            alt1 -> ... case _foo of+                alt1 -> ... f3 <interestingArg> ...+                alt2 -> ... f3 <interestingArg> ...++            alt2 -> ... case _foo of+                alt1 -> ... f3 <interestingArg> ...+                alt2 -> ... f3 <interestingArg> ...++The same thing happens for each binding up to f_n, duplicating the amount of inlining+done in each step. Until at some point we are either done or run out of simplifier+ticks/RAM. This pattern happened #18730.++To combat this we introduce one more heuristic when weighing inlining decision.+We keep track of a "case-depth". Which increases each time we look inside a case+expression with more than one alternative.++We then apply a penalty to inlinings based on the case-depth at which they would+be inlined. Bounding the number of inlinings in such a scenario.++The heuristic can be tuned in two ways:++* We can ignore the first n levels of case nestings for inlining decisions using+  -funfolding-case-threshold.++* The penalty grows linear with the depth. It's computed as+     size*(depth-threshold)/scaling.+  Scaling can be set with -funfolding-case-scaling.++Reflections and wrinkles++* See also Note [Do not add unfoldings to join points at birth] in+  GHC.Core.Opt.Simplify.Iteration++* The total case depth is really the wrong thing; it will inhibit inlining of a+  local function, just because there is some giant case nest further out.  What we+  want is the /difference/ in case-depth between the binding site and the call site.+  That could be done quite easily by adding the case-depth to the Unfolding of the+  function.++* What matters more than /depth/ is total /width/; that is how many alternatives+  are in the tree.  We could perhaps multiply depth by width at each case expression.++* There might be a case nest with many alternatives, but the function is called in+  only a handful of them.  So maybe we should ignore case-depth, and instead penalise+  funtions that are called many times -- after all, inlining them bloats code.++  But in the scenario above, we are simplifying an inlined fuction, without doing a+  global occurrence analysis each time.  So if we based the penalty on multiple+  occurences, we should /also/ add a penalty when simplifying an already-simplified+  expression.  We do track this (seInlineDepth) but currently we barely use it.++  An advantage of using occurrences+inline depth is that it'll work when no+  case expressions are involved.  See #15488.++* Test T18730 did not involve join points.  But join points are very prone to+  the same kind of thing.  For exampe in #13253, and several related tickets,+  we got an exponential blowup in code size from a program that looks like+  this.++  let j1a x = case f y     of { True -> p;   False -> q }+      j1b x = case f y     of { True -> q;   False -> p }+      j2a x = case f (y+1) of { True -> j1a x; False -> j1b x}+      j2b x = case f (y+1) of { True -> j1b x; False -> j1a x}+      ...+  in case f (y+10) of { True -> j10a 7; False -> j10b 8 }++  The first danger is this: in Simplifier iteration 1 postInlineUnconditionally+  inlines the last functions, j10a and j10b (they are both small).  Now we have+  two calls to j9a and two to j9b.  In the next Simplifer iteration,+  postInlineUnconditionally inlines all four of these calls, leaving four calls+  to j8a and j8b. Etc.++  Happily, this probably /won't/ happen because the Simplifier works top down, so it'll+  inline j1a/j1b into j2a/j2b, which will make the latter bigger; so the process+  will stop.  But we still need to stop the inline cascade described at the head+  of this Note.++Some guidance on setting these defaults:++* A low threshold (<= 2) is needed to prevent exponential cases from spiraling out of+  control. We picked 2 for no particular reason.++* Scaling the penalty by any more than 30 means the reproducer from+  T18730 won't compile even with reasonably small values of n. Instead+  it will run out of runs/ticks. This means to positively affect the reproducer+  a scaling <= 30 is required.++* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks.+  (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps)++* A scaling of >= 25 showed no regressions on nofib. However it showed a number of+  (small) regression for compiler perf benchmarks.++The end result is that we are settling for a scaling of 30, with a threshold of 2.+This gives us minimal compiler perf regressions. No nofib runtime regressions and+will still avoid this pattern sometimes. This is a "safe" default, where we err on+the side of compiler blowup instead of risking runtime regressions.++For cases where the default falls short the flag can be changed to allow+more/less inlining as needed on a per-module basis.++-}++tryUnfolding :: SimplEnv -> Logger -> Id -> Bool -> [ArgSummary] -> CallCtxt+             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance+             -> Maybe CoreExpr+tryUnfolding env logger id lone_variable arg_infos+             cont_info unf_template unf_cache guidance+ = case guidance of+     UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing++     UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }+        | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts)+                -- See Note [INLINE for small functions] (3)+        -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template)+        | otherwise+        -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing+        where+          some_benefit = calc_some_benefit uf_arity True+          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)++     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }+        | isJoinId id, small_enough         -> inline_join_point+        | unfoldingVeryAggressive opts      -> yes+        | is_wf, some_benefit, small_enough -> yes+        | otherwise                         -> no+        where+          yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True)  (Just unf_template)+          no  = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing++          some_benefit = calc_some_benefit (length arg_discounts) False++          -- depth_penalty: see Note [Avoid inlining into deeply nested cases]+          depth_threshold = unfoldingCaseThreshold opts+          depth_scaling   = unfoldingCaseScaling opts+          depth_penalty | case_depth <= depth_threshold = 0+                        | otherwise = (size * (case_depth - depth_threshold)) `div` depth_scaling++          adjusted_size = size + depth_penalty - discount+          small_enough = adjusted_size <= unfoldingUseThreshold opts+          discount = computeDiscount arg_discounts res_discount arg_infos cont_info++          extra_doc = vcat [ ppWhen (isJoinId id) $+                             text "join" <+> fsep [ ppr (v, hasCoreUnfolding (idUnfolding v)+                                                        , fmap (isEvaldUnfolding . idUnfolding) (lookupInScope in_scope v)+                                                        , is_more_evald in_scope v)+                                                  | v <- vselems (exprFreeIds unf_template) ]+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "adjusted size =" <+> int adjusted_size ]++          inline_join_point  -- See Note [Inlining join points]+            | or (zipWith scrut_arg arg_discounts arg_infos) = yes+            | anyVarSet (is_more_evald in_scope) $+              exprFreeIds unf_template                       = yes+            | otherwise                                      = no+          -- scrut_arg is True if the function body has a discount and the arg is a value+          scrut_arg disc ValueArg = disc > 0+          scrut_arg _    _        = False++  where+    opts         = seUnfoldingOpts env+    case_depth   = seCaseDepth env+    inline_depth = seInlineDepth env+    in_scope     = seInScope env++    -- Unpack the UnfoldingCache lazily because it may not be needed, and all+    -- its fields are strict; so evaluating unf_cache at all forces all the+    -- isWorkFree etc computations to take place.  That risks wasting effort for+    -- Ids that are never going to inline anyway.+    -- See Note [UnfoldingCache] in GHC.Core+    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache++    mk_doc some_benefit extra_doc yes_or_no+      = vcat [ text "arg infos" <+> ppr arg_infos+             , text "interesting continuation" <+> ppr cont_info+             , text "some_benefit" <+> ppr some_benefit+             , text "is exp:" <+> ppr is_exp+             , text "is work-free:" <+> ppr is_wf+             , text "guidance" <+> ppr guidance+             , text "case depth =" <+> int case_depth+             , text "inline depth =" <+> int inline_depth+             , extra_doc+             , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]++    ctx = log_default_dump_context (logFlags logger)+    str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id)+    n_val_args = length arg_infos++           -- some_benefit is used when the RHS is small enough+           -- and the call has enough (or too many) value+           -- arguments (ie n_val_args >= arity). But there must+           -- be *something* interesting about some argument, or the+           -- result context, to make it worth inlining+    calc_some_benefit :: Arity -> Bool -> Bool   -- The Arity is the number of args+                                         -- expected by the unfolding+    calc_some_benefit uf_arity is_inline+       | not saturated = interesting_args       -- Under-saturated+                                        -- Note [Unsaturated applications]+       | otherwise = interesting_args   -- Saturated or over-saturated+                  || interesting_call+      where+        saturated      = n_val_args >= uf_arity+        over_saturated = n_val_args > uf_arity+        interesting_args = any nonTriv arg_infos+                -- NB: (any nonTriv arg_infos) looks at the+                -- over-saturated args too which is "wrong";+                -- but if over-saturated we inline anyway.++        interesting_call+          | over_saturated+          = True+          | otherwise+          = case cont_info of+              CaseCtxt   -> not (lone_variable && is_exp)  -- Note [Lone variables]+              ValAppCtxt -> True                           -- Note [Cast then apply]+              RuleArgCtxt -> uf_arity > 0  -- See Note [RHS of lets]+              DiscArgCtxt -> uf_arity > 0  -- Note [Inlining in ArgCtxt]+              RhsCtxt NonRecursive | is_inline+                          -> uf_arity > 0  -- See Note [RHS of lets]+              _other      -> False         -- See Note [Nested functions]+++vselems :: VarSet -> [Var]+vselems s = nonDetStrictFoldVarSet (\v vs -> v : vs) [] s++is_more_evald :: InScopeSet -> Id -> Bool+-- See Note [Inlining join points]+is_more_evald in_scope v+  | Just v1 <- lookupInScope in_scope v+  , idUnfolding v1 `isBetterUnfoldingThan` idUnfolding v+  = True+  | otherwise+  = False++{- Note [RHS of lets]+~~~~~~~~~~~~~~~~~~~~~+When the call is the argument of a function with a RULE, or the RHS of a let,+we are a little bit keener to inline (in tryUnfolding).  For example+     f y = (y,y,y)+     g y = let x = f y in ...(case x of (a,b,c) -> ...) ...+We'd inline 'f' if the call was in a case context, and it kind-of-is,+only we can't see it.  Also+     x = f v+could be expensive whereas+     x = case v of (a,b) -> a+is patently cheap and may allow more eta expansion.++So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a+/non-recursive/ let as not-totally-boring.  A /recursive/ let isn't+going be inlined so there is much less point.  Hence the (only reason+for the) RecFlag in RhsCtxt++We inline only if `f` has an `UnfWhen` guidance.  I found that being more eager+led to fruitless inlining.  See Note [Seq is boring] wrinkle (SB1) in+GHC.Core.Opt.Simplify.Utils.++Note [Inlining join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we /do not/ want to inline join points /even if they are small/.+See Note [Duplicating join points] in GHC.Core.Opt.Simplify.Iteration.++But, assuming it is small, there are various times when we /do/ want to+inline a (non-recursive) join point.  Namely, if either of these hold:++(1) A /scrutinised/ argument (non-zero discount) has a /ValueArg/ info.+    Inlining will give some benefit.++(2) A free variable of the RHS is+    * Is /not/ evaluated at the join point defn site+    * Is evaluated at the join point call site.+    This is the is_more_evald predicate.++(1) is fairly obvious but (2) is less so. Here is the code for `integerGT`+without (2):++  integerGt = \ (x :: Integer) (y :: Integer) ->+     join fail _ = case x of {+       IS x1 -> case y of {+           IS y1 -> case <# x1 y1  of+                      _DEFAULT -> case ==# x1 y1 of+                                    DEFAULT -> True;+                                    1#      -> False+                      1# -> False+           IP ds1 -> False+           IN ds1 -> True++       IP x1 -> case y of {+                 _DEFAULT -> True;+                 IP y1    -> case bigNatCompare x1 y1 of+                               _DEFAULT -> False;+                               GT -> True+       IN x1 -> case y of {+                  _DEFAULT -> False;+                  IN y1    -> case bigNatCompare y1 x1 of+                                _DEFAULT -> False;+                                GT -> True+     in case x of {+       _DEFAULT -> jump fail GHC.Prim.(##);+       IS x1    -> case y of {+                     _DEFAULT -> jump fail GHC.Prim.(##);+                     IS y1 -> tagToEnum# @Bool (># x1 y1)++If we inline `fail` we get /much/ better code.  The only clue is that+`x` and `y` (a) are not evaluated at the definition site, and (b) are+evaluated at the call site.  This predicate is `isBetterUnfoldingThan`.++You might think that the variable should also be /scrutinised/ in the+join-point RHS, but here are two reasons for not taking that into+account.++First, we see code somewhat like this in imaginary/wheel-sieve1:+    let x = <small thunk> in+    join $j = (x,y) in+    case z of+      A -> case x of+             P -> $j+             Q -> blah+      B -> (x,x)+      C -> True+Here `x` can't be duplicated into the branches becuase it is used+in both the join point and the A branch.  But if we inline $j we get+    let x = <small thunk> in+    case z of+      A -> case x of x'+             P -> (x', y)+             Q -> blah+      B -> x+      C -> True+and now we /can/ duplicate x into the branches, at which point:+  * it is used strictly in the A branch (evaluated, but no thunk)+  * it is used lazily in the B branch (still a thunk)+  * it is not used at all in the C branch (no thunk)++Second, spectral/treejoin gets a big win from SpecConstr due+to evaluated-ness. Something like this:+    join $j x = ...(foo fv)...+    in case fv of I# x ->+       ...  jump $j True ...+If we inline $j, SpecConstr sees a call (foo (I# x)) and specialises.++Note [Unsaturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When a call is not saturated, we *still* inline if one of the+arguments has interesting structure.  That's sometimes very important.+A good example is the Ord instance for Bool in Base:++ Rec {+    $fOrdBool =GHC.Classes.D:Ord+                 @ Bool+                 ...+                 $cmin_ajX++    $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool+    $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool+  }++But the defn of GHC.Classes.$dmmin is:++  $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a+    {- Arity: 3, HasNoCafRefs, Strictness: SLL,+       Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->+                   case @ a GHC.Classes.<= @ a $dOrd x y of wild {+                     GHC.Types.False -> y GHC.Types.True -> x }) -}++We *really* want to inline $dmmin, even though it has arity 3, in+order to unravel the recursion.+++Note [Things to watch]+~~~~~~~~~~~~~~~~~~~~~~+*   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }+    Assume x is exported, so not inlined unconditionally.+    Then we want x to inline unconditionally; no reason for it+    not to, and doing so avoids an indirection.++*   { x = I# 3; ....f x.... }+    Make sure that x does not inline unconditionally!+    Lest we get extra allocation.++Note [Nested functions]+~~~~~~~~~~~~~~~~~~~~~~~+At one time we treated a call of a non-top-level function as+"interesting" (regardless of how boring the context) in the hope+that inlining it would eliminate the binding, and its allocation.+Specifically, in the default case of interesting_call we had+   _other -> not is_top && uf_arity > 0++But actually postInlineUnconditionally does some of this and overall+it makes virtually no difference to nofib.  So I simplified away this+special case++Note [Cast then apply]+~~~~~~~~~~~~~~~~~~~~~~+Consider+   myIndex = __inline_me ( (/\a. <blah>) |> co )+   co :: (forall a. a -> a) ~ (forall a. T a)+     ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...++We need to inline myIndex to unravel this; but the actual call (myIndex a) has+no value arguments.  The ValAppCtxt gives it enough incentive to inline.++Note [Inlining in ArgCtxt]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The condition (arity > 0) here is very important, because otherwise+we end up inlining top-level stuff into useless places; eg+   x = I# 3#+   f = \y.  g x+This can make a very big difference: it adds 16% to nofib 'integer' allocs,+and 20% to 'power'.++At one stage I replaced this condition by 'True' (leading to the above+slow-down).  The motivation was test eyeball/inline1.hs; but that seems+to work ok now.++NOTE: arguably, we should inline in ArgCtxt only if the result of the+call is at least CONLIKE.  At least for the cases where we use ArgCtxt+for the RHS of a 'let', we only profit from the inlining if we get a+CONLIKE thing (modulo lets).++Note [Lone variables]+~~~~~~~~~~~~~~~~~~~~~+See also Note [Interaction of exprIsWorkFree and lone variables]+which appears below++The "lone-variable" case is important.  I spent ages messing about+with unsatisfactory variants, but this is nice.  The idea is that if a+variable appears all alone++        as an arg of lazy fn, or rhs    BoringCtxt+        as scrutinee of a case          CaseCtxt+        as arg of a fn                  ArgCtxt+AND+        it is bound to a cheap expression++then we should not inline it (unless there is some other reason,+e.g. it is the sole occurrence).  That is what is happening at+the use of 'lone_variable' in 'interesting_call'.++Why?  At least in the case-scrutinee situation, turning+        let x = (a,b) in case x of y -> ...+into+        let x = (a,b) in case (a,b) of y -> ...+and thence to+        let x = (a,b) in let y = (a,b) in ...+is bad if the binding for x will remain.++Another example: I discovered that strings+were getting inlined straight back into applications of 'error'+because the latter is strict.+        s = "foo"+        f = \x -> ...(error s)...++Fundamentally such contexts should not encourage inlining because, provided+the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the+context can ``see'' the unfolding of the variable (e.g. case or a+RULE) so there's no gain.++However, watch out:++ * Consider this:+        foo = \n. [n])  {-# INLINE foo #-}+        bar = foo 20    {-# INLINE bar #-}+        baz = \n. case bar of { (m:_) -> m + n }+   Here we really want to inline 'bar' so that we can inline 'foo'+   and the whole thing unravels as it should obviously do.  This is+   important: in the NDP project, 'bar' generates a closure data+   structure rather than a list.++   So the non-inlining of lone_variables should only apply if the+   unfolding is regarded as expandable; because that is when+   exprIsConApp_maybe looks through the unfolding.  Hence the "&&+   is_exp" in the CaseCtxt branch of interesting_call++ * Even a type application or coercion isn't a lone variable.+   Consider+        case $fMonadST @ RealWorld of { :DMonad a b c -> c }+   We had better inline that sucker!  The case won't see through it.++   For now, I'm treating treating a variable applied to types+   in a *lazy* context "lone". The motivating example was+        f = /\a. \x. BIG+        g = /\a. \y.  h (f a)+   There's no advantage in inlining f here, and perhaps+   a significant disadvantage.  Hence some_val_args in the Stop case++Note [Interaction of exprIsWorkFree and lone variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The lone-variable test says "don't inline if a case expression+scrutinises a lone variable whose unfolding is cheap".  It's very+important that, under these circumstances, exprIsConApp_maybe+can spot a constructor application. So, for example, we don't+consider+        let x = e in (x,x)+to be cheap, and that's good because exprIsConApp_maybe doesn't+think that expression is a constructor application.++In the 'not (lone_variable && is_wf)' test, I used to test is_value+rather than is_wf, which was utterly wrong, because the above+expression responds True to exprIsHNF, which is what sets is_value.++This kind of thing can occur if you have++        {-# INLINE foo #-}+        foo = let x = e in (x,x)++which Roman did.+++-}++computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt+                -> Int+computeDiscount arg_discounts res_discount arg_infos cont_info++  = 10          -- Discount of 10 because the result replaces the call+                -- so we count 10 for the function itself++    + 10 * length actual_arg_discounts+               -- Discount of 10 for each arg supplied,+               -- because the result replaces the call++    + total_arg_discount + res_discount'+  where+    actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos+    total_arg_discount   = sum actual_arg_discounts++    mk_arg_discount _        TrivArg    = 0+    mk_arg_discount _        NonTrivArg = 10+    mk_arg_discount discount ValueArg   = discount++    res_discount'+      | LT <- arg_discounts `compareLength` arg_infos+      = res_discount   -- Over-saturated+      | otherwise+      = case cont_info of+           BoringCtxt  -> 0+           CaseCtxt    -> res_discount  -- Presumably a constructor+           ValAppCtxt  -> res_discount  -- Presumably a function+           _           -> 40 `min` res_discount+                -- ToDo: this 40 `min` res_discount doesn't seem right+                --   for DiscArgCtxt it shouldn't matter because the function will+                --       get the arg discount for any non-triv arg+                --   for RuleArgCtxt we do want to be keener to inline; but not only+                --       constructor results+                --   for RhsCtxt I suppose that exposing a data con is good in general+                --   And 40 seems very arbitrary+                --+                -- res_discount can be very large when a function returns+                -- constructors; but we only want to invoke that large discount+                -- when there's a case continuation.+                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.+                -- But we want to avoid inlining large functions that return+                -- constructors into contexts that are simply "interesting"
compiler/GHC/Core/Opt/Simplify/Iteration.hs view
@@ -8,4465 +8,4805 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where--import GHC.Prelude--import GHC.Platform--import GHC.Driver.Flags--import GHC.Core-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )-import GHC.Core.TyCo.Compare( eqType )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Simplify.Utils-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutBinderSwap_maybe )-import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )-import qualified GHC.Core.Make-import GHC.Core.Coercion hiding ( substCo, substCoVar )-import GHC.Core.Reduction-import GHC.Core.Coercion.Opt    ( optCoercion )-import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )-import GHC.Core.DataCon-   ( DataCon, dataConWorkId, dataConRepStrictness-   , dataConRepArgTys, isUnboxedTupleDataCon-   , StrictnessMark (..) )-import GHC.Core.Opt.Stats ( Tick(..) )-import GHC.Core.Ppr     ( pprCoreExpr )-import GHC.Core.Unfold-import GHC.Core.Unfold.Make-import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe-                          , pushCoTyArg, pushCoValArg, exprIsDeadEnd-                          , typeArity, arityTypeArity, etaExpandAT )-import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )-import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Rules   ( lookupRule, getRules )-import GHC.Core.Multiplicity--import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326-import GHC.Types.SourceText-import GHC.Types.Id-import GHC.Types.Id.Make   ( seqId )-import GHC.Types.Id.Info-import GHC.Types.Name   ( mkSystemVarName, isExternalName, getOccFS )-import GHC.Types.Demand-import GHC.Types.Unique ( hasKey )-import GHC.Types.Basic-import GHC.Types.Tickish-import GHC.Types.Var    ( isTyCoVar )-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )-import GHC.Builtin.Names( runRWKey )--import GHC.Data.Maybe   ( isNothing, orElse )-import GHC.Data.FastString-import GHC.Unit.Module ( moduleName )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Monad  ( mapAccumLM, liftIO )-import GHC.Utils.Logger-import GHC.Utils.Misc--import Control.Monad--{--The guts of the simplifier is in this module, but the driver loop for-the simplifier is in GHC.Core.Opt.Pipeline--Note [The big picture]-~~~~~~~~~~~~~~~~~~~~~~-The general shape of the simplifier is this:--  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)-  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-- * SimplEnv contains-     - Simplifier mode-     - Ambient substitution-     - InScopeSet-- * SimplFloats contains-     - Let-floats (which includes ok-for-spec case-floats)-     - Join floats-     - InScopeSet (including all the floats)-- * Expressions-      simplExpr :: SimplEnv -> InExpr -> SimplCont-                -> SimplM (SimplFloats, OutExpr)-   The result of simplifying an /expression/ is (floats, expr)-      - A bunch of floats (let bindings, join bindings)-      - A simplified expression.-   The overall result is effectively (let floats in expr)-- * Bindings-      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-   The result of simplifying a binding is-     - A bunch of floats, the last of which is the simplified binding-       There may be auxiliary bindings too; see prepareRhs-     - An environment suitable for simplifying the scope of the binding--   The floats may also be empty, if the binding is inlined unconditionally;-   in that case the returned SimplEnv will have an augmented substitution.--   The returned floats and env both have an in-scope set, and they are-   guaranteed to be the same.---Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more.   (Actually, it never did!)  The reason is-documented with simplifyArgs.---Eta expansion-~~~~~~~~~~~~~~-For eta expansion, we want to catch things like--        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r--If the \x was on the RHS of a let, we'd eta expand to bring the two-lambdas together.  And in general that's a good thing to do.  Perhaps-we should eta expand wherever we find a (value) lambda?  Then the eta-expansion at a let RHS can concentrate solely on the PAP case.--Note [In-scope set as a substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Lookups in in-scope set], an in-scope set can act as-a substitution. Specifically, it acts as a substitution from variable to-variables /with the same unique/.--Why do we need this? Well, during the course of the simplifier, we may want to-adjust inessential properties of a variable. For instance, when performing a-beta-reduction, we change--    (\x. e) u ==> let x = u in e--We typically want to add an unfolding to `x` so that it inlines to (the-simplification of) `u`.--We do that by adding the unfolding to the binder `x`, which is added to the-in-scope set. When simplifying occurrences of `x` (every occurrence!), they are-replaced by their “updated” version from the in-scope set, hence inherit the-unfolding. This happens in `SimplEnv.substId`.--Another example. Consider--   case x of y { Node a b -> ...y...-               ; Leaf v   -> ...y... }--In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we-want y's unfolding to be (Leaf v). We achieve this by adding the appropriate-unfolding to y, and re-adding it to the in-scope set. See the calls to-`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.--It's quite convenient. This way we don't need to manipulate the substitution all-the time: every update to a binder is automatically reflected to its bound-occurrences.--Note [Bangs in the Simplifier]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both SimplFloats and SimplEnv do *not* generally benefit from making-their fields strict. I don't know if this is because of good use of-laziness or unintended side effects like closures capturing more variables-after WW has run.--But the end result is that we keep these lazy, but force them in some places-where we know it's beneficial to the compiler.--Similarly environments returned from functions aren't *always* beneficial to-force. In some places they would never be demanded so forcing them early-increases allocation. In other places they almost always get demanded so-it's worthwhile to force them early.--Would it be better to through every allocation of e.g. SimplEnv and decide-wether or not to make this one strict? Absolutely! Would be a good use of-someones time? Absolutely not! I made these strict that showed up during-a profiled build or which I noticed while looking at core for one reason-or another.--The result sadly is that we end up with "random" bangs in the simplifier-where we sometimes force e.g. the returned environment from a function and-sometimes we don't for the same function. Depending on the context around-the call. The treatment is also not very consistent. I only added bangs-where I saw it making a difference either in the core or benchmarks. Some-patterns where it would be beneficial aren't convered as a consequence as-I neither have the time to go through all of the core and some cases are-too small to show up in benchmarks.----************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--}--simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)--- See Note [The big picture]-simplTopBinds env0 binds0-  = do  {       -- Put all the top-level binders into scope at the start-                -- so that if a rewrite rule has unexpectedly brought-                -- anything into scope, then we don't get a complaint about that.-                -- It's rather as if the top-level binders were imported.-                -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".-        -- See Note [Bangs in the Simplifier]-        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)-        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0-        ; freeTick SimplifierDone-        ; return (floats, env2) }-  where-        -- We need to track the zapped top-level binders, because-        -- they should have their fragile IdInfo zapped (notably occurrence info)-        -- That's why we run down binds and bndrs' simultaneously.-        ---    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)-    simpl_binds env []           = return (emptyFloats env, env)-    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind-                                      ; (floats, env2) <- simpl_binds env1 binds-                                      -- See Note [Bangs in the Simplifier]-                                      ; let !floats1 = float `addFloats` floats-                                      ; return (floats1, env2) }--    simpl_bind env (Rec pairs)-      = simplRecBind env (BC_Let TopLevel Recursive) pairs-    simpl_bind env (NonRec b r)-      = do { let bind_cxt = BC_Let TopLevel NonRecursive-           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt-           ; simplRecOrTopPair env' bind_cxt b b' r }--{--************************************************************************-*                                                                      *-        Lazy bindings-*                                                                      *-************************************************************************--simplRecBind is used for-        * recursive bindings only--}--simplRecBind :: SimplEnv -> BindContext-             -> [(InId, InExpr)]-             -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 bind_cxt pairs0-  = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0-        ; let new_bndrs = map sndOf3 triples-        ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->-            go env triples-        ; return (mkRecFloats rec_floats, env2) }-  where-    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))-        -- Add the (substituted) rules to the binder-    add_rules env (bndr, rhs)-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt-             ; return (env', (bndr, bndr', rhs)) }--    go env [] = return (emptyFloats env, env)--    go env ((old_bndr, new_bndr, rhs) : pairs)-        = do { (float, env1) <- simplRecOrTopPair env bind_cxt-                                                  old_bndr new_bndr rhs-             ; (floats, env2) <- go env1 pairs-             ; return (float `addFloats` floats, env2) }--{--simplOrTopPair is used for-        * recursive bindings (whether top level or not)-        * top-level non-recursive bindings--It assumes the binder has already been simplified, but not its IdInfo.--}--simplRecOrTopPair :: SimplEnv-                  -> BindContext-                  -> InId -> OutBndr -> InExpr  -- Binder and rhs-                  -> SimplM (SimplFloats, SimplEnv)--simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs-  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)-                                          old_bndr rhs env-  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}-    simplTrace "SimplBindr:inline-uncond" (ppr old_bndr) $-    do { tick (PreInlineUnconditionally old_bndr)-       ; return ( emptyFloats env, env' ) }--  | otherwise-  = case bind_cxt of-      BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $-                             simplJoinBind env is_rec cont old_bndr new_bndr rhs env--      BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $-                               simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env--simplTrace :: String -> SDoc -> SimplM a -> SimplM a-simplTrace herald doc thing_inside = do-  logger <- getLogger-  if logHasDumpFlag logger Opt_D_verbose_core2core-    then logTraceMsg logger herald doc thing_inside-    else thing_inside-----------------------------simplLazyBind :: SimplEnv-              -> TopLevelFlag -> RecFlag-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- Not a JoinId-                                        -- The OutId has IdInfo (notably RULES),-                                        -- except arity, unfolding-                                        -- Ids only, no TyVars-              -> InExpr -> SimplEnv     -- The RHS and its environment-              -> SimplM (SimplFloats, SimplEnv)--- Precondition: the OutId is already in the InScopeSet of the incoming 'env'--- Precondition: not a JoinId--- Precondition: rhs obeys the let-can-float invariant-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se-  = assert (isId bndr )-    assertPpr (not (isJoinId bndr)) (ppr bndr) $-    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]-                (tvs, body) = case collectTyAndValBinders rhs of-                                (tvs, [], body)-                                  | surely_not_lam body -> (tvs, body)-                                _                       -> ([], rhs)--                surely_not_lam (Lam {})     = False-                surely_not_lam (Tick t e)-                  | not (tickishFloatable t) = surely_not_lam e-                   -- eta-reduction could float-                surely_not_lam _            = True-                        -- Do not do the "abstract tyvar" thing if there's-                        -- a lambda inside, because it defeats eta-reduction-                        --    f = /\a. \x. g a x-                        -- should eta-reduce.--        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs-                -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils--        -- Simplify the RHS-        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))-                                   is_rec (idDemandInfo bndr)-        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont--        -- ANF-ise a constructor or PAP rhs-        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}-                                   prepareBinding env top_lvl is_rec-                                                  False  -- Not strict; this is simplLazyBind-                                                  bndr1 body_floats0 body0-          -- Subtle point: we do not need or want tvs' in the InScope set-          -- of body_floats2, so we pass in 'env' not 'body_env'.-          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do-          -- more renaming than necessary => extra work (see !7777 and test T16577).-          -- Don't need: we wrap tvs' around the RHS anyway.--        ; (rhs_floats, body3)-            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating-                     {-#SCC "simplLazyBind-simple-floating" #-}-                     return (body_floats2, body2)--                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first-                     {-#SCC "simplLazyBind-type-abstraction-first" #-}-                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl-                                                                tvs' body_floats2 body2-                        ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds-                        ; return (poly_floats, body3) }--        ; let env' = env `setInScopeFromF` rhs_floats-        ; rhs' <- rebuildLam env' tvs' body3 rhs_cont-        ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'-        ; return (rhs_floats `addFloats` bind_float, env2) }-----------------------------simplJoinBind :: SimplEnv-              -> RecFlag-              -> SimplCont-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- The OutId has IdInfo, except arity,-                                        --   unfolding-              -> InExpr -> SimplEnv     -- The right hand side and its env-              -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se-  = do  { let rhs_env = rhs_se `setInScopeFromE` env-        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }-----------------------------simplAuxBind :: SimplEnv-             -> InId            -- Old binder; not a JoinId-             -> OutExpr         -- Simplified RHS-             -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of completeBindX used to construct non-recursive--- auxiliary bindings, notably in knownCon.------ The binder comes from a case expression (case binder or alternative)--- and so does not have rules, inline pragmas etc.------ Precondition: rhs satisfies the let-can-float invariant--simplAuxBind env bndr new_rhs-  | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $-    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }-  = return (emptyFloats env, env)    --  Here c is dead, and we avoid-                                     --  creating the binding c = (a,b)--  -- The cases would be inlined unconditionally by completeBind:-  -- but it seems not uncommon, and avoids faff to do it here-  -- This is safe because it's only used for auxiliary bindings, which-  -- have no NOLINE pragmas, nor RULEs-  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...-  = return ( emptyFloats env-           , case new_rhs of-                Coercion co -> extendCvSubst env bndr co-                _           -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )--  | otherwise-  = do  { -- ANF-ise the RHS-          let !occ_fs = getOccFS bndr-        ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs-        ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)-        ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats--          -- Simplify the binder and complete the binding-        ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr-        ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive)-                                             bndr new_bndr rhs1--        ; return (rhs_floats `addFloats` bind_float, env2) }---{- *********************************************************************-*                                                                      *-           Cast worker/wrapper-*                                                                      *-************************************************************************--Note [Cast worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have a binding-   x = e |> co-we want to do something very similar to worker/wrapper:-   $wx = e-   x = $wx |> co--We call this making a cast worker/wrapper in tryCastWorkerWrapper.--The main motivaiton is that x can be inlined freely.  There's a chance-that e will be a constructor application or function, or something-like that, so moving the coercion to the usage site may well cancel-the coercions and lead to further optimisation.  Example:--     data family T a :: *-     data instance T Int = T Int--     foo :: Int -> Int -> Int-     foo m n = ...-        where-          t = T m-          go 0 = 0-          go n = case t of { T m -> go (n-m) }-                -- This case should optimise--A second reason for doing cast worker/wrapper is that the worker/wrapper-pass after strictness analysis can't deal with RHSs like-     f = (\ a b c. blah) |> co-Instead, it relies on cast worker/wrapper to get rid of the cast,-leaving a simpler job for demand-analysis worker/wrapper.  See #19874.--Wrinkles--1. We must /not/ do cast w/w on-     f = g |> co-   otherwise it'll just keep repeating forever! You might think this-   is avoided because the call to tryCastWorkerWrapper is guarded by-   preInlineUnconditinally, but I'm worried that a loop-breaker or an-   exported Id might say False to preInlineUnonditionally.--2. We need to be careful with inline/noinline pragmas:-       rec { {-# NOINLINE f #-}-             f = (...g...) |> co-           ; g = ...f... }-   This is legitimate -- it tells GHC to use f as the loop breaker-   rather than g.  Now we do the cast thing, to get something like-       rec { $wf = ...g...-           ; f = $wf |> co-           ; g = ...f... }-   Where should the NOINLINE pragma go?  If we leave it on f we'll get-     rec { $wf = ...g...-         ; {-# NOINLINE f #-}-           f = $wf |> co-         ; g = ...f... }-   and that is bad: the whole point is that we want to inline that-   cast!  We want to transfer the pagma to $wf:-      rec { {-# NOINLINE $wf #-}-            $wf = ...g...-          ; f = $wf |> co-          ; g = ...f... }-   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.--3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.-      {- f: Stable unfolding = <stable-big> -}-      f = (\xy. <big-body>) |> co-   Then we want to w/w to-      {- $wf: Stable unfolding = <stable-big> |> sym co -}-      $wf = \xy. <big-body>-      f = $wf |> co-   Notice that the stable unfolding moves to the worker!  Now demand analysis-   will work fine on $wf, whereas it has trouble with the original f.-   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.-   This point also applies to strong loopbreakers with INLINE pragmas, see-   wrinkle (4).--4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence-   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to-   loop-breakers) because they'll definitely be inlined anyway, cast and-   all. And if we do cast w/w for an INLINE function with arity zero, we get-   something really silly: we inline that "worker" right back into the wrapper!-   Worse than a no-op, because we have then lost the stable unfolding.--All these wrinkles are exactly like worker/wrapper for strictness analysis:-  f is the wrapper and must inline like crazy-  $wf is the worker and must carry f's original pragma-See Note [Worker/wrapper for INLINABLE functions]-and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.--See #17673, #18093, #18078, #19890.--Note [Preserve strictness in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the Note [Cast worker/wrapper] transformation, keep the strictness info.-Eg-        f = e `cast` co    -- f has strictness SSL-When we transform to-        f' = e             -- f' also has strictness SSL-        f = f' `cast` co   -- f still has strictness SSL--Its not wrong to drop it on the floor, but better to keep it.--Note [Preserve RuntimeRep info in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not do cast w/w when the presence of the coercion is needed in order-to determine the runtime representation.--Example:--  Suppose we have a type family:--    type F :: RuntimeRep-    type family F where-      F = LiftedRep--  together with a type `ty :: TYPE F` and a top-level binding--    a :: ty |> TYPE F[0]--  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.-  However, were we to apply cast w/w, we would get:--    b :: ty-    b = ...--    a :: ty |> TYPE F[0]-    a = b `cast` GRefl (TYPE F[0])--  Now we are in trouble because `ty :: TYPE F` does not have a known runtime-  representation, because we need to be able to reduce the nullary type family-  application `F` to find that out.--Conclusion: only do cast w/w when doing so would not lose the RuntimeRep-information. That is, when handling `Cast rhs co`, don't attempt cast w/w-unless the kind of the type of rhs is concrete, in the sense of-Note [Concrete types] in GHC.Tc.Utils.Concrete.--}--tryCastWorkerWrapper :: SimplEnv -> BindContext-                     -> InId -> OccInfo-                     -> OutId -> OutExpr-                     -> SimplM (SimplFloats, SimplEnv)--- See Note [Cast worker/wrapper]-tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)-  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points-  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform-                        --            a DFunUnfolding in mk_worker_unfolding-  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1-  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4-  , isConcrete (typeKind work_ty)  -- Don't peel off a cast if doing so would-                                   -- lose the underlying runtime representation.-                                   -- See Note [Preserve RuntimeRep info in cast w/w]-  , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings-                                                   -- See Note [OPAQUE pragma]-  = do  { uniq <- getUniqueM-        ; let work_name = mkSystemVarName uniq occ_fs-              work_id   = mkLocalIdWithInfo work_name ManyTy work_ty work_info-              is_strict = isStrictId bndr--        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict-                                                   work_id (emptyFloats env) rhs--        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs-        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf-               floats   = rhs_floats `addLetFloats`-                          unitLetFloat (NonRec work_id_w_unf work_rhs)--               triv_rhs = Cast (Var work_id_w_unf) co--        ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs-             -- Almost always True, because the RHS is trivial-             -- In that case we want to eliminate the binding fast-             -- We conservatively use postInlineUnconditionally so that we-             -- check all the right things-          then do { tick (PostInlineUnconditionally bndr)-                  ; return ( floats-                           , extendIdSubst (setInScopeFromF env floats) old_bndr $-                             DoneEx triv_rhs Nothing ) }--          else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs-                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)-                                `setIdUnfolding`  wrap_unf-                        floats' = floats `extendFloats` NonRec bndr' triv_rhs-                  ; return ( floats', setInScopeFromF env floats' ) } }-  where-    -- Force the occ_fs so that the old Id is not retained in the new Id.-    !occ_fs = getOccFS bndr-    uf_opts = seUnfoldingOpts env-    work_ty = coercionLKind co-    info   = idInfo bndr-    work_arity = arityInfo info `min` typeArity work_ty--    work_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info-                              `setCprSigInfo`     cprSigInfo info-                              `setDemandInfo`     demandInfo info-                              `setInlinePragInfo` inlinePragInfo info-                              `setArityInfo`      work_arity-           -- We do /not/ want to transfer OccInfo, Rules-           -- Note [Preserve strictness in cast w/w]-           -- and Wrinkle 2 of Note [Cast worker/wrapper]--    ----------- Worker unfolding ------------    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);-    --   the next round of simplification will do the job-    -- Non-stable case: use work_rhs-    -- Wrinkle 3 of Note [Cast worker/wrapper]-    mk_worker_unfolding top_lvl work_id work_rhs-      = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers-           unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })-             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })-           _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs--tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings-  = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr-                                   , text "rhs:" <+> ppr rhs ])-        ; return (mkFloatBind env (NonRec bndr rhs)) }--mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma--- See Note [Cast worker/wrapper]-mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })-  = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = fn_inl       -- See Note [Worker/wrapper for INLINABLE functions]-                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap-                 , inl_act    = wrap_act     -- See Note [Wrapper activation]-                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap-                                -- RuleMatchInfo is (and must be) unaffected-  where-    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap-    -- But simpler, because we don't need to disable during InitialPhase-    wrap_act | isNeverActive fn_act = activateDuringFinal-             | otherwise            = fn_act---{- *********************************************************************-*                                                                      *-           prepareBinding, prepareRhs, makeTrivial-*                                                                      *-********************************************************************* -}--prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool-               -> Id   -- Used only for its OccName; can be InId or OutId-               -> SimplFloats -> OutExpr-               -> SimplM (SimplFloats, OutExpr)--- In (prepareBinding ... bndr floats rhs), the binding is really just---    bndr = let floats in rhs--- Maybe we can ANF-ise this binding and float out; e.g.---    bndr = let a = f x in K a a (g x)--- we could float out to give---    a    = f x---    tmp  = g x---    bndr = K a a tmp--- That's what prepareBinding does--- Precondition: binder is not a JoinId--- Postcondition: the returned SimplFloats contains only let-floats-prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs-  = do { -- Never float join-floats out of a non-join let-binding (which this is)-         -- So wrap the body in the join-floats right now-         -- Hence: rhs_floats1 consists only of let-floats-         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs--         -- rhs_env: add to in-scope set the binders from rhs_floats-         -- so that prepareRhs knows what is in scope in rhs-       ; let rhs_env = env `setInScopeFromF` rhs_floats1-             -- Force the occ_fs so that the old Id is not retained in the new Id.-             !occ_fs = getOccFS bndr--       -- Now ANF-ise the remaining rhs-       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1--       -- Finally, decide whether or not to float-       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats-       ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2-         then -- Float!-              do { tick LetFloatFromLet-                 ; return (all_floats, rhs2) }--         else -- Abandon floating altogether; revert to original rhs-              -- Since we have already built rhs1, we just need to add-              -- rhs_floats1 to it-              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }--{- Note [prepareRhs]-~~~~~~~~~~~~~~~~~~~~-prepareRhs takes a putative RHS, checks whether it's a PAP or-constructor application and, if so, converts it to ANF, so that the-resulting thing can be inlined more easily.  Thus-        x = (f a, g b)-becomes-        t1 = f a-        t2 = g b-        x = (t1,t2)--We also want to deal well cases like this-        v = (f e1 `cast` co) e2-Here we want to make e1,e2 trivial and get-        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2-That's what the 'go' loop in prepareRhs does--}--prepareRhs :: HasDebugCallStack-           => SimplEnv -> TopLevelFlag-           -> FastString    -- Base for any new variables-           -> OutExpr-           -> SimplM (LetFloats, OutExpr)--- Transforms a RHS into a better RHS by ANF'ing args--- for expandable RHSs: constructors and PAPs--- e.g        x = Just e--- becomes    a = e               -- 'a' is fresh---            x = Just a--- See Note [prepareRhs]-prepareRhs env top_lvl occ rhs0-  | is_expandable = anfise rhs0-  | otherwise     = return (emptyLetFloats, rhs0)-  where-    -- We can' use exprIsExpandable because the WHOLE POINT is that-    -- we want to treat (K <big>) as expandable, because we are just-    -- about "anfise" the <big> expression.  exprIsExpandable would-    -- just say no!-    is_expandable = go rhs0 0-       where-         go (Var fun) n_val_args       = isExpandableApp fun n_val_args-         go (App fun arg) n_val_args-           | isTypeArg arg             = go fun n_val_args-           | otherwise                 = go fun (n_val_args + 1)-         go (Cast rhs _)  n_val_args   = go rhs n_val_args-         go (Tick _ rhs)  n_val_args   = go rhs n_val_args-         go _             _            = False--    anfise :: OutExpr -> SimplM (LetFloats, OutExpr)-    anfise (Cast rhs co)-        = do { (floats, rhs') <- anfise rhs-             ; return (floats, Cast rhs' co) }-    anfise (App fun (Type ty))-        = do { (floats, rhs') <- anfise fun-             ; return (floats, App rhs' (Type ty)) }-    anfise (App fun arg)-        = do { (floats1, fun') <- anfise fun-             ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg-             ; return (floats1 `addLetFlts` floats2, App fun' arg') }-    anfise (Var fun)-        = return (emptyLetFloats, Var fun)--    anfise (Tick t rhs)-        -- We want to be able to float bindings past this-        -- tick. Non-scoping ticks don't care.-        | tickishScoped t == NoScope-        = do { (floats, rhs') <- anfise rhs-             ; return (floats, Tick t rhs') }--        -- On the other hand, for scoping ticks we need to be able to-        -- copy them on the floats, which in turn is only allowed if-        -- we can obtain non-counting ticks.-        | (not (tickishCounts t) || tickishCanSplit t)-        = do { (floats, rhs') <- anfise rhs-             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)-                   floats' = mapLetFloats floats tickIt-             ; return (floats', Tick t rhs') }--    anfise other = return (emptyLetFloats, other)--makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)-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--makeTrivial :: HasDebugCallStack-            => SimplEnv -> TopLevelFlag -> Demand-            -> FastString  -- ^ A "friendly name" to build the new binder from-            -> OutExpr-            -> SimplM (LetFloats, OutExpr)--- Binds the expression to a variable, if it's not trivial, returning the variable--- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]-makeTrivial env top_lvl dmd occ_fs expr-  | exprIsTrivial expr                          -- Already trivial-  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise-                                                --   See Note [Cannot trivialise]-  = return (emptyLetFloats, expr)--  | Cast expr' co <- expr-  = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'-       ; return (floats, Cast triv_expr co) }--  | otherwise -- 'expr' is not of form (Cast e co)-  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr-        ; uniq <- getUniqueM-        ; let name = mkSystemVarName uniq occ_fs-              var  = mkLocalIdWithInfo name ManyTy expr_ty id_info--        -- Now something very like completeBind,-        -- but without the postInlineUnconditionally part-        ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1-          -- Technically we should extend the in-scope set in 'env' with-          -- the 'floats' from prepareRHS; but they are all fresh, so there is-          -- no danger of introducing name shadowig in eta expansion--        ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2--        ; let final_id = addLetBndrInfo var arity_type unf-              bind     = NonRec final_id expr2--        ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])-        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }-  where-    id_info = vanillaIdInfo `setDemandInfo` dmd-    expr_ty = exprType expr-    uf_opts = seUnfoldingOpts env--bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool--- True iff we can have a binding of this expression at this level--- Precondition: the type is the type of the expression-bindingOk top_lvl expr expr_ty-  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty-  | otherwise          = True--{- Note [Cannot trivialise]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-   f :: Int -> Addr#--   foo :: Bar-   foo = Bar (f 3)--Then we can't ANF-ise foo, even though we'd like to, because-we can't make a top-level binding for the Addr# (f 3). And if-so we don't want to turn it into-   foo = let x = f 3 in Bar x-because we'll just end up inlining x back, and that makes the-simplifier loop.  Better not to ANF-ise it at all.--Literal strings are an exception.--   foo = Ptr "blob"#--We want to turn this into:--   foo1 = "blob"#-   foo = Ptr foo1--See Note [Core top-level string literals] in GHC.Core.--************************************************************************-*                                                                      *-          Completing a lazy binding-*                                                                      *-************************************************************************--completeBind-  * deals only with Ids, not TyVars-  * takes an already-simplified binder and RHS-  * is used for both recursive and non-recursive bindings-  * is used for both top-level and non-top-level bindings--It does the following:-  - tries discarding a dead binding-  - tries PostInlineUnconditionally-  - add unfolding [this is the only place we add an unfolding]-  - add arity-  - extend the InScopeSet of the SimplEnv--It does *not* attempt to do let-to-case.  Why?  Because it is used for-  - top-level bindings (when let-to-case is impossible)-  - many situations where the "rhs" is known to be a WHNF-                (so let-to-case is inappropriate).--Nor does it do the atomic-argument thing--}--completeBind :: SimplEnv-             -> BindContext-             -> InId           -- Old binder-             -> OutId          -- New binder; can be a JoinId-             -> OutExpr        -- New RHS-             -> SimplM (SimplFloats, SimplEnv)--- completeBind may choose to do its work---      * by extending the substitution (e.g. let x = y in ...)---      * or by adding to the floats in the envt------ Binder /can/ be a JoinId--- Precondition: rhs obeys the let-can-float invariant-completeBind env bind_cxt old_bndr new_bndr new_rhs- | isCoVar old_bndr- = case new_rhs of-     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)-     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))-- | otherwise- = assert (isId new_bndr) $-   do { let old_info = idInfo old_bndr-            old_unf  = realUnfoldingInfo old_info-            occ_info = occInfo old_info--         -- Do eta-expansion on the RHS of the binding-         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils-      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs--        -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr-                         eta_rhs (idType new_bndr) new_arity old_unf--      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding-        -- See Note [In-scope set as a substitution]--      ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs--        then -- Inline and discard the binding-             do  { tick (PostInlineUnconditionally old_bndr)-                 ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs-                          -- See Note [Use occ-anald RHS in postInlineUnconditionally]-                 ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $-                   return ( emptyFloats env-                          , extendIdSubst env old_bndr $-                            DoneEx unf_rhs (isJoinId_maybe new_bndr)) }-                -- Use the substitution to make quite, quite sure that the-                -- substitution will happen, since we are going to discard the binding--        else -- Keep the binding; do cast worker/wrapper-             -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $-             tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }--addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity_type new_unf-  = new_bndr `setIdInfo` info5-  where-    new_arity = arityTypeArity new_arity_type-    info1 = idInfo new_bndr `setArityInfo` new_arity--    -- Unfolding info: Note [Setting the new unfolding]-    info2 = info1 `setUnfoldingInfo` new_unf--    -- Demand info: Note [Setting the demand info]-    info3 | isEvaldUnfolding new_unf-          = zapDemandInfo info2 `orElse` info2-          | otherwise-          = info2--    -- Bottoming bindings: see Note [Bottoming bindings]-    info4 = case arityTypeBotSigs_maybe new_arity_type of-        Nothing -> info3-        Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $-                                       info3 `setDmdSigInfo` str_sig-                                             `setCprSigInfo` cpr_sig--     -- Zap call arity info. We have used it by now (via-     -- `tryEtaExpandRhs`), and the simplifier can invalidate this-     -- information, leading to broken code later (e.g. #13479)-    info5 = zapCallArityInfo info4---{- Note [Bottoming bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   let x = error "urk"-   in ...(case x of <alts>)...-or-   let f = \y. error (y ++ "urk")-   in ...(case f "foo" of <alts>)...--Then we'd like to drop the dead <alts> immediately.  So it's good to-propagate the info that x's (or f's) RHS is bottom to x's (or f's)-IdInfo as rapidly as possible.--We use tryEtaExpandRhs on every binding, and it turns out that the-arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already-does a simple bottoming-expression analysis.  So all we need to do-is propagate that info to the binder's IdInfo.--This showed up in #12150; see comment:16.--There is a second reason for settting  the strictness signature. Consider-   let -- f :: <[S]b>-       f = \x. error "urk"-   in ...(f a b c)...-Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f`-to eta-expand to-   let f = \x y z. error "urk"-   in ...(f a b c)...--But now f's strictness signature has too short an arity; see-GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth].-Fortuitously, the same strictness-signature-fixup code-gives the function a new strictness signature with the right number of-arguments.  Example in stranal/should_compile/EtaExpansion.--Note [Setting the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the unfolding is a value, the demand info may-go pear-shaped, so we nuke it.  Example:-     let x = (a,b) in-     case x of (p,q) -> h p q x-Here x is certainly demanded. But after we've nuked-the case, we'll get just-     let x = (a,b) in h a b x-and now x is not demanded (I'm assuming h is lazy)-This really happens.  Similarly-     let f = \x -> e in ...f..f...-After inlining f at some of its call sites the original binding may-(for example) be no longer strictly demanded.-The solution here is a bit ad hoc...--Note [Use occ-anald RHS in postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we postInlineUnconditionally 'f in-  let f = \x -> x True in ...(f blah)...-then we'd like to inline the /occ-anald/ RHS for 'f'.  If we-use the non-occ-anald version, we'll end up with a-    ...(let x = blah in x True)...-and hence an extra Simplifier iteration.--We already /have/ the occ-anald version in the Unfolding for-the Id.  Well, maybe not /quite/ always.  If the binder is Dead,-postInlineUnconditionally will return True, but we may not have an-unfolding because it's too big. Hence the belt-and-braces `orElse`-in the defn of unf_rhs.  The Nothing case probably never happens.---************************************************************************-*                                                                      *-\subsection[Simplify-simplExpr]{The main function: simplExpr}-*                                                                      *-************************************************************************--The reason for this OutExprStuff stuff is that we want to float *after*-simplifying a RHS, not before.  If we do so naively we get quadratic-behaviour as things float out.--To see why it's important to do it after, consider this (real) example:--        let t = f x-        in fst t-==>-        let t = let a = e1-                    b = e2-                in (a,b)-        in fst t-==>-        let a = e1-            b = e2-            t = (a,b)-        in-        a       -- Can't inline a this round, cos it appears twice-==>-        e1--Each of the ==> steps is a round of simplification.  We'd save a-whole round if we float first.  This can cascade.  Consider--        let f = g d-        in \x -> ...f...-==>-        let f = let d1 = ..d.. in \y -> e-        in \x -> ...f...-==>-        let d1 = ..d..-        in \x -> ...(\y ->e)...--Only in this second round can the \y be applied, and it-might do the same again.--}--simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]-  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]-       ; return (Type ty') }--simplExpr env expr-  = simplExprC env expr (mkBoringStop expr_out_ty)-  where-    expr_out_ty :: OutType-    expr_out_ty = substTy env (exprType expr)-    -- NB: Since 'expr' is term-valued, not (Type ty), this call-    --     to exprType will succeed.  exprType fails on (Type ty).--simplExprC :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM OutExpr-        -- Simplify an expression, given a continuation-simplExprC env expr cont-  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $-    do  { (floats, expr') <- simplExprF env expr cont-        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $-          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $-          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $-          return (wrapFloats floats expr') }-----------------------------------------------------simplExprF :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> 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)-      ]) $ -}-    simplExprF1 env e cont--simplExprF1 :: SimplEnv -> InExpr -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--simplExprF1 _ (Type ty) cont-  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)-    -- simplExprF does only with term-valued expressions-    -- 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 (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-simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont--simplExprF1 env (App fun arg) cont-  = {-#SCC "simplExprF1-App" #-} case arg of-      Type ty -> do { -- The argument type will (almost) certainly be used-                      -- in the output program, so just force it now.-                      -- See Note [Avoiding space leaks in OutType]-                      arg' <- simplType env ty--                      -- But use substTy, not simplType, to avoid forcing-                      -- the hole type; it will likely not be needed.-                      -- See Note [The hole type in ApplyToTy]-                    ; let hole' = substTy env (exprType fun)--                    ; simplExprF env fun $-                      ApplyToTy { sc_arg_ty  = arg'-                                , sc_hole_ty = hole'-                                , sc_cont    = cont } }-      _       ->-          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will-          -- be forced only if we need to run contHoleType.-          -- When these are forced, we might get quadratic behavior;-          -- this quadratic blowup could be avoided by drilling down-          -- to the function and getting its multiplicities all at once-          -- (instead of one-at-a-time). But in practice, we have not-          -- observed the quadratic behavior, so this extra entanglement-          -- seems not worthwhile.-        simplExprF env fun $-        ApplyToVal { sc_arg = arg, sc_env = env-                   , sc_hole_ty = substTy env (exprType fun)-                   , sc_dup = NoDup, sc_cont = cont }--simplExprF1 env expr@(Lam {}) cont-  = {-#SCC "simplExprF1-Lam" #-}-    simplLam env (zapLambdaBndrs expr n_args) cont-        -- zapLambdaBndrs: the issue here is under-saturated lambdas-        --   (\x1. \x2. e) arg1-        -- Here x1 might have "occurs-once" occ-info, because occ-info-        -- is computed assuming that a group of lambdas is applied-        -- all at once.  If there are too few args, we must zap the-        -- occ-info, UNLESS the remaining binders are one-shot-  where-    n_args = countArgs cont-        -- NB: countArgs counts all the args (incl type args)-        -- and likewise drop counts all binders (incl type lambdas)--simplExprF1 env (Case scrut bndr _ alts) cont-  = {-#SCC "simplExprF1-Case" #-}-    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr-                                 , sc_alts = alts-                                 , sc_env = env, sc_cont = cont })--simplExprF1 env (Let (Rec pairs) body) cont-  | Just pairs' <- joinPointBindings_maybe pairs-  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont--  | otherwise-  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont--simplExprF1 env (Let (NonRec bndr rhs) body) cont-  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)-  = {-#SCC "simplExprF1-NonRecLet-Type" #-}-    assert (isTyVar bndr) $-    do { ty' <- simplType env ty-       ; simplExprF (extendTvSubst env bndr ty') body cont }--  | 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)-       ; simplExprF env' body cont }--  -- Now check for a join point.  It's better to do the preInlineUnconditionally-  -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial-  -- binding like { j = j2 |> co } would first be eta-expanded and then inlined-  -- Better to test preInlineUnconditionally first.-  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs-  = {-#SCC "simplNonRecJoinPoint" #-}-    simplNonRecJoinPoint env bndr' rhs' body cont--  | otherwise-  = {-#SCC "simplNonRecE" #-}-    simplNonRecE env FromLet bndr (rhs, env) body cont--{- Note [Avoiding space leaks in OutType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the simplifier is run for multiple iterations, we need to ensure-that any thunks in the output of one simplifier iteration are forced-by the evaluation of the next simplifier iteration. Otherwise we may-retain multiple copies of the Core program and leak a terrible amount-of memory (as in #13426).--The simplifier is naturally strict in the entire "Expr part" of the-input Core program, because any expression may contain binders, which-we must find in order to extend the SimplEnv accordingly. But types-do not contain binders and so it is tempting to write things like--    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!--This is Bad because the result includes a thunk (substTy env ty) which-retains a reference to the whole simplifier environment; and the next-simplifier iteration will not force this thunk either, because the-line above is not strict in ty.--So instead our strategy is for the simplifier to fully evaluate-OutTypes when it emits them into the output Core program, for example--    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good-                                 ; return (Type ty') }--where the only difference from above is that simplType calls seqType-on the result of substTy.--However, SimplCont can also contain OutTypes and it's not necessarily-a good idea to force types on the way in to SimplCont, because they-may end up not being used and forcing them could be a lot of wasted-work. T5631 is a good example of this.--- For ApplyToTy's sc_arg_ty, we force the type on the way in because-  the type will almost certainly appear as a type argument in the-  output program.--- For the hole types in Stop and ApplyToTy, we force the type when we-  emit it into the output program, after obtaining it from-  contResultType. (The hole type in ApplyToTy is only directly used-  to form the result type in a new Stop continuation.)--}-------------------------------------- Simplify a join point, adding the context.--- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:---   \x1 .. xn -> e => \x1 .. xn -> E[e]--- Note that we need the arity of the join point, since e may be a lambda--- (though this is unlikely). See Note [Join points and case-of-case].-simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont-             -> SimplM OutExpr-simplJoinRhs env bndr expr cont-  | Just arity <- isJoinId_maybe bndr-  =  do { let (join_bndrs, join_body) = collectNBinders arity expr-              mult = contHoleScaling cont-        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)-        ; join_body' <- simplExprC env' join_body cont-        ; return $ mkLams join_bndrs' join_body' }--  | otherwise-  = pprPanic "simplJoinRhs" (ppr bndr)------------------------------------simplType :: SimplEnv -> InType -> SimplM OutType-        -- Kept monadic just so we can do the seqType-        -- See Note [Avoiding space leaks in OutType]-simplType env ty-  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $-    seqType new_ty `seq` return new_ty-  where-    new_ty = substTy env ty------------------------------------simplCoercionF :: SimplEnv -> InCoercion -> SimplCont-               -> SimplM (SimplFloats, OutExpr)-simplCoercionF env co cont-  = do { co' <- simplCoercion env co-       ; rebuild env (Coercion co') cont }--simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion-simplCoercion env co-  = do { let opt_co = optCoercion opts (getSubst env) co-       ; seqCo opt_co `seq` return opt_co }-  where-    opts = seOptCoercionOpts env---------------------------------------- | Push a TickIt context outwards past applications and cases, as--- long as this is a non-scoping tick, to let case and application--- optimisations apply.--simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplTick env tickish expr cont-  -- A scoped tick turns into a continuation, so that we can spot-  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do-  -- it this way, then it would take two passes of the simplifier to-  -- reduce ((scc t (\x . e)) e').-  -- NB, don't do this with counting ticks, because if the expr is-  -- bottom, then rebuildCall will discard the continuation.---- XXX: we cannot do this, because the simplifier assumes that--- the context can be pushed into a case with a single branch. e.g.---    scc<f>  case expensive of p -> e--- becomes---    case expensive of p -> scc<f> e------ So I'm disabling this for now.  It just means we will do more--- simplifier iterations that necessary in some cases.----  | tickishScoped tickish && not (tickishCounts tickish)---  = simplExprF env expr (TickIt tickish cont)--  -- For unscoped or soft-scoped ticks, we are allowed to float in new-  -- cost, so we simply push the continuation inside the tick.  This-  -- has the effect of moving the tick to the outside of a case or-  -- application context, allowing the normal case and application-  -- optimisations to fire.-  | tickish `tickishScopesLike` SoftScope-  = do { (floats, expr') <- simplExprF env expr cont-       ; return (floats, mkTick tickish expr')-       }--  -- Push tick inside if the context looks like this will allow us to-  -- do a case-of-case - see Note [case-of-scc-of-case]-  | Select {} <- cont, Just expr' <- push_tick_inside-  = simplExprF env expr' cont--  -- We don't want to move the tick, but we might still want to allow-  -- floats to pass through with appropriate wrapping (or not, see-  -- wrap_floats below)-  --- | not (tickishCounts tickish) || tickishCanSplit tickish-  -- = wrap_floats--  | otherwise-  = no_floating_past_tick-- where--  -- Try to push tick inside a case, see Note [case-of-scc-of-case].-  push_tick_inside =-    case expr0 of-      Case scrut bndr ty alts-             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)-      _other -> Nothing-   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)-         movable t      = not (tickishCounts t) ||-                          t `tickishScopesLike` NoScope ||-                          tickishCanSplit t-         tickScrut e    = foldr mkTick e ticks-         -- Alternatives get annotated with all ticks that scope in some way,-         -- but we don't want to count entries.-         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)-         ts_scope         = map mkNoCount $-                            filter (not . (`tickishScopesLike` NoScope)) ticks--  no_floating_past_tick =-    do { let (inc,outc) = splitCont cont-       ; (floats, expr1) <- simplExprF env expr inc-       ; let expr2    = wrapFloats floats expr1-             tickish' = simplTickish env tickish-       ; rebuild env (mkTick tickish' expr2) outc-       }---- Alternative version that wraps outgoing floats with the tick.  This--- results in ticks being duplicated, as we don't make any attempt to--- eliminate the tick if we re-inline the binding (because the tick--- semantics allows unrestricted inlining of HNFs), so I'm not doing--- this any more.  FloatOut will catch any real opportunities for--- floating.------  wrap_floats =---    do { let (inc,outc) = splitCont cont---       ; (env', expr') <- simplExprF (zapFloats env) expr inc---       ; let tickish' = simplTickish env tickish---       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),---                                   mkTick (mkNoCount tickish') rhs)---              -- when wrapping a float with mkTick, we better zap the Id's---              -- strictness info and arity, because it might be wrong now.---       ; let env'' = addFloats env (mapFloats env' wrap_float)---       ; rebuild env'' expr' (TickIt tickish' outc)---       }---  simplTickish env tickish-    | Breakpoint ext n ids <- tickish-          = Breakpoint ext n (map (getDoneId . substId env) ids)-    | otherwise = tickish--  -- Push type application and coercion inside a tick-  splitCont :: SimplCont -> (SimplCont, SimplCont)-  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)-    where (inc,outc) = splitCont tail-  splitCont (CastIt co c) = (CastIt co inc, outc)-    where (inc,outc) = splitCont c-  splitCont other = (mkBoringStop (contHoleType other), other)--  getDoneId (DoneId id)  = id-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst-  getDoneId other = pprPanic "getDoneId" (ppr other)---- Note [case-of-scc-of-case]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- It's pretty important to be able to transform case-of-case when--- there's an SCC in the way.  For example, the following comes up--- in nofib/real/compress/Encode.hs:------        case scctick<code_string.r1>---             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje---             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->---             (ww1_s13f, ww2_s13g, ww3_s13h)---             }---        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->---        tick<code_string.f1>---        (ww_s12Y,---         ww1_s12Z,---         PTTrees.PT---           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)---        }------ We really want this case-of-case to fire, because then the 3-tuple--- will go away (indeed, the CPR optimisation is relying on this--- happening).  But the scctick is in the way - we need to push it--- inside to expose the case-of-case.  So we perform this--- transformation on the inner case:------   scctick c (case e of { p1 -> e1; ...; pn -> en })---    ==>---   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }------ So we've moved a constant amount of work out of the scc to expose--- the case.  We only do this when the continuation is interesting: in--- for now, it has to be another Case (maybe generalise this later).--{--************************************************************************-*                                                                      *-\subsection{The main rebuilder}-*                                                                      *-************************************************************************--}--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-      Stop {}          -> return (emptyFloats env, expr)-      TickIt t cont    -> rebuild env (mkTick t expr) cont-      CastIt co cont   -> rebuild env (mkCast expr co) cont-                       -- NB: mkCast implements the (Coercion co |> g) optimisation--      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }-        -> 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--      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--      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') <- simplArg env dup_flag fun_ty se arg-              ; rebuild env (App expr arg') cont }--completeBindX :: SimplEnv-              -> FromWhat-              -> InId -> OutExpr   -- Bind this Id to this (simplified) expression-                                   -- (the let-can-float invariant may not be satisfied)-              -> InExpr            -- In this body-              -> SimplCont         -- Consumed by this continuation-              -> SimplM (SimplFloats, OutExpr)-completeBindX env from_what bndr rhs body cont-  | FromBeta arg_ty <- from_what-  , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant-  = do { (env1, bndr1)   <- simplNonRecBndr env bndr  -- Lambda binders don't have rules-       ; (floats, expr') <- simplNonRecBody env1 from_what body cont-       -- Do not float floats past the Case binder below-       ; let expr'' = wrapFloats floats expr'-             case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']-       ; return (emptyFloats env, case_expr) }--  | otherwise -- Make a let-binding-  = do  { (env1, bndr1) <- simplNonRecBndr env bndr-        ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)--        ; let is_strict = isStrictId bndr2-              -- isStrictId: use simplified binder because the InId bndr might not have-              -- a fixed runtime representation, which isStrictId doesn't expect-              -- c.f. Note [Dark corner with representation polymorphism]--        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict-                                               bndr2 (emptyFloats env) rhs-              -- NB: it makes a surprisingly big difference (5% in compiler allocation-              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',-              -- because this is simplNonRecX, so bndr is not in scope in the RHS.--        ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)-                                             (BC_Let NotTopLevel NonRecursive)-                                             bndr bndr2 rhs1-              -- Must pass env1 to completeBind in case simplBinder had to clone,-              -- and extended the substitution with [bndr :-> new_bndr]--        -- Simplify the body-        ; (body_floats, body') <- simplNonRecBody env2 from_what body cont--        ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats-        ; return ( all_floats, body' ) }--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--{- Note [Optimising reflexivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important (for compiler performance) to get rid of reflexivity as soon-as it appears.  See #11735, #14737, and #15019.--In particular, we want to behave well on-- *  e |> co1 |> co2-    where the two happen to cancel out entirely. That is quite common;-    e.g. a newtype wrapping and unwrapping cancel.--- * (f |> co) @t1 @t2 ... @tn x1 .. xm-   Here we will use pushCoTyArg and pushCoValArg successively, which-   build up SelCo stacks.  Silly to do that if co is reflexive.--However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (#14737 comment:7).--A good compromise (determined experimentally) seems to be to call-isReflexiveCo- * when composing casts, and- * at the end--In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See #15090.--}---simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplCast env body co0 cont0-  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0-        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}-                   if isReflCo co1-                   then return cont0  -- See Note [Optimising reflexivity]-                   else addCoerce co1 cont0-        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }-  where-        -- If the first parameter is MRefl, then simplifying revealed a-        -- reflexive coercion. Omit.-        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont-        addCoerceM MRefl   cont = return cont-        addCoerceM (MCo co) cont = addCoerce co cont--        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont-        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]-          | isReflexiveCo co' = return cont-          | otherwise         = addCoerce co' cont-          where-            co' = mkTransCo co1 co2--        addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })-          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty-          = {-#SCC "addCoerce-pushCoTyArg" #-}-            do { tail' <- addCoerceM m_co' tail-               ; return (ApplyToTy { sc_arg_ty  = arg_ty'-                                   , sc_cont    = tail'-                                   , sc_hole_ty = coercionLKind co }) }-                                        -- NB!  As the cast goes past, the-                                        -- type of the hole changes (#16312)--        -- (f |> co) e   ===>   (f (e |> co1)) |> co2-        -- where   co :: (s1->s2) ~ (t1->t2)-        --         co1 :: t1 ~ s1-        --         co2 :: s2 ~ t2-        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se-                                      , sc_dup = dup, sc_cont = tail-                                      , sc_hole_ty = fun_ty })-          | Just (m_co1, m_co2) <- pushCoValArg co-          , fixed_rep m_co1-          = {-#SCC "addCoerce-pushCoValArg" #-}-            do { tail' <- addCoerceM m_co2 tail-               ; case m_co1 of {-                   MRefl -> return (cont { sc_cont = tail'-                                         , sc_hole_ty = coercionLKind co }) ;-                      -- Avoid simplifying if possible;-                      -- See Note [Avoiding exponential behaviour]--                   MCo co1 ->-            do { (dup', arg_se', arg') <- simplArg env dup fun_ty arg_se arg-                    -- When we build the ApplyTo we can't mix the OutCoercion-                    -- 'co' with the InExpr 'arg', so we simplify-                    -- to make it all consistent.  It's a bit messy.-                    -- But it isn't a common case.-                    -- Example of use: #995-               ; return (ApplyToVal { sc_arg  = mkCast arg' co1-                                    , sc_env  = arg_se'-                                    , sc_dup  = dup'-                                    , sc_cont = tail'-                                    , sc_hole_ty = coercionLKind co }) } } }--        addCoerce co cont-          | isReflexiveCo co = return cont  -- Having this at the end makes a huge-                                            -- difference in T12227, for some reason-                                            -- See Note [Optimising reflexivity]-          | otherwise        = return (CastIt co cont)--        fixed_rep :: MCoercionR -> Bool-        fixed_rep MRefl    = True-        fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co-          -- Without this check, we can get an argument which does not-          -- have a fixed runtime representation.-          -- See Note [Representation polymorphism invariants] in GHC.Core-          -- test: typecheck/should_run/EtaExpandLevPoly--simplArg :: SimplEnv -> DupFlag-         -> OutType                 -- Type of the function applied to this arg-         -> StaticEnv -> CoreExpr   -- Expression with its static envt-         -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag fun_ty arg_env arg-  | isSimplified dup_flag-  = return (dup_flag, arg_env, arg)-  | otherwise-  = do { let arg_env' = arg_env `setInScopeFromE` env-       ; arg' <- simplExprC arg_env' arg (mkBoringStop (funArgTy fun_ty))-       ; return (Simplified, zapSubstEnv arg_env', arg') }-         -- Return a StaticEnv that includes the in-scope set from 'env',-         -- because arg' may well mention those variables (#20639)--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--simplNonRecBody :: SimplEnv -> FromWhat-                -> InExpr -> SimplCont-                -> SimplM (SimplFloats, OutExpr)-simplNonRecBody env from_what body cont-  = case from_what of-      FromLet     -> simplExprF env body cont-      FromBeta {} -> simplLam   env body cont--simplLam :: SimplEnv -> InExpr -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont-simplLam env expr            cont = simplExprF env expr cont--simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- Type beta-reduction-simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })-  = do { tick (BetaReduction bndr)-       ; simplLam (extendTvSubst env bndr arg_ty) body cont }---- Value beta-reduction-simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se-                                    , sc_cont = cont, sc_dup = dup-                                    , sc_hole_ty = fun_ty})-  = do { tick (BetaReduction bndr)-       ; let arg_ty = funArgTy fun_ty-       ; if | isSimplified dup  -- Don't re-simplify if we've simplified it once-                                -- Including don't preInlineUnconditionally-                                -- See Note [Avoiding exponential behaviour]-            -> completeBindX env (FromBeta arg_ty) bndr arg body cont--            | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se-            , not (needsCaseBinding arg_ty arg)-              -- Ok to test arg::InExpr in needsCaseBinding because-              -- exprOkForSpeculation is stable under simplification-            -> do { tick (PreInlineUnconditionally bndr)-                  ; simplLam env' body cont }--            | otherwise-            -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }---- Discard a non-counting tick on a lambda.  This may change the--- cost attribution slightly (moving the allocation of the--- lambda elsewhere), but we don't care: optimisation changes--- cost attribution all the time.-simpl_lam env bndr body (TickIt tickish cont)-  | not (tickishCounts tickish)-  = simpl_lam env bndr body cont---- Not enough args, so there are real lambdas left to put in the result-simpl_lam env bndr body cont-  = do  { let (inner_bndrs, inner_body) = collectBinders body-        ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)-        ; body'   <- simplExpr env' inner_body-        ; new_lam <- rebuildLam env' bndrs' body' cont-        ; rebuild env' new_lam cont }----------------simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Historically this had a special case for when a lambda-binder--- could have a stable unfolding;--- see Historical Note [Case binders and join points]--- But now it is much simpler! We now only remove unfoldings.--- See Note [Never put `OtherCon` unfoldings on lambda binders]-simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)--simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs---------------------simplNonRecE :: SimplEnv-             -> FromWhat-             -> InId                    -- The binder, always an Id-                                        -- Never a join point-             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)-             -> InExpr                  -- Body of the let/lambda-             -> SimplCont-             -> SimplM (SimplFloats, OutExpr)---- simplNonRecE is used for---  * from=FromLet:  a non-top-level non-recursive non-join-point let-expression---  * from=FromBeta: a binding arising from a beta reduction------ simplNonRecE env b (rhs, rhs_se) body k---   = let env in---     cont< let b = rhs_se(rhs) in body >------ It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process.------ from_what=FromLet => the RHS satisfies the let-can-float invariant--- Otherwise it may or may not satisfy it.--simplNonRecE env from_what bndr (rhs, rhs_se) body cont-  | assert (isId bndr && not (isJoinId bndr) ) $-    is_strict_bind-  = -- Evaluate RHS strictly-    simplExprF (rhs_se `setInScopeFromE` env) rhs-               (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what-                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })--  | otherwise  -- Evaluate RHS lazily-  = do { (env1, bndr1)    <- simplNonRecBndr env bndr-       ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)-       ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive-                                           bndr bndr2 rhs rhs_se-       ; (floats2, expr') <- simplNonRecBody env3 from_what body cont-       ; return (floats1 `addFloats` floats2, expr') }--  where-    is_strict_bind = case from_what of-       FromBeta arg_ty | isUnliftedType arg_ty -> True-         -- If we are coming from a beta-reduction (FromBeta) we must-         -- establish the let-can-float invariant, so go via StrictBind-         -- If not, the invariant holds already, and it's optional.-         -- Using arg_ty: see Note [Dark corner with representation polymorphism]-         -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg-         --      When we come to `x=arg` we myst choose lazy/strict correctly-         --      It's wrong to err in either directly--       _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)----------------------simplRecE :: SimplEnv-          -> [(InId, InExpr)]-          -> InExpr-          -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- simplRecE is used for---  * non-top-level recursive lets in expressions--- Precondition: not a join-point binding-simplRecE env pairs body cont-  = do  { let bndrs = map fst pairs-        ; massert (all (not . isJoinId) bndrs)-        ; env1 <- simplRecBndrs env bndrs-                -- NB: bndrs' don't have unfoldings or rules-                -- We add them as we go down-        ; (floats1, env2)  <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs-        ; (floats2, expr') <- simplExprF env2 body cont-        ; return (floats1 `addFloats` floats2, expr') }--{- Note [Dark corner with representation polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail-if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).-So we are careful to call `isStrictId` on the OutId, not the InId, in case we have-     ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)-That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell-if x is lifted or unlifted from that.--We only get such redexes from the compulsory inlining of a wired-in,-representation-polymorphic function like `rightSection` (see-GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined-such compulsory inlinings already, but belt and braces does no harm.--Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the-Simplifier without first calling SimpleOpt, so anything involving-GHCi or TH and operator sections will fall over if we don't take-care here.--Note [Avoiding exponential behaviour]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One way in which we can get exponential behaviour is if we simplify a-big expression, and then re-simplify it -- and then this happens in a-deeply-nested way.  So we must be jolly careful about re-simplifying-an expression (#13379).  That is why simplNonRecX does not try-preInlineUnconditionally (unlike simplNonRecE).--Example:-  f BIG, where f has a RULE-Then- * We simplify BIG before trying the rule; but the rule does not fire- * We inline f = \x. x True- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)--However, if BIG has /not/ already been simplified, we'd /like/ to-simplify BIG True; maybe good things happen.  That is why--* simplLam has-    - a case for (isSimplified dup), which goes via simplNonRecX, and-    - a case for the un-simplified case, which goes via simplNonRecE--* 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])---************************************************************************-*                                                                      *-                     Join points-*                                                                      *-********************************************************************* -}--{- Note [Rules and unfolding for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   simplExpr (join j x = rhs                         ) cont-             (      {- RULE j (p:ps) = blah -}       )-             (      {- StableUnfolding j = blah -}   )-             (in blah                                )--Then we will push 'cont' into the rhs of 'j'.  But we should *also* push-'cont' into the RHS of-  * Any RULEs for j, e.g. generated by SpecConstr-  * Any stable unfolding for j, e.g. the result of an INLINE pragma--Simplifying rules and stable-unfoldings happens a bit after-simplifying the right-hand side, so we remember whether or not it-is a join point, and what 'cont' is, in a value of type MaybeJoinCont--#13900 was caused by forgetting to push 'cont' into the RHS-of a SpecConstr-generated RULE for a join point.--}--simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr-                     -> InExpr -> SimplCont-                     -> SimplM (SimplFloats, OutExpr)-simplNonRecJoinPoint env bndr rhs body cont-   = assert (isJoinId bndr ) $-     wrapJoinCont env cont $ \ env cont ->-     do { -- We push join_cont into the join RHS and the body;-          -- and wrap wrap_cont around the whole thing-        ; let mult   = contHoleScaling cont-              res_ty = contResultType cont-        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty-        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)-        ; (floats1, env3)  <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env-        ; (floats2, body') <- simplExprF env3 body cont-        ; return (floats1 `addFloats` floats2, body') }----------------------simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]-                  -> InExpr -> SimplCont-                  -> SimplM (SimplFloats, OutExpr)-simplRecJoinPoint env pairs body cont-  = wrapJoinCont env cont $ \ env cont ->-    do { let bndrs  = map fst pairs-             mult   = contHoleScaling cont-             res_ty = contResultType cont-       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty-               -- NB: bndrs' don't have unfoldings or rules-               -- We add them as we go down-       ; (floats1, env2)  <- simplRecBind env1 (BC_Join Recursive cont) pairs-       ; (floats2, body') <- simplExprF env2 body cont-       ; return (floats1 `addFloats` floats2, body') }-----------------------wrapJoinCont :: SimplEnv -> SimplCont-             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))-             -> SimplM (SimplFloats, OutExpr)--- Deal with making the continuation duplicable if necessary,--- and with the no-case-of-case situation.-wrapJoinCont env cont thing_inside-  | contIsStop cont        -- Common case; no need for fancy footwork-  = thing_inside env cont--  | not (seCaseCase env)-    -- See Note [Join points with -fno-case-of-case]-  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))-       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1-       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont-       ; return (floats2 `addFloats` floats3, expr3) }--  | otherwise-    -- Normal case; see Note [Join points and case-of-case]-  = do { (floats1, cont')  <- mkDupableCont env cont-       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'-       ; return (floats1 `addFloats` floats2, result) }------------------------trimJoinCont :: Id         -- Used only in error message-             -> Maybe JoinArity-             -> SimplCont -> SimplCont--- Drop outer context from join point invocation (jump)--- See Note [Join points and case-of-case]--trimJoinCont _ Nothing cont-  = cont -- Not a jump-trimJoinCont var (Just arity) cont-  = trim arity cont-  where-    trim 0 cont@(Stop {})-      = cont-    trim 0 cont-      = mkBoringStop (contResultType cont)-    trim n cont@(ApplyToVal { sc_cont = k })-      = cont { sc_cont = trim (n-1) k }-    trim n cont@(ApplyToTy { sc_cont = k })-      = cont { sc_cont = trim (n-1) k } -- join arity counts types!-    trim _ cont-      = pprPanic "completeCall" $ ppr var $$ ppr cont---{- Note [Join points and case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we perform the case-of-case transform (or otherwise push continuations-inward), we want to treat join points specially. Since they're always-tail-called and we want to maintain this invariant, we can do this (for any-evaluation context E):--  E[join j = e-    in case ... of-         A -> jump j 1-         B -> jump j 2-         C -> f 3]--    -->--  join j = E[e]-  in case ... of-       A -> jump j 1-       B -> jump j 2-       C -> E[f 3]--As is evident from the example, there are two components to this behavior:--  1. When entering the RHS of a join point, copy the context inside.-  2. When a join point is invoked, discard the outer context.--We need to be very careful here to remain consistent---neither part is-optional!--We need do make the continuation E duplicable (since we are duplicating it)-with mkDupableCont.---Note [Join points with -fno-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Supose case-of-case is switched off, and we are simplifying--    case (join j x = <j-rhs> in-          case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--Usually, we'd push the outer continuation (case . of <outer-alts>) into-both the RHS and the body of the join point j.  But since we aren't doing-case-of-case we may then end up with this totally bogus result--    join x = case <j-rhs> of <outer-alts> in-    case (case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--This would be OK in the language of the paper, but not in GHC: j is no longer-a join point.  We can only do the "push continuation into the RHS of the-join point j" if we also push the continuation right down to the /jumps/ to-j, so that it can evaporate there.  If we are doing case-of-case, we'll get to--    join x = case <j-rhs> of <outer-alts> in-    case y of-      A -> j 1-      B -> j 2-      C -> case e of <outer-alts>--which is great.--Bottom line: if case-of-case is off, we must stop pushing the continuation-inwards altogether at any join point.  Instead simplify the (join ... in ...)-with a Stop continuation, and wrap the original continuation around the-outside.  Surprisingly tricky!---************************************************************************-*                                                                      *-                     Variables-*                                                                      *-************************************************************************--Note [zapSubstEnv]-~~~~~~~~~~~~~~~~~~-When simplifying something that has already been simplified, be sure to-zap the SubstEnv.  This is VITAL.  Consider-     let x = e in-     let y = \z -> ...x... in-     \ x -> ...y...--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-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)-So it's fine to zoom straight to `rebuild` which just rebuilds the-call in a very straightforward way.--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--- Look up an InVar in the environment-simplVar env var-  -- Why $! ? See Note [Bangs in the Simplifier]-  | isTyVar var = return $! Type $! (substTyVar env var)-  | isCoVar var = return $! Coercion $! (substCoVar env var)-  | otherwise-  = case substId env var of-        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids-                                in simplExpr env' e-        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-  | otherwise-  = case substId env var of-      ContEx tvs cvs ids e -> simplExprF env' e cont-        -- Don't trimJoinCont; haven't already simplified e,-        -- so the cont is not embodied in e-        where-          env' = setSubstEnv env tvs cvs ids--      DoneId var1 ->-        do { rule_base <- getSimplRules-           ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont-                 info  = mkArgInfo env rule_base var1 cont'-           ; rebuildCall env info cont' }--      DoneEx e mb_join -> simplExprF 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 co cont)-  = rebuildCall env (addCastTo info co) cont--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------------ The runRW# rule. Do this after absorbing all arguments --------- 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-  -- 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-             -- 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)-                -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify-                --    Note [Case-of-case and full laziness]--       -- If the argument is a literal lambda already, take a short cut-       -- This isn't just efficiency:-       --    * If we don't do this we get a beta-redex every time, so the-       --      simplifier keeps doing more iterations.-       --    * Even more important: see Note [No eta-expansion in runRW#]-       ; arg' <- case arg of-           Lam s body -> do { (env', s') <- simplBinder arg_env s-                            ; body' <- simplExprC env' body inner_cont-                            ; return (Lam s' body') }-                            -- Important: do not try to eta-expand this lambda-                            -- See Note [No eta-expansion in runRW#]--           _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy-                   ; let (m,_,_) = splitFunTy fun_ty-                         env'  = arg_env `addNewInScopeIds` [s']-                         cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'-                                            , sc_env = env', sc_cont = inner_cont-                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }-                                -- cont' applies to s', then K-                   ; body' <- simplExprC env' arg cont'-                   ; return (Lam s' body') }--       ; let rr'   = getRuntimeRep new_runrw_res_ty-             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']-       ; rebuild env call' outer_cont }------------ Simplify value arguments ---------------------rebuildCall env fun_info-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_dup = dup_flag, sc_hole_ty = fun_ty-                        , sc_cont = cont })-  -- Argument is already simplified-  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]-  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont--  -- Strict arguments-  | isStrictArgInfo fun_info-  , seCaseCase env    -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify-                      --    Note [Case-of-case and full laziness]-  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $-    simplExprF (arg_se `setInScopeFromE` env) arg-               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty-                          , sc_dup = Simplified-                          , sc_cont = cont })-                -- Note [Shadowing]--  -- Lazy arguments-  | otherwise-        -- DO NOT float anything outside, hence simplExprC-        -- There is no benefit (unlike in a let-binding), and we'd-        -- have to be very careful about bogus strictness through-        -- floating a demanded let.-  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty fun_info)-        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }-  where-    arg_ty = funArgTy fun_ty------------- No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont-  = rebuild env (argInfoExpr fun rev_args) cont--------------------------------------tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)-tryInlining env logger var cont-  | Just expr <- callSiteInline logger uf_opts case_depth var active_unf-                                lone_variable arg_infos interesting_cont-  = do { dump_inline expr cont-       ; return (Just expr) }--  | otherwise-  = return Nothing--  where-    uf_opts    = seUnfoldingOpts env-    case_depth = seCaseDepth env-    (lone_variable, arg_infos, call_cont) = contArgs cont-    interesting_cont = interestingCallContext env call_cont-    active_unf       = activeUnfolding (seMode env) var--    log_inlining doc-      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)-           Opt_D_dump_inlinings-           "" FormatText doc--    dump_inline unfolding cont-      | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()-      | not (logHasDumpFlag logger Opt_D_verbose_core2core)-      = when (isExternalName (idName var)) $-            log_inlining $-                sep [text "Inlining done:", nest 4 (ppr var)]-      | otherwise-      = log_inlining $-           sep [text "Inlining done: " <> ppr var,-                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),-                              text "Cont:  " <+> ppr cont])]---{- Note [Trying rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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--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 exponential behaviour].--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---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.--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.--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.--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:--* mkArgInfo sets the ai_rewrite field to TryRules if there are any rewrite-  rules avaialable for that function.--* 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`.--  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].--* 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.--* GHC.Core.Opt.Simplify.Utils. mkRewriteCall: if there are no rules, and no-  unfolding, we can skip both TryRules and TryInlining, which saves work.--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.--Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider-        f (...(\a -> e)...) (case y of (a,b) -> e')-where f is strict in its second arg-If we simplify the innermost one first we get (...(\a -> e)...)-Simplifying the second arg makes us float the case out, so we end up with-        case y of (a,b) -> f (...(\a -> e)...) e'-So the output does not have the no-shadowing invariant.  However, there is-no danger of getting name-capture, because when the first arg was simplified-we used an in-scope set that at least mentioned all the variables free in its-static environment, and that is enough.--We can't just do innermost first, or we'd end up with a dual problem:-        case x of (a,b) -> f e (...(\a -> e')...)--I spent hours trying to recover the no-shadowing invariant, but I just could-not think of an elegant way to do it.  The simplifier is already knee-deep in-continuations.  We have to keep the right in-scope set around; AND we have-to get the effect that finding (error "foo") in a strict arg position will-discard the entire application and replace it with (error "foo").  Getting-all this at once is TOO HARD!--Note [No eta-expansion in runRW#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we see `runRW# (\s. blah)` we must not attempt to eta-expand that-lambda.  Why not?  Because-* `blah` can mention join points bound outside the runRW#-* eta-expansion uses arityType, and-* `arityType` cannot cope with free join Ids:--So the simplifier spots the literal lambda, and simplifies inside it.-It's a very special lambda, because it is the one the OccAnal spots and-allows join points bound /outside/ to be called /inside/.--See Note [No free join points in arityType] in GHC.Core.Opt.Arity--************************************************************************-*                                                                      *-                Rewrite rules-*                                                                      *-************************************************************************--}--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--{- Disabled until we fix #8326-  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]-  , [_type_arg, val_arg] <- args-  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont-  , isDeadBinder bndr-  = do { let enum_to_tag :: CoreAlt -> CoreAlt-                -- Takes   K -> e  into   tagK# -> e-                -- where tagK# is the tag of constructor K-             enum_to_tag (DataAlt con, [], rhs)-               = assert (isEnumerationTyCon (dataConTyCon con) )-                (LitAlt tag, [], rhs)-              where-                tag = mkLitInt (sePlatform env) (toInteger (dataConTag con - fIRST_TAG))-             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)--             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts-             new_bndr = setIdType bndr intPrimTy-                 -- The binder is dead, but should have the right type-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}--  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)-                                        (activeRule (seMode env)) fn-                                        (argInfoAppArgs 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-                 -- 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--  | otherwise  -- No rule fires-  = do { logger <- getLogger-       ; nodump logger  -- This ensures that an empty file is written-       ; return Nothing }--  where-    ropts      = seRuleOpts env-    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]--    printRuleModule rule-      = parens (maybe (text "BUILTIN")-                      (pprModuleName . moduleName)-                      (ruleModule rule))--    dump logger rule rule_rhs-      | logHasDumpFlag logger Opt_D_dump_rule_rewrites-      = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat-          [ text "Rule:" <+> ftext (ruleName rule)-          , text "Module:" <+>  printRuleModule 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 ]--      | logHasDumpFlag logger Opt_D_dump_rule_firings-      = log_rule Opt_D_dump_rule_firings "Rule fired:" $-          ftext (ruleName rule)-            <+> printRuleModule rule--      | otherwise-      = return ()--    nodump logger-      | logHasDumpFlag logger Opt_D_dump_rule_rewrites-      = liftIO $-          touchDumpFile logger Opt_D_dump_rule_rewrites--      | logHasDumpFlag logger Opt_D_dump_rule_firings-      = liftIO $-          touchDumpFile logger Opt_D_dump_rule_firings--      | otherwise-      = return ()--    log_rule flag hdr details-      = do-      { logger <- getLogger-      ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText-               $ sep [text hdr, nest 4 details]-      }--trySeqRules :: SimplEnv-            -> OutExpr -> InExpr   -- Scrutinee and RHS-            -> SimplCont-            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--- See Note [User-defined RULES for seq]-trySeqRules in_env scrut rhs cont-  = do { rule_base <- getSimplRules-       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }-  where-    no_cast_scrut = drop_casts scrut-    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-    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b-    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty-    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-                        , 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 } ]-    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--{- Note [User-defined RULES for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-   case (scrut |> co) of _ -> rhs-look for rules that match the expression-   seq @t1 @t2 scrut-where scrut :: t1-      rhs   :: t2--If you find a match, rewrite it, and apply to 'rhs'.--Notice that we can simply drop casts on the fly here, which-makes it more likely that a rule will match.--See Note [User-defined RULES for seq] in GHC.Types.Id.Make.--Note [Occurrence-analyse after rule firing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-After firing a rule, we occurrence-analyse the instantiated RHS before-simplifying it.  Usually this doesn't make much difference, but it can-be huge.  Here's an example (simplCore/should_compile/T7785)--  map f (map f (map f xs)--= -- Use build/fold form of map, twice-  map f (build (\cn. foldr (mapFB c f) n-                           (build (\cn. foldr (mapFB c f) n xs))))--= -- Apply fold/build rule-  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))--= -- Beta-reduce-  -- Alas we have no occurrence-analysed, so we don't know-  -- that c is used exactly once-  map f (build (\cn. let c1 = mapFB c f in-                     foldr (mapFB c1 f) n xs))--= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)-  -- We can do this because (mapFB c n) is a PAP and hence expandable-  map f (build (\cn. let c1 = mapFB c n in-                     foldr (mapFB c (f.f)) n x))--This is not too bad.  But now do the same with the outer map, and-we get another use of mapFB, and t can interact with /both/ remaining-mapFB calls in the above expression.  This is stupid because actually-that 'c1' binding is dead.  The outer map introduces another c2. If-there is a deep stack of maps we get lots of dead bindings, and lots-of redundant work as we repeatedly simplify the result of firing rules.--The easy thing to do is simply to occurrence analyse the result of-the rule firing.  Note that this occ-anals not only the RHS of the-rule, but also the function arguments, which by now are OutExprs.-E.g.-      RULE f (g x) = x+1--Call   f (g BIG)  -->   (\x. x+1) BIG--The rule binders are lambda-bound and applied to the OutExpr arguments-(here BIG) which lack all internal occurrence info.--Is this inefficient?  Not really: we are about to walk over the result-of the rule firing to simplify it, so occurrence analysis is at most-a constant factor.--Note, however, that the rule RHS is /already/ occ-analysed; see-Note [OccInfo in unfoldings and rules] in GHC.Core.  There is something-unsatisfactory about doing it twice; but the rule RHS is usually very-small, and this is simple.--Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:--  data Foo = A | B | C--Then we want to transform--   case tagToEnum# x of   ==>    case x of-     A -> e1                       DEFAULT -> e1-     B -> e2                       1#      -> e2-     C -> e3                       2#      -> e3--thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT-alternative we retain it (remember it comes first).  If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.-See #8317.--Note [Rules for recursive functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that we shouldn't apply rules for a loop breaker:-doing so might give rise to an infinite loop, because a RULE is-rather like an extra equation for the function:-     RULE:           f (g x) y = x+y-     Eqn:            f a     y = a-y--But it's too drastic to disable rules for loop breakers.-Even the foldr/build rule would be disabled, because foldr-is recursive, and hence a loop breaker:-     foldr k z (build g) = g k z-So it's up to the programmer: rules can cause divergence---************************************************************************-*                                                                      *-                Rebuilding a case expression-*                                                                      *-************************************************************************--Note [Case elimination]-~~~~~~~~~~~~~~~~~~~~~~~-The case-elimination transformation discards redundant case expressions.-Start with a simple situation:--        case x# of      ===>   let y# = x# in e-          y# -> e--(when x#, y# are of primitive type, of course).  We can't (in general)-do this for algebraic cases, because we might turn bottom into-non-bottom!--The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise-this idea to look for a case where we're scrutinising a variable, and we know-that only the default case can match.  For example:--        case x of-          0#      -> ...-          DEFAULT -> ...(case x of-                         0#      -> ...-                         DEFAULT -> ...) ...--Here the inner case is first trimmed to have only one alternative, the-DEFAULT, after which it's an instance of the previous case.  This-really only shows up in eliminating error-checking code.--Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So--        case e of       ===> case e of DEFAULT -> r-           True  -> r-           False -> r--Now again the case may be eliminated by the CaseElim transformation.-This includes things like (==# a# b#)::Bool so that we simplify-      case ==# a# b# of { True -> x; False -> x }-to just-      x-This particular example shows up in default methods for-comparison operations (e.g. in (>=) for Int.Int32)--Note [Case to let transformation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a case over a lifted type has a single alternative, and is being-used as a strict 'let' (all isDeadBinder bndrs), we may want to do-this transformation:--    case e of r       ===>   let r = e in ...r...-      _ -> ...r...--We treat the unlifted and lifted cases separately:--* Unlifted case: 'e' satisfies exprOkForSpeculation-  (ok-for-spec is needed to satisfy the let-can-float invariant).-  This turns     case a +# b of r -> ...r...-  into           let r = a +# b in ...r...-  and thence     .....(a +# b)....--  However, if we have-      case indexArray# a i of r -> ...r...-  we might like to do the same, and inline the (indexArray# a i).-  But indexArray# is not okForSpeculation, so we don't build a let-  in rebuildCase (lest it get floated *out*), so the inlining doesn't-  happen either.  Annoying.--* Lifted case: we need to be sure that the expression is already-  evaluated (exprIsHNF).  If it's not already evaluated-      - we risk losing exceptions, divergence or-        user-specified thunk-forcing-      - even if 'e' is guaranteed to converge, we don't want to-        create a thunk (call by need) instead of evaluating it-        right away (call by value)--  However, we can turn the case into a /strict/ let if the 'r' is-  used strictly in the body.  Then we won't lose divergence; and-  we won't build a thunk because the let is strict.-  See also Note [Case-to-let for strictly-used binders]--Note [Case-to-let for strictly-used binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have this:-   case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to-   let r = <scrut> in ...r...--This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.--Note that this can change the error behaviour.  For example, we might-transform-    case x of { _ -> error "bad" }-    --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").--Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'.  See #8900 for an example where the loss of this-transformation bit us in practice.--See also Note [Empty case alternatives] in GHC.Core.--Historical notes--There have been various earlier versions of this patch:--* By Sept 18 the code looked like this:-     || scrut_is_demanded_var scrut--    scrut_is_demanded_var :: CoreExpr -> Bool-    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s-    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)-    scrut_is_demanded_var _          = False--  This only fired if the scrutinee was a /variable/, which seems-  an unnecessary restriction. So in #15631 I relaxed it to allow-  arbitrary scrutinees.  Less code, less to explain -- but the change-  had 0.00% effect on nofib.--* Previously, in Jan 13 the code looked like this:-     || case_bndr_evald_next rhs--    case_bndr_evald_next :: CoreExpr -> Bool-      -- See Note [Case binder next]-    case_bndr_evald_next (Var v)         = v == case_bndr-    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e-    case_bndr_evald_next (App e _)       = case_bndr_evald_next e-    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e-    case_bndr_evald_next _               = False--  This patch was part of fixing #7542. See also-  Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.)---Further notes about case elimination-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:       test :: Integer -> IO ()-                test = print--Turns out that this compiles to:-    Print.test-      = \ eta :: Integer-          eta1 :: Void# ->-          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->-          case hPutStr stdout-                 (PrelNum.jtos eta ($w[] @ Char))-                 eta1-          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}--Notice the strange '<' which has no effect at all. This is a funny one.-It started like this:--f x y = if x < 0 then jtos x-          else if y==0 then "" else jtos x--At a particular call site we have (f v 1).  So we inline to get--        if v < 0 then jtos x-        else if 1==0 then "" else jtos x--Now simplify the 1==0 conditional:--        if v<0 then jtos v else jtos v--Now common-up the two branches of the case:--        case (v<0) of DEFAULT -> jtos v--Why don't we drop the case?  Because it's strict in v.  It's technically-wrong to drop even unnecessary evaluations, and in practice they-may be a result of 'seq' so we *definitely* don't want to drop those.-I don't really know how to improve this situation.---Note [FloatBinds from constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have FloatBinds coming from the constructor wrapper-(as in Note [exprIsConApp_maybe on data constructors with wrappers]),-we cannot float past them. We'd need to float the FloatBind-together with the simplify floats, unfortunately the-simplifier doesn't have case-floats. The simplest thing we can-do is to wrap all the floats here. The next iteration of the-simplifier will take care of all these cases and lets.--Given data T = MkT !Bool, this allows us to simplify-case $WMkT b of { MkT x -> f x }-to-case b of { b' -> f b' }.--We could try and be more clever (like maybe wfloats only contain-let binders, so we could float them). But the need for the-extra complication is not clear.--Note [Do not duplicate constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#20125)-   let x = (a,b)-   in ...(case x of x' -> blah)...x...x...--We want that `case` to vanish (since `x` is bound to a data con) leaving-   let x = (a,b)-   in ...(let x'=x in blah)...x..x...--In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,-since is bound to (a,b).  But in eliminating the case, if the scrutinee-is trivial, we want to bind the case-binder to the scrutinee, /not/ to-the constructor application.  Hence the case_bndr_rhs in rebuildCase.--This applies equally to a non-DEFAULT case alternative, say-   let x = (a,b) in ...(case x of x' { (p,q) -> blah })...-This variant is handled by bind_case_bndr in knownCon.--We want to bind x' to x, and not to a duplicated (a,b)).--}--------------------------------------------------------------      Eliminate the case if possible--rebuildCase, reallyRebuildCase-   :: SimplEnv-   -> OutExpr          -- Scrutinee-   -> InId             -- Case binder-   -> [InAlt]          -- Alternatives (increasing order)-   -> SimplCont-   -> SimplM (SimplFloats, OutExpr)-------------------------------------------------------      1. Eliminate the case if there's a known constructor-----------------------------------------------------rebuildCase env scrut case_bndr alts cont-  | Lit lit <- scrut    -- No need for same treatment as constructors-                        -- because literals are inlined more vigorously-  , not (litIsLifted lit)-  = do  { tick (KnownBranch case_bndr)-        ; case findAlt (LitAlt lit) alts of-            Nothing             -> missingAlt env case_bndr alts cont-            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }--  | Just (in_scope', wfloats, con, ty_args, other_args)-      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut-        -- Works when the scrutinee is a variable with a known unfolding-        -- as well as when it's an explicit constructor application-  , let env0 = setInScopeSet env in_scope'-  = do  { tick (KnownBranch case_bndr)-        ; let scaled_wfloats = map scale_float wfloats-              -- case_bndr_unf: see Note [Do not duplicate constructor applications]-              case_bndr_rhs | exprIsTrivial scrut = scrut-                            | otherwise           = con_app-              con_app = Var (dataConWorkId con) `mkTyApps` ty_args-                                                `mkApps`   other_args-        ; case findAlt (DataAlt con) alts of-            Nothing                   -> missingAlt env0 case_bndr alts cont-            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs-            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args-                                                  other_args case_bndr bs rhs cont-        }-  where-    simple_rhs env wfloats case_bndr_rhs bs rhs =-      assert (null bs) $-      do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs-             -- scrut is a constructor application,-             -- hence satisfies let-can-float invariant-         ; (floats2, expr') <- simplExprF env' rhs cont-         ; case wfloats of-             [] -> return (floats1 `addFloats` floats2, expr')-             _ -> return-               -- See Note [FloatBinds from constructor wrappers]-                   ( emptyFloats env,-                     GHC.Core.Make.wrapFloats wfloats $-                     wrapFloats (floats1 `addFloats` floats2) expr' )}--    -- This scales case floats by the multiplicity of the continuation hole (see-    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because-    -- they are aliases anyway.-    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =-      let-        scale_id id = scaleVarBy holeScaling id-      in-      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)-    scale_float f = f--    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr-     -- We are in the following situation-     --   case[p] case[q] u of { D x -> C v } of { C x -> w }-     -- And we are producing case[??] u of { D x -> w[x\v]}-     ---     -- What should the multiplicity `??` be? In order to preserve the usage of-     -- variables in `u`, it needs to be `pq`.-     ---     -- As an illustration, consider the following-     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }-     -- Where C :: A %1 -> T is linear-     -- If we were to produce a case[1], like the inner case, we would get-     --   case[1] of { C x -> (x, x) }-     -- Which is ill-typed with respect to linearity. So it needs to be a-     -- case[Many].-------------------------------------------------------      2. Eliminate the case if scrutinee is evaluated-----------------------------------------------------rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont-  -- See if we can get rid of the case altogether-  -- See Note [Case elimination]-  -- mkCase made sure that if all the alternatives are equal,-  -- then there is now only one (DEFAULT) rhs--  -- 2a.  Dropping the case altogether, if-  --      a) it binds nothing (so it's really just a 'seq')-  --      b) evaluating the scrutinee has no side effects-  | is_plain_seq-  , exprOkForSideEffects scrut-          -- The entire case is dead, so we can drop it-          -- if the scrutinee converges without having imperative-          -- side effects or raising a Haskell exception-          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps-   = simplExprF env rhs cont--  -- 2b.  Turn the case into a let, if-  --      a) it binds only the case-binder-  --      b) unlifted case: the scrutinee is ok-for-speculation-  --           lifted case: the scrutinee is in HNF (or will later be demanded)-  -- See Note [Case to let transformation]-  | all_dead_bndrs-  , doCaseToLet scrut case_bndr-  = do { tick (CaseElim case_bndr)-       ; (floats1, env')  <- simplAuxBind env case_bndr scrut-       ; (floats2, expr') <- simplExprF env' rhs cont-       ; return (floats1 `addFloats` floats2, expr') }--  -- 2c. Try the seq rules if-  --     a) it binds only the case binder-  --     b) a rule for seq applies-  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make-  | 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 }-  where-    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]-    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect--rebuildCase env scrut case_bndr alts cont-  = reallyRebuildCase env scrut case_bndr alts cont---doCaseToLet :: OutExpr          -- Scrutinee-            -> InId             -- Case binder-            -> Bool--- The situation is         case scrut of b { DEFAULT -> body }--- Can we transform thus?   let { b = scrut } in body-doCaseToLet scrut case_bndr-  | isTyCoVar case_bndr    -- Respect GHC.Core-  = isTyCoArg scrut        -- Note [Core type and coercion invariant]--  | isUnliftedType (exprType scrut)-    -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).-    -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'-    -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].-    -- Using `exprType` is typically cheap because `scrut` is typically a variable.-    -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts-    -- the brain more.  Consider that if this test ever turns out to be a perf-    -- problem (which seems unlikely).-  = exprOkForSpeculation scrut--  | otherwise  -- Scrut has a lifted type-  = exprIsHNF scrut-    || isStrUsedDmd (idDemandInfo case_bndr)-    -- See Note [Case-to-let for strictly-used binders]-------------------------------------------------------      3. Catch-all case-----------------------------------------------------reallyRebuildCase env scrut case_bndr alts cont-  | not (seCaseCase env)    -- Only when case-of-case is on.-                            -- See GHC.Driver.Config.Core.Opt.Simplify-                            --    Note [Case-of-case and full laziness]-  = do { case_expr <- simplAlts env scrut case_bndr alts-                                (mkBoringStop (contHoleType cont))-       ; rebuild env case_expr cont }--  | otherwise-  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont-       ; case_expr <- simplAlts env' scrut-                                (scaleIdBy holeScaling case_bndr)-                                (scaleAltsBy holeScaling alts)-                                cont'-       ; return (floats, case_expr) }-  where-    holeScaling = contHoleScaling cont-    -- Note [Scaling in case-of-case]--{--simplCaseBinder checks whether the scrutinee is a variable, v.  If so,-try to eliminate uses of v in the RHSs in favour of case_bndr; that-way, there's a chance that v will now only be used once, and hence-inlined.--Historical note: we use to do the "case binder swap" in the Simplifier-so there were additional complications if the scrutinee was a variable.-Now the binder-swap stuff is done in the occurrence analyser; see-"GHC.Core.Opt.OccurAnal" Note [Binder swap].--Note [knownCon occ info]-~~~~~~~~~~~~~~~~~~~~~~~~-If the case binder is not dead, then neither are the pattern bound-variables:-        case <any> of x { (a,b) ->-        case x of { (p,q) -> p } }-Here (a,b) both look dead, but come alive after the inner case is eliminated.-The point is that we bring into the envt a binding-        let x = (a,b)-after the outer case, and that makes (a,b) alive.  At least we do unless-the case binder is guaranteed dead.--Note [Case alternative occ info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are simply reconstructing a case (the common case), we always-zap the occurrence info on the binders in the alternatives.  Even-if the case binder is dead, the scrutinee is usually a variable, and *that*-can bring the case-alternative binders back to life.-See Note [Add unfolding for scrutinee]--Note [Improving seq]-~~~~~~~~~~~~~~~~~~~-Consider-        type family F :: * -> *-        type instance F Int = Int--We'd like to transform-        case e of (x :: F Int) { DEFAULT -> rhs }-===>-        case e `cast` co of (x'::Int)-           I# x# -> let x = x' `cast` sym co-                    in rhs--so that 'rhs' can take advantage of the form of x'.  Notice that Note-[Case of cast] (in OccurAnal) may then apply to the result.--We'd also like to eliminate empty types (#13468). So if--    data Void-    type instance F Bool = Void--then we'd like to transform-        case (x :: F Bool) of { _ -> error "urk" }-===>-        case (x |> co) of (x' :: Void) of {}--Nota Bene: we used to have a built-in rule for 'seq' that dropped-casts, so that-    case (x |> co) of { _ -> blah }-dropped the cast; in order to improve the chances of trySeqRules-firing.  But that works in the /opposite/ direction to Note [Improving-seq] so there's a danger of flip/flopping.  Better to make trySeqRules-insensitive to the cast, which is now is.--The need for [Improving seq] showed up in Roman's experiments.  Example:-  foo :: F Int -> Int -> Int-  foo t n = t `seq` bar n-     where-       bar 0 = 0-       bar n = bar (n - case t of TI i -> i)-Here we'd like to avoid repeated evaluating t inside the loop, by-taking advantage of the `seq`.--At one point I did transformation in LiberateCase, but it's more-robust here.  (Otherwise, there's a danger that we'll simply drop the-'seq' altogether, before LiberateCase gets to see it.)--Note [Scaling in case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When two cases commute, if done naively, the multiplicities will be wrong:--  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]-  { (z[Many], t[Many]) -> z-  }--The multiplicities here, are correct, but if I perform a case of case:--  case u of w[1]-  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }-  }--This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and-`y` must have multiplicities `Many` not `1`! The correct solution is to make-all the `1`-s be `Many`-s instead:--  case u of w[Many]-  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }-  }--In general, when commuting two cases, the rule has to be:--  case (case … of x[p] {…}) of y[q] { … }-  ===> case … of x[p*q] { … case … of y[q] { … } }--This is materialised, in the simplifier, by the fact that every time we simplify-case alternatives with a continuation (the surrounded case (or more!)), we must-scale the entire case we are simplifying, by a scaling factor which can be-computed in the continuation (with function `contHoleScaling`).--}--simplAlts :: SimplEnv-          -> OutExpr         -- Scrutinee-          -> InId            -- Case binder-          -> [InAlt]         -- Non-empty-          -> SimplCont-          -> SimplM OutExpr  -- Returns the complete simplified case expression--simplAlts env0 scrut case_bndr alts cont'-  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr-                                      , text "cont':" <+> ppr cont'-                                      , text "in_scope" <+> ppr (seInScope env0) ])-        ; (env1, case_bndr1) <- simplBinder env0 case_bndr-        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding-              env2       = modifyInScope env1 case_bndr2-              -- See Note [Case binder evaluated-ness]-              fam_envs   = seFamEnvs env0--        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut-                                                       case_bndr case_bndr2 alts--        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts-          -- NB: it's possible that the returned in_alts is empty: this is handled-          --     by the caller (rebuildCase) in the missingAlt function-          -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts-          --     See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils--        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts---      ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()--        ; let alts_ty' = contResultType cont'-        -- See Note [Avoiding space leaks in OutType]-        ; seqType alts_ty' `seq`-          mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' }----------------------------------------improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv-           -> OutExpr -> InId -> OutId -> [InAlt]-           -> SimplM (SimplEnv, OutExpr, OutId)--- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]-  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)-  = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing-              env2 = extendIdSubst env case_bndr rhs-        ; return (env2, scrut `Cast` co, case_bndr2) }--improveSeq _ env scrut _ case_bndr1 _-  = return (env, scrut, case_bndr1)----------------------------------------simplAlt :: SimplEnv-         -> Maybe OutExpr  -- The scrutinee-         -> [AltCon]       -- These constructors can't be present when-                           -- matching the DEFAULT alternative-         -> OutId          -- The case binder-         -> SimplCont-         -> InAlt-         -> SimplM OutAlt--simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)-  = assert (null bndrs) $-    do  { let env' = addBinderUnfolding env case_bndr'-                                        (mkOtherCon imposs_deflt_cons)-                -- Record the constructors that the case-binder *can't* be.-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt DEFAULT [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)-  = assert (null bndrs) $-    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt (LitAlt lit) [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)-  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]-          let vs_with_evals = addEvals scrut' con vs-        ; (env', vs') <- simplBinders env vs_with_evals--                -- Bind the case-binder to (con args)-        ; let inst_tys' = tyConAppArgs (idType case_bndr')-              con_app :: OutExpr-              con_app   = mkConApp2 con inst_tys' vs'--        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app-        ; rhs' <- simplExprC env'' rhs cont'-        ; return (Alt (DataAlt con) vs' rhs') }--{- Note [Adding evaluatedness info to pattern-bound variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-addEvals records the evaluated-ness of the bound variables of-a case pattern.  This is *important*.  Consider--     data T = T !Int !Int--     case x of { T a b -> T (a+1) b }--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--NB: simplLamBndrs preserves this eval info--In addition to handling data constructor fields with !s, addEvals-also records the fact that the result of seq# is always in WHNF.-See Note [seq# magic] in GHC.Core.Opt.ConstantFold.  Example (#15226):--  case seq# v s of-    (# s', v' #) -> E--we want the compiler to be aware that v' is in WHNF in E.--Open problem: we don't record that v itself is in WHNF (and we can't-do it here).  The right thing is to do some kind of binder-swap;-see #15226 for discussion.--}--addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]--- See Note [Adding evaluatedness info to pattern-bound variables]-addEvals scrut con vs-  -- Deal with seq# applications-  | Just scr <- scrut-  , isUnboxedTupleDataCon con-  , [s,x] <- vs-    -- Use stripNArgs rather than collectArgsTicks to avoid building-    -- a list of arguments only to throw it away immediately.-  , Just (Var f) <- stripNArgs 4 scr-  , Just SeqOp <- isPrimOpId_maybe f-  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x-  = [s, x']--  -- Deal with banged datacon fields-addEvals _scrut con vs = go vs the_strs-    where-      the_strs = dataConRepStrictness con--      go [] [] = []-      go (v:vs') strs | isTyVar v = v : go vs' strs-      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs-      go _ _ = pprPanic "Simplify.addEvals"-                (ppr con $$-                 ppr vs  $$-                 ppr_with_length (map strdisp the_strs) $$-                 ppr_with_length (dataConRepArgTys con) $$-                 ppr_with_length (dataConRepStrictness con))-        where-          ppr_with_length list-            = ppr list <+> parens (text "length =" <+> ppr (length list))-          strdisp :: StrictnessMark -> SDoc-          strdisp MarkedStrict = text "MarkedStrict"-          strdisp NotMarkedStrict = text "NotMarkedStrict"--zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id-zapIdOccInfoAndSetEvald str v =-  setCaseBndrEvald str $ -- Add eval'dness info-  zapIdOccInfo v         -- And kill occ info;-                         -- see Note [Case alternative occ info]--addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv-addAltUnfoldings env mb_scrut case_bndr con_app-  = do { let con_app_unf = mk_simple_unf con_app-             env1 = addBinderUnfolding env case_bndr con_app_unf--             -- See Note [Add unfolding for scrutinee]-             env2 | Just scrut <- mb_scrut-                  , Just (v,mco) <- scrutBinderSwap_maybe scrut-                  = addBinderUnfolding env1 v $-                       if isReflMCo mco  -- isReflMCo: avoid calling mk_simple_unf-                       then con_app_unf  --            twice in the common case-                       else mk_simple_unf (mkCastMCo con_app mco)--                  | otherwise = env1--       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr mb_scrut, ppr con_app])-       ; return env2 }-  where-    -- Force the opts, so that the whole SimplEnv isn't retained-    !opts = seUnfoldingOpts env-    mk_simple_unf = mkSimpleUnfolding opts--addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv-addBinderUnfolding env bndr unf-  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf-  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))-          "unfolding type mismatch"-          (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $-          modifyInScope env (bndr `setIdUnfolding` unf)--  | otherwise-  = modifyInScope env (bndr `setIdUnfolding` unf)--zapBndrOccInfo :: Bool -> Id -> Id--- Consider  case e of b { (a,b) -> ... }--- Then if we bind b to (a,b) in "...", and b is not dead,--- then we must zap the deadness info on a,b-zapBndrOccInfo keep_occ_info pat_id-  | keep_occ_info = pat_id-  | otherwise     = zapIdOccInfo pat_id--{- Note [Case binder evaluated-ness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin on a (OtherCon []) unfolding to the case-binder of a Case,-even though it'll be over-ridden in every case alternative with a more-informative unfolding.  Why?  Because suppose a later, less clever, pass-simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let-can-float invariant.  Example-    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....-                ; K       -> blah }--The let-can-float invariant requires that y is evaluated in the call to-reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we-propagate binders to occurrences.--This showed up in #13027.--Note [Add unfolding for scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general it's unlikely that a variable scrutinee will appear-in the case alternatives   case x of { ...x unlikely to appear... }-because the binder-swap in OccurAnal has got rid of all such occurrences-See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".--BUT it is still VERY IMPORTANT to add a suitable unfolding for a-variable scrutinee, in simplAlt.  Here's why-   case x of y-     (a,b) -> case b of c-                I# v -> ...(f y)...-There is no occurrence of 'b' in the (...(f y)...).  But y gets-the unfolding (a,b), and *that* mentions b.  If f has a RULE-    RULE f (p, I# q) = ...-we want that rule to match, so we must extend the in-scope env with a-suitable unfolding for 'y'.  It's *essential* for rule matching; but-it's also good for case-elimination -- suppose that 'f' was inlined-and did multi-level case analysis, then we'd solve it in one-simplifier sweep instead of two.--HOWEVER, given-  case x of y { Just a -> r1; Nothing -> r2 }-we do not want to add the unfolding x -> y to 'x', which might seem cool,-since 'y' itself has different unfoldings in r1 and r2.  Reason: if we-did that, we'd have to zap y's deadness info and that is a very useful-piece of information.--So instead we add the unfolding x -> Just a, and x -> Nothing in the-respective RHSs.--Since this transformation is tantamount to a binder swap, we use-GHC.Core.Opt.OccurAnal.scrutBinderSwap_maybe to do the check.--Exactly the same issue arises in GHC.Core.Opt.SpecConstr;-see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr---************************************************************************-*                                                                      *-\subsection{Known constructor}-*                                                                      *-************************************************************************--We are a bit careful with occurrence info.  Here's an example--        (\x* -> case x of (a*, b) -> f a) (h v, e)--where the * means "occurs once".  This effectively becomes-        case (h v, e) of (a*, b) -> f a)-and then-        let a* = h v; b = e in f a-and then-        f (h v)--All this should happen in one sweep.--}--knownCon :: SimplEnv-         -> OutExpr                                           -- The scrutinee-         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)-         -> InId -> [InBndr] -> InExpr                        -- The alternative-         -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont-  = do  { (floats1, env1)  <- bind_args env bs dc_args-        ; (floats2, env2)  <- bind_case_bndr env1-        ; (floats3, expr') <- simplExprF env2 rhs cont-        ; case dc_floats of-            [] ->-              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')-            _ ->-              return ( emptyFloats env-               -- See Note [FloatBinds from constructor wrappers]-                     , GHC.Core.Make.wrapFloats dc_floats $-                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }-  where-    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId--                  -- Ugh!-    bind_args env' [] _  = return (emptyFloats env', env')--    bind_args env' (b:bs') (Type ty : args)-      = assert (isTyVar b )-        bind_args (extendTvSubst env' b ty) bs' args--    bind_args env' (b:bs') (Coercion co : args)-      = assert (isCoVar b )-        bind_args (extendCvSubst env' b co) bs' args--    bind_args env' (b:bs') (arg : args)-      = assert (isId b) $-        do { let b' = zap_occ b-             -- zap_occ: the binder might be "dead", because it doesn't-             -- occur in the RHS; and simplAuxBind may therefore discard it.-             -- Nevertheless we must keep it if the case-binder is alive,-             -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplAuxBind env' b' arg  -- arg satisfies let-can-float invariant-           ; (floats2, env3)  <- bind_args env2 bs' args-           ; return (floats1 `addFloats` floats2, env3) }--    bind_args _ _ _ =-      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$-                             text "scrut:" <+> ppr scrut--       -- It's useful to bind bndr to scrut, rather than to a fresh-       -- binding      x = Con arg1 .. argn-       -- because very often the scrut is a variable, so we avoid-       -- creating, and then subsequently eliminating, a let-binding-       -- BUT, if scrut is a not a variable, we must be careful-       -- about duplicating the arg redexes; in that case, make-       -- a new con-app from the args-    bind_case_bndr env-      | isDeadBinder bndr   = return (emptyFloats env, env)-      | exprIsTrivial scrut = return (emptyFloats env-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))-                              -- See Note [Do not duplicate constructor applications]-      | otherwise           = do { dc_args <- mapM (simplVar env) bs-                                         -- dc_ty_args are already OutTypes,-                                         -- but bs are InBndrs-                                 ; let con_app = Var (dataConWorkId dc)-                                                 `mkTyApps` dc_ty_args-                                                 `mkApps`   dc_args-                                 ; simplAuxBind env bndr con_app }----------------------missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont-           -> SimplM (SimplFloats, OutExpr)-                -- This isn't strictly an error, although it is unusual.-                -- It's possible that the simplifier might "see" that-                -- an inner case has no accessible alternatives before-                -- it "sees" that the entire branch of an outer case is-                -- inaccessible.  So we simply put an error case here instead.-missingAlt env case_bndr _ cont-  = warnPprTrace True "missingAlt" (ppr case_bndr) $-    -- See Note [Avoiding space leaks in OutType]-    let cont_ty = contResultType cont-    in seqType cont_ty `seq`-       return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt")--{--************************************************************************-*                                                                      *-\subsection{Duplicating continuations}-*                                                                      *-************************************************************************--Consider-  let x* = case e of { True -> e1; False -> e2 }-  in b-where x* is a strict binding.  Then mkDupableCont will be given-the continuation-   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop-and will split it into-   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop-   join floats:  $j1 = e1, $j2 = e2-   non_dupable:  let x* = [] in b; stop--Putting this back together would give-   let x* = let { $j1 = e1; $j2 = e2 } in-            case e of { True -> $j1; False -> $j2 }-   in b-(Of course we only do this if 'e' wants to duplicate that continuation.)-Note how important it is that the new join points wrap around the-inner expression, and not around the whole thing.--In contrast, any let-bindings introduced by mkDupableCont can wrap-around the entire thing.--Note [Bottom alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have-     case (case x of { A -> error .. ; B -> e; C -> error ..)-       of alts-then we can just duplicate those alts because the A and C cases-will disappear immediately.  This is more direct than creating-join points and inlining them away.  See #4930.--}-----------------------mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont-                  -> SimplM ( SimplFloats  -- Join points (if any)-                            , SimplEnv     -- Use this for the alts-                            , SimplCont)-mkDupableCaseCont env alts cont-  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont-                           ; let env' = bumpCaseDepth $-                                        env `setInScopeFromF` floats-                           ; return (floats, env', cont) }-  | otherwise         = return (emptyFloats env, env, cont)--altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative-altsWouldDup []  = False        -- See Note [Bottom alternatives]-altsWouldDup [_] = False-altsWouldDup (alt:alts)-  | is_bot_alt alt = altsWouldDup alts-  | otherwise      = not (all is_bot_alt alts)-    -- otherwise case: first alt is non-bot, so all the rest must be bot-  where-    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs----------------------------mkDupableCont :: SimplEnv-              -> SimplCont-              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with-                                       --   extra let/join-floats and in-scope variables-                        , SimplCont)   -- dup_cont: duplicable continuation-mkDupableCont env cont-  = mkDupableContWithDmds env (repeat topDmd) cont--mkDupableContWithDmds-   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite-   -> SimplCont -> SimplM ( SimplFloats, SimplCont)--mkDupableContWithDmds env _ cont-  | contIsDupable cont-  = return (emptyFloats env, cont)--mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn--mkDupableContWithDmds env dmds (CastIt ty cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, CastIt ty cont') }---- Duplicating ticks for now, not sure if this is good or not-mkDupableContWithDmds env dmds (TickIt t cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, TickIt t cont') }--mkDupableContWithDmds env _-     (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what-                 , sc_env = se, sc_cont = cont})--- See Note [Duplicating StrictBind]--- K[ let x = <> in b ]  -->   join j x = K[ b ]---                             j <>-  = do { let sb_env = se `setInScopeFromE` env-       ; (sb_env1, bndr')      <- simplBinder sb_env bndr-       ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont-          -- No need to use mkDupableCont before simplNonRecBody; we-          -- use cont once here, and then share the result if necessary--       ; let join_body = wrapFloats floats1 join_inner-             res_ty    = contResultType cont--       ; mkDupableStrictBind env bndr' join_body res_ty }--mkDupableContWithDmds env _-    (StrictArg { sc_fun = fun, sc_cont = cont-               , sc_fun_ty = fun_ty })-  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-  | isNothing (isDataConId_maybe (ai_fun fun))-  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]-  = -- Use Plan A of Note [Duplicating StrictArg]-    do { let (_ : dmds) = 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-       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)-                                           (ai_args fun)-       ; return ( foldl' addLetFloats floats1 floats_s-                , StrictArg { sc_fun = fun { ai_args = args' }-                            , sc_cont = cont'-                            , sc_fun_ty = fun_ty-                            , sc_dup = OkToDup} ) }--  | otherwise-  = -- Use Plan B of Note [Duplicating StrictArg]-    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]-    --                         j <>-    do { let rhs_ty       = contResultType cont-             (m,arg_ty,_) = splitFunTy fun_ty-       ; arg_bndr <- newId (fsLit "arg") m arg_ty-       ; let env' = env `addNewInScopeIds` [arg_bndr]-       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont-       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }-  where-    thumbsUpPlanA (StrictArg {})               = False-    thumbsUpPlanA (CastIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (Select {})                  = True-    thumbsUpPlanA (StrictBind {})              = True-    thumbsUpPlanA (Stop {})                    = True--mkDupableContWithDmds env dmds-    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, ApplyToTy { sc_cont = cont'-                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env dmds-    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se-                , sc_cont = cont, sc_hole_ty = hole_ty })-  =     -- e.g.         [...hole...] (...arg...)-        --      ==>-        --              let a = ...arg...-        --              in [...hole...] a-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { let (dmd:cont_dmds) = dmds   -- Never fails-        ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont-        ; let env' = env `setInScopeFromF` floats1-        ; (_, se', arg') <- simplArg env' dup hole_ty se arg-        ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'-        ; let all_floats = floats1 `addLetFloats` let_floats2-        ; return ( all_floats-                 , ApplyToVal { sc_arg = arg''-                              , sc_env = se' `setInScopeFromF` all_floats-                                         -- Ensure that sc_env includes the free vars of-                                         -- arg'' in its in-scope set, even if makeTrivial-                                         -- has turned arg'' into a fresh variable-                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                              , sc_dup = OkToDup, sc_cont = cont'-                              , sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env _-    (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })-  =     -- e.g.         (case [...hole...] of { pi -> ei })-        --      ===>-        --              let ji = \xij -> ei-        --              in case [...hole...] of { pi -> ji xij }-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { tick (CaseOfCase case_bndr)-        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont-                -- NB: We call mkDupableCaseCont here to make cont duplicable-                --     (if necessary, depending on the number of alts)-                -- And this is important: see Note [Fusing case continuations]--        ; let cont_scaling = contHoleScaling cont-          -- See Note [Scaling in case-of-case]-        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)-        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)-        -- Safe to say that there are no handled-cons for the DEFAULT case-                -- NB: simplBinder does not zap deadness occ-info, so-                -- a dead case_bndr' will still advertise its deadness-                -- This is really important because in-                --      case e of b { (# p,q #) -> ... }-                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),-                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.-                -- In the new alts we build, we have the new case binder, so it must retain-                -- its deadness.-        -- NB: we don't use alt_env further; it has the substEnv for-        --     the alternatives, and we don't want that--        ; let platform = sePlatform env-        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt platform case_bndr')-                                              emptyJoinFloats alts'--        ; let all_floats = floats `addJoinFloats` join_floats-                           -- Note [Duplicated env]-        ; return (all_floats-                 , Select { sc_dup  = OkToDup-                          , sc_bndr = case_bndr'-                          , sc_alts = alts''-                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats-                                      -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                          , sc_cont = mkBoringStop (contResultType cont) } ) }--mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType-                    -> SimplM (SimplFloats, SimplCont)-mkDupableStrictBind env arg_bndr join_rhs res_ty-  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]-  = return (emptyFloats env-           , StrictBind { sc_bndr = arg_bndr-                        , sc_body = join_rhs-                        , sc_env  = zapSubstEnv env-                        , sc_from = FromLet-                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                        , sc_dup  = OkToDup-                        , sc_cont = mkBoringStop res_ty } )-  | otherwise-  = do { join_bndr <- newJoinId [arg_bndr] res_ty-       ; let arg_info = ArgInfo { ai_fun   = join_bndr-                                , ai_rewrite = TryNothing, ai_args  = []-                                , ai_encl  = False, ai_dmds  = repeat topDmd-                                , ai_discs = repeat 0 }-       ; return ( addJoinFloats (emptyFloats env) $-                  unitJoinFloat                   $-                  NonRec join_bndr                $-                  Lam (setOneShotLambda arg_bndr) join_rhs-                , StrictArg { sc_dup    = OkToDup-                            , sc_fun    = arg_info-                            , sc_fun_ty = idType join_bndr-                            , sc_cont   = mkBoringStop res_ty-                            } ) }--mkDupableAlt :: Platform -> OutId-             -> JoinFloats -> OutAlt-             -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)-  | exprIsTrivial alt_rhs_in   -- See point (2) of Note [Duplicating join points]-  = return (jfloats, Alt con alt_bndrs alt_rhs_in)--  | otherwise-  = do  { let rhs_ty'  = exprType alt_rhs_in--              bangs-                | DataAlt c <- con-                = dataConRepStrictness c-                | otherwise = []--              abstracted_binders = abstract_binders alt_bndrs bangs--              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]-              abstract_binders [] []-                -- Abstract over the case binder too if it's used.-                | isDeadBinder case_bndr  = []-                | otherwise               = [(case_bndr,MarkedStrict)]-              abstract_binders (alt_bndr:alt_bndrs) marks-                -- Abstract over all type variables just in case-                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks-              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)-                -- The deadness info on the new Ids is preserved by simplBinders-                -- We don't abstract over dead ids here.-                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks-                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks-              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)--              filtered_binders = map fst abstracted_binders-              -- We want to make any binder with an evaldUnfolding strict in the rhs.-              -- See Note [Call-by-value for worker args] (which also applies to join points)-              (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in--              final_args = varsToCoreExprs filtered_binders-                           -- Note [Join point abstraction]--                -- We make the lambdas into one-shot-lambdas.  The-                -- join point is sure to be applied at most once, and doing so-                -- prevents the body of the join point being floated out by-                -- the full laziness pass-              final_bndrs     = map one_shot filtered_binders-              one_shot v | isId v    = setOneShotLambda v-                         | otherwise = v--              -- No lambda binder has an unfolding, but (currently) case binders can,-              -- so we must zap them here.-              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs--        ; join_bndr <- newJoinId filtered_binders rhs_ty'--        ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = Alt con alt_bndrs join_call--        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)-                 , alt') }-                -- See Note [Duplicated env]--{--Note [Fusing case continuations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important to fuse two successive case continuations when the-first has one alternative.  That's why we call prepareCaseCont here.-Consider this, which arises from thunk splitting (see Note [Thunk-splitting] in GHC.Core.Opt.WorkWrap):--      let-        x* = case (case v of {pn -> rn}) of-               I# a -> I# a-      in body--The simplifier will find-    (Var v) with continuation-            Select (pn -> rn) (-            Select [I# a -> I# a] (-            StrictBind body Stop--So we'll call mkDupableCont on-   Select [I# a -> I# a] (StrictBind body Stop)-There is just one alternative in the first Select, so we want to-simplify the rhs (I# a) with continuation (StrictBind body Stop)-Supposing that body is big, we end up with-          let $j a = <let x = I# a in body>-          in case v of { pn -> case rn of-                                 I# a -> $j a }-This is just what we want because the rn produces a box that-the case rn cancels with.--See #4957 a fuller example.--Note [Duplicating join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-IN #19996 we discovered that we want to be really careful about-inlining join points.   Consider-    case (join $j x = K f x )-         (in case v of      )-         (     p1 -> $j x1  ) of-         (     p2 -> $j x2  )-         (     p3 -> $j x3  )-      K g y -> blah[g,y]--Here the join-point RHS is very small, just a constructor-application (K x y).  So we might inline it to get-    case (case v of        )-         (     p1 -> K f x1  ) of-         (     p2 -> K f x2  )-         (     p3 -> K f x3  )-      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]-    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.--To achieve this:--1. Do not postInlineUnconditionally a join point, until the Final-   phase.  (The Final phase is still quite early, so we might consider-   delaying still more.)--2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for-   all alternatives, except for exprIsTrival RHSs. Previously we used-   exprIsDupable.  This generates a lot more join points, but makes-   them much more case-of-case friendly.--   It is definitely worth checking for exprIsTrivial, otherwise we get-   an extra Simplifier iteration, because it is inlined in the next-   round.--3. 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.  That same Note explains why we-   want Plan A when the RHS of the new join point would be a-   non-data-constructor application--4. You might worry that $j will be inlined by the call-site inliner,-   but it won't because the call-site context for a join is usually-   extremely boring (the arguments come from the pattern match).-   And if not, then perhaps inlining it would be a good idea.--   You might also wonder if we get UnfWhen, because the RHS of the-   join point is no bigger than the call. But in the cases we care-   about it will be a little bigger, because of that free `f` in-       $j x = K f x-   So for now we don't do anything special in callSiteInline--There is a bit of tension between (2) and (3).  Do we want to retain-the join point only when the RHS is-* a constructor application? or-* just non-trivial?-Currently, a bit ad-hoc, but we definitely want to retain the join-point for data constructors in mkDupalbleALt (point 2); that is the-whole point of #19996 described above.--Historical Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: this entire Note is now irrelevant.  In Jun 21 we stopped-adding unfoldings to lambda binders (#17530).  It was always a-hack and bit us in multiple small and not-so-small ways--Consider this-   case (case .. ) of c {-     I# c# -> ....c....--If we make a join point with c but not c# we get-  $j = \c -> ....c....--But if later inlining scrutinises the c, thus--  $j = \c -> ... case c of { I# y -> ... } ...--we won't see that 'c' has already been scrutinised.  This actually-happens in the 'tabulate' function in wave4main, and makes a significant-difference to allocation.--An alternative plan is this:--   $j = \c# -> let c = I# c# in ...c....--but that is bad if 'c' is *not* later scrutinised.--So instead we do both: we pass 'c' and 'c#' , and record in c's inlining-(a stable unfolding) that it's really I# c#, thus--   $j = \c# -> \c[=I# c#] -> ...c....--Absence analysis may later discard 'c'.--NB: take great care when doing strictness analysis;-    see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.--Also note that we can still end up passing stuff that isn't used.  Before-strictness analysis we have-   let $j x y c{=(x,y)} = (h c, ...)-   in ...-After strictness analysis we see that h is strict, we end up with-   let $j x y c{=(x,y)} = ($wh x y, ...)-and c is unused.--Note [Duplicated env]-~~~~~~~~~~~~~~~~~~~~~-Some of the alternatives are simplified, but have not been turned into a join point-So they *must* have a zapped subst-env.  So we can't use completeNonRecX to-bind the join point, because it might to do PostInlineUnconditionally, and-we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,-but zapping it (as we do in mkDupableCont, the Select case) is safe, and-at worst delays the join-point inlining.--Note [Funky mkLamTypes]-~~~~~~~~~~~~~~~~~~~~~~-Notice the funky mkLamTypes.  If the constructor has existentials-it's possible that the join point will be abstracted over-type variables as well as term variables.- Example:  Suppose we have-        data T = forall t.  C [t]- Then faced with-        case (case e of ...) of-            C t xs::[t] -> rhs- We get the join point-        let j :: forall t. [t] -> ...-            j = /\t \xs::[t] -> rhs-        in-        case (case e of ...) of-            C t xs::[t] -> j t xs--Note [Duplicating StrictArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Dealing with making a StrictArg continuation duplicable has turned out-to be one of the trickiest corners of the simplifier, giving rise-to several cases in which the simplier expanded the program's size-*exponentially*.  They include-  #13253 exponential inlining-  #10421 ditto-  #18140 strict constructors-  #18282 another nested-function call case--Suppose we have a call-  f e1 (case x of { True -> r1; False -> r2 }) e3-and f is strict in its second argument.  Then we end up in-mkDupableCont with a StrictArg continuation for (f e1 <> e3).-There are two ways to make it duplicable.--* Plan A: move the entire call inwards, being careful not-  to duplicate e1 or e3, thus:-     let a1 = e1-         a3 = e3-     in case x of { True  -> f a1 r1 a3-                  ; False -> f a1 r2 a3 }--* Plan B: make a join point:-     join $j x = f e1 x e3-     in case x of { True  -> jump $j r1-                  ; False -> jump $j r2 }--  Notice that Plan B is very like the way we handle strict bindings;-  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd-  get if we turned use a case expression to evaluate the strict arg:--       case (case x of { True -> r1; False -> r2 }) of-         r -> f e1 r e3--  So, looking at Note [Duplicating join points], we also want Plan B-  when `f` is a data constructor.--Plan A is often good. Here's an example from #3116-     go (n+1) (case l of-                 1  -> bs'-                 _  -> Chunk p fpc (o+1) (l-1) bs')--If we pushed the entire call for 'go' inside the case, we get-call-pattern specialisation for 'go', which is *crucial* for-this particular program.--Here is another example.-        && E (case x of { T -> F; F -> T })--Pushing the call inward (being careful not to duplicate E)-        let a = E-        in case x of { T -> && a F; F -> && a T }--and now the (&& a F) etc can optimise.  Moreover there might-be a RULE for the function that can fire when it "sees" the-particular case alternative.--But Plan A can have terrible, terrible behaviour. Here is a classic-case:-  f (f (f (f (f True))))--Suppose f is strict, and has a body that is small enough to inline.-The innermost call inlines (seeing the True) to give-  f (f (f (f (case v of { True -> e1; False -> e2 }))))--Now, suppose we naively push the entire continuation into both-case branches (it doesn't look large, just f.f.f.f). We get-  case v of-    True  -> f (f (f (f e1)))-    False -> f (f (f (f e2)))--And now the process repeats, so we end up with an exponentially large-number of copies of f. No good!--CONCLUSION: we want Plan A in general, but do Plan B is there a-danger of this nested call behaviour. The function that decides-this is called thumbsUpPlanA.--Note [Keeping demand info in StrictArg Plan A]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Following on from Note [Duplicating StrictArg], another common code-pattern that can go bad is this:-   f (case x1 of { T -> F; F -> T })-     (case x2 of { T -> F; F -> T })-     ...etc...-when f is strict in all its arguments.  (It might, for example, be a-strict data constructor whose wrapper has not yet been inlined.)--We use Plan A (because there is no nesting) giving-  let a2 = case x2 of ...-      a3 = case x3 of ...-  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }--Now we must be careful!  a2 and a3 are small, and the OneOcc code in-postInlineUnconditionally may inline them both at both sites; see Note-Note [Inline small things to avoid creating a thunk] in-Simplify.Utils. But if we do inline them, the entire process will-repeat -- back to exponential behaviour.--So we are careful to keep the demand-info on a2 and a3.  Then they'll-be /strict/ let-bindings, which will be dealt with by StrictBind.-That's why contIsDupableWithDmds is careful to propagage demand-info to the auxiliary bindings it creates.  See the Demand argument-to makeTrivial.--Note [Duplicating StrictBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictBind duplicable in a very similar way to-that for case expressions.  After all,-   let x* = e in b   is similar to    case e of x -> b--So we potentially make a join-point for the body, thus:-   let x = <> in b   ==>   join j x = b-                           in j <>--Just like StrictArg in fact -- and indeed they share code.--Note [Join point abstraction]  Historical note-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This note is now historical, describing how (in the past) we used-to add a void argument to nullary join points.  But now that "join-point" is not a fuzzy concept but a formal syntactic construct (as-distinguished by the JoinId constructor of IdDetails), each of these-concerns is handled separately, with no need for a vestigial extra-argument.--Join points always have at least one value argument,-for several reasons--* If we try to lift a primitive-typed something out-  for let-binding-purposes, we will *caseify* it (!),-  with potentially-disastrous strictness results.  So-  instead we turn it into a function: \v -> e-  where v::Void#.  The value passed to this function is void,-  which generates (almost) no code.--* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now-  we make the join point into a function whenever used_bndrs'-  is empty.  This makes the join-point more CPR friendly.-  Consider:       let j = if .. then I# 3 else I# 4-                  in case .. of { A -> j; B -> j; C -> ... }--  Now CPR doesn't w/w j because it's a thunk, so-  that means that the enclosing function can't w/w either,-  which is a lose.  Here's the example that happened in practice:-          kgmod :: Int -> Int -> Int-          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0-                      then 78-                      else 5--* Let-no-escape.  We want a join point to turn into a let-no-escape-  so that it is implemented as a jump, and one of the conditions-  for LNE is that it's not updatable.  In CoreToStg, see-  Note [What is a non-escaping let]--* Floating.  Since a join point will be entered once, no sharing is-  gained by floating out, but something might be lost by doing-  so because it might be allocated.--I have seen a case alternative like this:-        True -> \v -> ...-It's a bit silly to add the realWorld dummy arg in this case, making-        $j = \s v -> ...-           True -> $j s-(the \v alone is enough to make CPR happy) but I think it's rare--There's a slight infelicity here: we pass the overall-case_bndr to all the join points if it's used in *any* RHS,-because we don't know its usage in each RHS separately----************************************************************************-*                                                                      *-                    Unfoldings-*                                                                      *-************************************************************************--}--simplLetUnfolding :: SimplEnv-                  -> BindContext-                  -> InId-                  -> OutExpr -> OutType -> ArityType-                  -> Unfolding -> SimplM Unfolding-simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf-  | isStableUnfolding unf-  = simplStableUnfolding env bind_cxt id rhs_ty arity unf-  | isExitJoinId id-  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify-  | otherwise-  = -- Otherwise, we end up retaining all the SimpleEnv-    let !opts = seUnfoldingOpts env-    in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs----------------------mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource-               -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding !uf_opts top_lvl src id new_rhs-  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing)-            -- We make an  unfolding *even for loop-breakers*.-            -- Reason: (a) It might be useful to know that they are WHNF-            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to-            --             expose the unfolding then indeed we *have* an unfolding-            --             to expose.  (We could instead use the RHS, but currently-            --             we don't.)  The simple thing is always to have one.-  where-    -- Might as well force this, profiles indicate up to 0.5MB of thunks-    -- just from this site.-    !is_top_lvl   = isTopLevel top_lvl-    -- See Note [Force bottoming field]-    !is_bottoming = isDeadEndId id----------------------simplStableUnfolding :: SimplEnv -> BindContext-                     -> InId-                     -> OutType-                     -> ArityType      -- Used to eta expand, but only for non-join-points-                     -> Unfolding-                     ->SimplM Unfolding--- Note [Setting the new unfolding]-simplStableUnfolding env bind_cxt id rhs_ty id_arity unf-  = case unf of-      NoUnfolding   -> return unf-      BootUnfolding -> return unf-      OtherCon {}   -> return unf--      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }-        -> do { (env', bndrs') <- simplBinders unf_env bndrs-              ; args' <- mapM (simplExpr env') args-              ; return (mkDFunUnfolding bndrs' con args') }--      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }-        | isStableSource src-        -> do { expr' <- case bind_cxt of-                  BC_Join _ cont    -> -- Binder is a join point-                                       -- See Note [Rules and unfolding for join points]-                                       simplJoinRhs unf_env id expr cont-                  BC_Let _ is_rec -> -- Binder is not a join point-                                     do { let cont = mkRhsStop rhs_ty is_rec topDmd-                                           -- mkRhsStop: switch off eta-expansion at the top level-                                        ; expr' <- simplExprC unf_env expr cont-                                        ; return (eta_expand expr') }-              ; case guide of-                  UnfWhen { ug_boring_ok = boring_ok }-                     -- Happens for INLINE things-                     -- Really important to force new_boring_ok since otherwise-                     --   `ug_boring_ok` is a thunk chain of-                     --   inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ...-                     -- See #20134-                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'-                            guide' = guide { ug_boring_ok = new_boring_ok }-                        -- Refresh the boring-ok flag, in case expr'-                        -- has got small. This happens, notably in the inlinings-                        -- for dfuns for single-method classes; see-                        -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.-                        -- A test case is #4138-                        -- But retain a previous boring_ok of True; e.g. see-                        -- the way it is set in calcUnfoldingGuidanceWithArity-                        in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')-                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold--                  _other              -- Happens for INLINABLE things-                     -> mkLetUnfolding uf_opts top_lvl src id expr' }-                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE-                -- unfolding, and we need to make sure the guidance is kept up-                -- to date with respect to any changes in the unfolding.--        | otherwise -> return noUnfolding   -- Discard unstable unfoldings-  where-    uf_opts    = seUnfoldingOpts env-    -- Forcing this can save about 0.5MB of max residency and the result-    -- is small and easy to compute so might as well force it.-    top_lvl     = bindContextLevel bind_cxt-    !is_top_lvl = isTopLevel top_lvl-    act        = idInlineActivation id-    unf_env    = updMode (updModeForStableUnfoldings act) env-         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils--    -- See Note [Eta-expand stable unfoldings]-    -- Use the arity from the main Id (in id_arity), rather than computing it from rhs-    -- Not used for join points-    eta_expand expr | seEtaExpand env-                    , exprArity expr < arityTypeArity id_arity-                    , wantEtaExpansion expr-                    = etaExpandAT (getInScope env) id_arity expr-                    | otherwise-                    = expr--{- Note [Eta-expand stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For INLINE/INLINABLE things (which get stable unfoldings) there's a danger-of getting-   f :: Int -> Int -> Int -> Blah-   [ Arity = 3                 -- Good arity-   , Unf=Stable (\xy. blah)    -- Less good arity, only 2-   f = \pqr. e--This can happen because f's RHS is optimised more vigorously than-its stable unfolding.  Now suppose we have a call-   g = f x-Because f has arity=3, g will have arity=2.  But if we inline f (using-its stable unfolding) g's arity will reduce to 1, because <blah>-hasn't been optimised yet.  This happened in the 'parsec' library,-for Text.Pasec.Char.string.--Generally, if we know that 'f' has arity N, it seems sensible to-eta-expand the stable unfolding to arity N too. Simple and consistent.--Wrinkles--* See Historical-note [Eta-expansion in stable unfoldings] in-  GHC.Core.Opt.Simplify.Utils--* Don't eta-expand a trivial expr, else each pass will eta-reduce it,-  and then eta-expand again. See Note [Which RHSs do we eta-expand?]-  in GHC.Core.Opt.Simplify.Utils.--* Don't eta-expand join points; see Note [Do not eta-expand join points]-  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point-  case (bind_cxt = BC_Join {}) doesn't use eta_expand.--Note [Force bottoming field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to force bottoming, or the new unfolding holds-on to the old unfolding (which is part of the id).--Note [Setting the new unfolding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we-  should do nothing at all, but simplifying gently might get rid of-  more crap.--* If not, we make an unfolding from the new RHS.  But *only* for-  non-loop-breakers. Making loop breakers not have an unfolding at all-  means that we can avoid tests in exprIsConApp, for example.  This is-  important: if exprIsConApp says 'yes' for a recursive thing, then we-  can get into an infinite loop--If there's a stable unfolding on a loop breaker (which happens for-INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the-user did say 'INLINE'.  May need to revisit this choice.--************************************************************************-*                                                                      *-                    Rules-*                                                                      *-************************************************************************--Note [Rules in a letrec]-~~~~~~~~~~~~~~~~~~~~~~~~-After creating fresh binders for the binders of a letrec, we-substitute the RULES and add them back onto the binders; this is done-*before* processing any of the RHSs.  This is important.  Manuel found-cases where he really, really wanted a RULE for a recursive function-to apply in that function's own right-hand side.--See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"--}--addBndrRules :: SimplEnv -> InBndr -> OutBndr-             -> BindContext-             -> SimplM (SimplEnv, OutBndr)--- Rules are added back into the bin-addBndrRules env in_id out_id bind_cxt-  | null old_rules-  = return (env, out_id)-  | otherwise-  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt-       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules-       ; return (modifyInScope env final_id, final_id) }-  where-    old_rules = ruleInfoRules (idSpecialisation in_id)--simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]--- Simplify local rules for imported Ids-simplImpRules env rules-  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)--simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]-           -> BindContext -> SimplM [CoreRule]-simplRules env mb_new_id rules bind_cxt-  = mapM simpl_rule rules-  where-    simpl_rule rule@(BuiltinRule {})-      = return rule--    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs-                          , ru_act = act })-      = do { (env', bndrs') <- simplBinders env bndrs-           ; let rhs_ty = substTy env' (exprType rhs)-                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]-                                BC_Let {}      -> mkBoringStop rhs_ty-                                BC_Join _ cont -> assertPpr join_ok bad_join_msg cont-                 lhs_env = updMode updModeForRules env'-                 rhs_env = updMode (updModeForStableUnfoldings act) env'-                           -- See Note [Simplifying the RHS of a RULE]-                 -- Force this to avoid retaining reference to old Id-                 !fn_name' = case mb_new_id of-                              Just id -> idName id-                              Nothing -> fn_name--                 -- join_ok is an assertion check that the join-arity of the-                 -- binder matches that of the rule, so that pushing the-                 -- continuation into the RHS makes sense-                 join_ok = case mb_new_id of-                             Just id | Just join_arity <- isJoinId_maybe id-                                     -> length args == join_arity-                             _ -> False-                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]+module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.ConstantFold+import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Inline+import GHC.Core.Opt.Simplify.Utils+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified GHC.Core.Make+import GHC.Core.Coercion hiding ( substCo, substCoVar )+import GHC.Core.Reduction+import GHC.Core.Coercion.Opt    ( optCoercion )+import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )+import GHC.Core.DataCon+import GHC.Core.Opt.Stats ( Tick(..) )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Utils+import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe+                          , pushCoTyArg, pushCoValArg, exprIsDeadEnd+                          , typeArity, arityTypeArity, etaExpandAT )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.FVs     ( mkRuleInfo {- exprsFreeIds -} )+import GHC.Core.Rules   ( lookupRule, getRules )+import GHC.Core.Multiplicity++import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326+import GHC.Types.SourceText+import GHC.Types.Id+import GHC.Types.Id.Make   ( seqId )+import GHC.Types.Id.Info+import GHC.Types.Name   ( mkSystemVarName, isExternalName, getOccFS )+import GHC.Types.Demand+import GHC.Types.Unique ( hasKey )+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var    ( isTyCoVar )+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )+import GHC.Builtin.Names( runRWKey, seqHashKey )++import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )+import GHC.Data.FastString+import GHC.Unit.Module ( moduleName )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad  ( mapAccumLM, liftIO )+import GHC.Utils.Logger+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+the simplifier is in GHC.Core.Opt.Pipeline++Note [The big picture]+~~~~~~~~~~~~~~~~~~~~~~+The general shape of the simplifier is this:++  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)++ * SimplEnv contains+     - Simplifier mode+     - Ambient substitution+     - InScopeSet++ * SimplFloats contains+     - Let-floats (which includes ok-for-spec case-floats)+     - Join floats+     - InScopeSet (including all the floats)++ * Expressions+      simplExpr :: SimplEnv -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+   The result of simplifying an /expression/ is (floats, expr)+      - A bunch of floats (let bindings, join bindings)+      - A simplified expression.+   The overall result is effectively (let floats in expr)++ * Bindings+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)+   The result of simplifying a binding is+     - A bunch of floats, the last of which is the simplified binding+       There may be auxiliary bindings too; see prepareRhs+     - An environment suitable for simplifying the scope of the binding++   The floats may also be empty, if the binding is inlined unconditionally;+   in that case the returned SimplEnv will have an augmented substitution.++   The returned floats and env both have an in-scope set, and they are+   guaranteed to be the same.++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.++Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++    (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++   case x of y { Node a b -> ...y...+               ; Leaf v   -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.++Note [Bangs in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both SimplFloats and SimplEnv do *not* generally benefit from making+their fields strict. I don't know if this is because of good use of+laziness or unintended side effects like closures capturing more variables+after WW has run.++But the end result is that we keep these lazy, but force them in some places+where we know it's beneficial to the compiler.++Similarly environments returned from functions aren't *always* beneficial to+force. In some places they would never be demanded so forcing them early+increases allocation. In other places they almost always get demanded so+it's worthwhile to force them early.++Would it be better to through every allocation of e.g. SimplEnv and decide+wether or not to make this one strict? Absolutely! Would be a good use of+someones time? Absolutely not! I made these strict that showed up during+a profiled build or which I noticed while looking at core for one reason+or another.++The result sadly is that we end up with "random" bangs in the simplifier+where we sometimes force e.g. the returned environment from a function and+sometimes we don't for the same function. Depending on the context around+the call. The treatment is also not very consistent. I only added bangs+where I saw it making a difference either in the core or benchmarks. Some+patterns where it would be beneficial aren't convered as a consequence as+I neither have the time to go through all of the core and some cases are+too small to show up in benchmarks.++++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+-- See Note [The big picture]+simplTopBinds env0 binds0+  = do  {       -- Put all the top-level binders into scope at the start+                -- so that if a rewrite rule has unexpectedly brought+                -- anything into scope, then we don't get a complaint about that.+                -- It's rather as if the top-level binders were imported.+                -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".+        -- See Note [Bangs in the Simplifier]+        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0+        ; freeTick SimplifierDone+        ; return (floats, env2) }+  where+        -- We need to track the zapped top-level binders, because+        -- they should have their fragile IdInfo zapped (notably occurrence info)+        -- That's why we run down binds and bndrs' simultaneously.+        --+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+    simpl_binds env []           = return (emptyFloats env, env)+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind+                                      ; (floats, env2) <- simpl_binds env1 binds+                                      -- See Note [Bangs in the Simplifier]+                                      ; let !floats1 = float `addFloats` floats+                                      ; return (floats1, env2) }++    simpl_bind env (Rec pairs)+      = simplRecBind env (BC_Let TopLevel Recursive) pairs+    simpl_bind env (NonRec b r)+      = do { let bind_cxt = BC_Let TopLevel NonRecursive+           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt+           ; simplRecOrTopPair env' bind_cxt b b' r }++{-+************************************************************************+*                                                                      *+        Lazy bindings+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> BindContext+             -> [(InId, InExpr)]+             -> SimplM (SimplFloats, SimplEnv)+simplRecBind env0 bind_cxt pairs0+  = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0+        ; let new_bndrs = map sndOf3 triples+        ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->+                                go env triples+        ; return (mkRecFloats rec_floats, env2) }+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return (emptyFloats env, env)++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { (float, env1) <- simplRecOrTopPair env bind_cxt+                                                  old_bndr new_bndr rhs+             ; (floats, env2) <- go env1 pairs+             ; return (float `addFloats` floats, env2) }++{-+simplOrTopPair is used for+        * recursive bindings (whether top level or not)+        * top-level non-recursive bindings++It assumes the binder has already been simplified, but not its IdInfo.+-}++simplRecOrTopPair :: SimplEnv+                  -> BindContext+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM (SimplFloats, SimplEnv)++simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)+                                          old_bndr rhs env+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}+    simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | otherwise+  = case bind_cxt of+      BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $+                             simplJoinBind is_rec cont+                                           (old_bndr,env) (new_bndr,env) (rhs,env)++      BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $+                               simplLazyBind top_lvl is_rec+                                             (old_bndr,env) (new_bndr,env) (rhs,env)++simplTrace :: String -> SDoc -> SimplM a -> SimplM a+simplTrace herald doc thing_inside = do+  logger <- getLogger+  if logHasDumpFlag logger Opt_D_verbose_core2core+    then logTraceMsg logger herald doc thing_inside+    else thing_inside++--------------------------+simplLazyBind :: TopLevelFlag -> RecFlag+              -> (InId, SimplEnv)       -- InBinder, and static env for its unfolding (if any)+              -> (OutId, SimplEnv)      -- OutBinder, and SimplEnv after simplifying that binder+                                        -- The OutId has IdInfo (notably RULES),+                                        -- except arity, unfolding+              -> (InExpr, SimplEnv)     -- The RHS and its static environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: Ids only, no TyVars; not a JoinId+-- Precondition: rhs obeys the let-can-float invariant+simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)+  = assert (isId bndr )+    assertPpr (not (isJoinId bndr)) (ppr bndr) $+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]+                (tvs, body) = case collectTyAndValBinders rhs of+                                (tvs, [], body)+                                  | surely_not_lam body -> (tvs, body)+                                _                       -> ([], rhs)++                surely_not_lam (Lam {})     = False+                surely_not_lam (Tick t e)+                  | not (tickishFloatable t) = surely_not_lam e+                   -- eta-reduction could float+                surely_not_lam _            = True+                        -- Do not do the "abstract tyvar" thing if there's+                        -- a lambda inside, because it defeats eta-reduction+                        --    f = /\a. \x. g a x+                        -- should eta-reduce.++        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs+                -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils++        -- Simplify the RHS+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+                                   is_rec (idDemandInfo bndr)+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont++        -- ANF-ise a constructor or PAP rhs+        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}+                                   prepareBinding env top_lvl is_rec+                                                  False  -- Not strict; this is simplLazyBind+                                                  bndr1 body_floats0 body0+          -- Subtle point: we do not need or want tvs' in the InScope set+          -- of body_floats2, so we pass in 'env' not 'body_env'.+          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do+          -- more renaming than necessary => extra work (see !7777 and test T16577).+          -- Don't need: we wrap tvs' around the RHS anyway.++        ; (rhs_floats, body3)+            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating+                     {-#SCC "simplLazyBind-simple-floating" #-}+                     return (body_floats2, body2)++                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}+                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl+                                                                tvs' body_floats2 body2+                        ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; return (poly_floats, body3) }++        ; let env1 = env `setInScopeFromF` rhs_floats+        ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont+        ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: RecFlag+              -> SimplCont+              -> (InId, SimplEnv)       -- InBinder, with static env for its unfolding+              -> (OutId, SimplEnv)      -- OutBinder; SimplEnv has the binder in scope+                                        -- The OutId has IdInfo, except arity, unfolding+              -> (InExpr, SimplEnv)     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se)+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) }++--------------------------+simplAuxBind :: String+             -> SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of completeBindX used to construct non-recursive+-- auxiliary bindings, notably in knownCon.+--+-- The binder comes from a case expression (case binder or alternative)+-- and so does not have rules, unfolding, inline pragmas etc.+--+-- Precondition: rhs satisfies the let-can-float invariant++simplAuxBind _str env bndr new_rhs+  | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid+                                     --  creating the binding c = (a,b)++  -- Next we have a fast-path for cases that would be inlined unconditionally by+  -- completeBind: but it seems not uncommon, and it turns to be a little more+  -- efficient (in compile time allocations) to do it here.+  -- Effectively this is just a vastly-simplified postInlineUnconditionally+  --   See Note [Post-inline for single-use things] in GHC.Core.Opt.Simplify.Utils+  -- We could instead use postInlineUnconditionally itself, but I think it's simpler+  --   and more direct to focus on the "hot" cases.+  -- e.g. auxiliary bindings have no NOLINE pragmas, RULEs, or stable unfoldings+  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...+    || case (idOccInfo bndr) of+          OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True+          _                                                 -> False+  = return ( emptyFloats env+           , extendCvIdSubst env bndr new_rhs )  -- bndr can be a CoVar++  | otherwise+  = do  { -- ANF-ise the RHS+          let !occ_fs = getOccFS bndr+        ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs+        ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)+        ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats++          -- Simplify the binder and complete the binding+        ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr+        ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (new_bndr, rhs1, env1)++        ; return (rhs_floats `addFloats` bind_float, env2) }+++{- *********************************************************************+*                                                                      *+           Cast worker/wrapper+*                                                                      *+************************************************************************++Note [Cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a binding+   x = e |> co+we want to do something very similar to worker/wrapper:+   $wx = e+   x = $wx |> co++We call this making a cast worker/wrapper in tryCastWorkerWrapper.++The main motivaiton is that x can be inlined freely.  There's a chance+that e will be a constructor application or function, or something+like that, so moving the coercion to the usage site may well cancel+the coercions and lead to further optimisation.  Example:++     data family T a :: *+     data instance T Int = T Int++     foo :: Int -> Int -> Int+     foo m n = ...+        where+          t = T m+          go 0 = 0+          go n = case t of { T m -> go (n-m) }+                -- This case should optimise++A second reason for doing cast worker/wrapper is that the worker/wrapper+pass after strictness analysis can't deal with RHSs like+     f = (\ a b c. blah) |> co+Instead, it relies on cast worker/wrapper to get rid of the cast,+leaving a simpler job for demand-analysis worker/wrapper.  See #19874.++Wrinkles++1. We must /not/ do cast w/w on+     f = g |> co+   otherwise it'll just keep repeating forever! You might think this+   is avoided because the call to tryCastWorkerWrapper is guarded by+   preInlineUnconditinally, but I'm worried that a loop-breaker or an+   exported Id might say False to preInlineUnonditionally.++2. We need to be careful with inline/noinline pragmas:+       rec { {-# NOINLINE f #-}+             f = (...g...) |> co+           ; g = ...f... }+   This is legitimate -- it tells GHC to use f as the loop breaker+   rather than g.  Now we do the cast thing, to get something like+       rec { $wf = ...g...+           ; f = $wf |> co+           ; g = ...f... }+   Where should the NOINLINE pragma go?  If we leave it on f we'll get+     rec { $wf = ...g...+         ; {-# NOINLINE f #-}+           f = $wf |> co+         ; g = ...f... }+   and that is bad: the whole point is that we want to inline that+   cast!  We want to transfer the pagma to $wf:+      rec { {-# NOINLINE $wf #-}+            $wf = ...g...+          ; f = $wf |> co+          ; g = ...f... }+   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.+      {- f: Stable unfolding = <stable-big> -}+      f = (\xy. <big-body>) |> co+   Then we want to w/w to+      {- $wf: Stable unfolding = <stable-big> |> sym co -}+      $wf = \xy. <big-body>+      f = $wf |> co+   Notice that the stable unfolding moves to the worker!  Now demand analysis+   will work fine on $wf, whereas it has trouble with the original f.+   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.+   This point also applies to strong loopbreakers with INLINE pragmas, see+   wrinkle (4).++4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence+   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to+   loop-breakers) because they'll definitely be inlined anyway, cast and+   all. And if we do cast w/w for an INLINE function with arity zero, we get+   something really silly: we inline that "worker" right back into the wrapper!+   Worse than a no-op, because we have then lost the stable unfolding.++All these wrinkles are exactly like worker/wrapper for strictness analysis:+  f is the wrapper and must inline like crazy+  $wf is the worker and must carry f's original pragma+See Note [Worker/wrapper for INLINABLE functions]+and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++See #17673, #18093, #18078, #19890.++Note [Preserve strictness in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Cast worker/wrapper] transformation, keep the strictness info.+Eg+        f = e `cast` co    -- f has strictness SSL+When we transform to+        f' = e             -- f' also has strictness SSL+        f = f' `cast` co   -- f still has strictness SSL++Its not wrong to drop it on the floor, but better to keep it.++Note [Preserve RuntimeRep info in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not do cast w/w when the presence of the coercion is needed in order+to determine the runtime representation.++Example:++  Suppose we have a type family:++    type F :: RuntimeRep+    type family F where+      F = LiftedRep++  together with a type `ty :: TYPE F` and a top-level binding++    a :: ty |> TYPE F[0]++  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.+  However, were we to apply cast w/w, we would get:++    b :: ty+    b = ...++    a :: ty |> TYPE F[0]+    a = b `cast` GRefl (TYPE F[0])++  Now we are in trouble because `ty :: TYPE F` does not have a known runtime+  representation, because we need to be able to reduce the nullary type family+  application `F` to find that out.++Conclusion: only do cast w/w when doing so would not lose the RuntimeRep+information. That is, when handling `Cast rhs co`, don't attempt cast w/w+unless the kind of the type of rhs is concrete, in the sense of+Note [Concrete types] in GHC.Tc.Utils.Concrete.+-}++tryCastWorkerWrapper :: SimplEnv -> BindContext+                     -> InId -> OutId -> OutExpr+                     -> SimplM (SimplFloats, SimplEnv)+-- See Note [Cast worker/wrapper]+tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)+  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points+  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform+                        --            a DFunUnfolding in mk_worker_unfolding+  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1+  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4+  , typeHasFixedRuntimeRep work_ty    -- Don't peel off a cast if doing so would+                                      -- lose the underlying runtime representation.+                                      -- See Note [Preserve RuntimeRep info in cast w/w]+  , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings+                                                   -- See Note [OPAQUE pragma]+  = do  { uniq <- getUniqueM+        ; let work_name = mkSystemVarName uniq occ_fs+              work_id   = mkLocalIdWithInfo work_name ManyTy work_ty work_info+              is_strict = isStrictId bndr++        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict+                                                   work_id (emptyFloats env) rhs++        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs+        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf+               floats   = rhs_floats `addLetFloats`+                          unitLetFloat (NonRec work_id_w_unf work_rhs)++               triv_rhs = Cast (Var work_id_w_unf) co++        ; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs+             -- Almost always True, because the RHS is trivial+             -- In that case we want to eliminate the binding fast+             -- We conservatively use postInlineUnconditionally so that we+             -- check all the right things+          then do { tick (PostInlineUnconditionally bndr)+                  ; return ( floats+                           , extendIdSubst (setInScopeFromF env floats) old_bndr $+                             DoneEx triv_rhs NotJoinPoint ) }++          else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs+                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)+                                `setIdUnfolding`  wrap_unf+                        floats' = floats `extendFloats` NonRec bndr' triv_rhs+                  ; return ( floats', setInScopeFromF env floats' ) } }+  where+    -- Force the occ_fs so that the old Id is not retained in the new Id.+    !occ_fs = getOccFS bndr+    work_ty = coercionLKind co+    info   = idInfo bndr+    work_arity = arityInfo info `min` typeArity work_ty++    work_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info+                              `setCprSigInfo`     cprSigInfo info+                              `setDemandInfo`     demandInfo info+                              `setInlinePragInfo` inlinePragInfo info+                              `setArityInfo`      work_arity+           -- We do /not/ want to transfer OccInfo, Rules+           -- Note [Preserve strictness in cast w/w]+           -- and Wrinkle 2 of Note [Cast worker/wrapper]++    ----------- Worker unfolding -----------+    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);+    --   the next round of simplification will do the job+    -- Non-stable case: use work_rhs+    -- Wrinkle 3 of Note [Cast worker/wrapper]+    mk_worker_unfolding top_lvl work_id work_rhs+      = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers+           unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })+           _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs++tryCastWorkerWrapper env _ _ bndr rhs  -- All other bindings+  = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr+                                   , text "rhs:" <+> ppr rhs ])+        ; return (mkFloatBind env (NonRec bndr rhs)) }++mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma+-- See Note [Cast worker/wrapper]+mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })+  = InlinePragma { inl_src    = SourceText $ fsLit "{-# INLINE"+                 , inl_inline = fn_inl       -- See Note [Worker/wrapper for INLINABLE functions]+                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap+                 , inl_act    = wrap_act     -- See Note [Wrapper activation]+                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap+                                -- RuleMatchInfo is (and must be) unaffected+  where+    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap+    -- But simpler, because we don't need to disable during InitialPhase+    wrap_act | isNeverActive fn_act = activateDuringFinal+             | otherwise            = fn_act+++{- *********************************************************************+*                                                                      *+           prepareBinding, prepareRhs, makeTrivial+*                                                                      *+********************************************************************* -}++prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool+               -> Id   -- Used only for its OccName; can be InId or OutId+               -> SimplFloats -> OutExpr+               -> SimplM (SimplFloats, OutExpr)+-- In (prepareBinding ... bndr floats rhs), the binding is really just+--    bndr = let floats in rhs+-- Maybe we can ANF-ise this binding and float out; e.g.+--    bndr = let a = f x in K a a (g x)+-- we could float out to give+--    a    = f x+--    tmp  = g x+--    bndr = K a a tmp+-- That's what prepareBinding does+-- Precondition: binder is not a JoinId+-- Postcondition: the returned SimplFloats contains only let-floats+prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs+  = do { -- Never float join-floats out of a non-join let-binding (which this is)+         -- So wrap the body in the join-floats right now+         -- Hence: rhs_floats1 consists only of let-floats+         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs++         -- rhs_env: add to in-scope set the binders from rhs_floats+         -- so that prepareRhs knows what is in scope in rhs+       ; let rhs_env = env `setInScopeFromF` rhs_floats1+             -- Force the occ_fs so that the old Id is not retained in the new Id.+             !occ_fs = getOccFS bndr++       -- Now ANF-ise the remaining rhs+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1++       -- Finally, decide whether or not to float+       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats+       ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2+         then -- Float!+              do { tick LetFloatFromLet+                 ; return (all_floats, rhs2) }++         else -- Abandon floating altogether; revert to original rhs+              -- Since we have already built rhs1, we just need to add+              -- rhs_floats1 to it+              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }++{- Note [prepareRhs]+~~~~~~~~~~~~~~~~~~~~+prepareRhs takes a putative RHS, checks whether it's a PAP or+constructor application and, if so, converts it to ANF, so that the+resulting thing can be inlined more easily.  Thus+        x = (f a, g b)+becomes+        t1 = f a+        t2 = g b+        x = (t1,t2)++We also want to deal well cases like this+        v = (f e1 `cast` co) e2+Here we want to make e1,e2 trivial and get+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2+That's what the 'go' loop in prepareRhs does+-}++prepareRhs :: HasDebugCallStack+           => SimplEnv -> TopLevelFlag+           -> FastString    -- Base for any new variables+           -> OutExpr+           -> SimplM (LetFloats, OutExpr)+-- Transforms a RHS into a better RHS by ANF'ing args+-- for expandable RHSs: constructors and PAPs+-- e.g        x = Just e+-- becomes    a = e               -- 'a' is fresh+--            x = Just a+-- See Note [prepareRhs]+prepareRhs env top_lvl occ rhs0+  | is_expandable = anfise rhs0+  | otherwise     = return (emptyLetFloats, rhs0)+  where+    -- We can't use exprIsExpandable because the WHOLE POINT is that+    -- we want to treat (K <big>) as expandable, because we are just+    -- about "anfise" the <big> expression.  exprIsExpandable would+    -- just say no!+    is_expandable = go rhs0 0+       where+         go (Var fun) n_val_args       = isExpandableApp fun n_val_args+         go (App fun arg) n_val_args+           | isTypeArg arg             = go fun n_val_args+           | otherwise                 = go fun (n_val_args + 1)+         go (Cast rhs _)  n_val_args   = go rhs n_val_args+         go (Tick _ rhs)  n_val_args   = go rhs n_val_args+         go _             _            = False++    anfise :: OutExpr -> SimplM (LetFloats, OutExpr)+    anfise (Cast rhs co)+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Cast rhs' co) }+    anfise (App fun (Type ty))+        = do { (floats, rhs') <- anfise fun+             ; return (floats, App rhs' (Type ty)) }+    anfise (App fun arg)+        = do { (floats1, fun') <- anfise fun+             ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+             ; return (floats1 `addLetFlts` floats2, App fun' arg') }+    anfise (Var fun)+        = return (emptyLetFloats, Var fun)++    anfise (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Tick t rhs') }++        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | (not (tickishCounts t) || tickishCanSplit t)+        = do { (floats, rhs') <- anfise rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (floats', Tick t rhs') }++    anfise other = return (emptyLetFloats, other)++makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)+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@(TyArg {})+  = return (emptyLetFloats, arg)++makeTrivial :: HasDebugCallStack+            => SimplEnv -> TopLevelFlag -> Demand+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]+makeTrivial env top_lvl dmd occ_fs expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (emptyLetFloats, expr)++  | Cast expr' co <- expr+  = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'+       ; return (floats, Cast triv_expr co) }++  | otherwise -- 'expr' is not of form (Cast e co)+  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr+        ; uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdWithInfo name ManyTy expr_ty id_info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditionally part+        ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1+          -- Technically we should extend the in-scope set in 'env' with+          -- the 'floats' from prepareRHS; but they are all fresh, so there is+          -- no danger of introducing name shadowing in eta expansion++        ; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2++        ; let final_id = addLetBndrInfo var arity_type unf+              bind     = NonRec final_id expr2++        ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }+  where+    id_info = vanillaIdInfo `setDemandInfo` dmd+    expr_ty = exprType expr++bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool+-- True iff we can have a binding of this expression at this level+-- Precondition: the type is the type of the expression+bindingOk top_lvl expr expr_ty+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty+  | otherwise          = True++{- Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   f :: Int -> Addr#++   foo :: Bar+   foo = Bar (f 3)++Then we can't ANF-ise foo, even though we'd like to, because+we can't make a top-level binding for the Addr# (f 3). And if+so we don't want to turn it into+   foo = let x = f 3 in Bar x+because we'll just end up inlining x back, and that makes the+simplifier loop.  Better not to ANF-ise it at all.++Literal strings are an exception.++   foo = Ptr "blob"#++We want to turn this into:++   foo1 = "blob"#+   foo = Ptr foo1++See Note [Core top-level string literals] in GHC.Core.++************************************************************************+*                                                                      *+          Completing a lazy binding+*                                                                      *+************************************************************************++completeBind+  * deals only with Ids, not TyVars+  * takes an already-simplified binder and RHS+  * is used for both recursive and non-recursive bindings+  * is used for both top-level and non-top-level bindings++It does the following:+  - tries discarding a dead binding+  - tries PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity+  - extend the InScopeSet of the SimplEnv++It does *not* attempt to do let-to-case.  Why?  Because it is used for+  - top-level bindings (when let-to-case is impossible)+  - many situations where the "rhs" is known to be a WHNF+                (so let-to-case is inappropriate).++Nor does it do the atomic-argument thing+-}++completeBind :: BindContext+             -> (InId, SimplEnv)           -- Old binder, and the static envt in which to simplify+                                           --   its stable unfolding (if any)+             -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId.+                                           -- And the SimplEnv with that OutId in scope.+             -> SimplM (SimplFloats, SimplEnv)+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Binder /can/ be a JoinId+-- Precondition: rhs obeys the let-can-float invariant+completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))++ | otherwise+ = assert (isId new_bndr) $+   do { let old_info = idInfo old_bndr+            old_unf  = realUnfoldingInfo old_info++         -- Do eta-expansion on the RHS of the binding+         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs++        -- Simplify the unfolding; see Note [Environment for simplLetUnfolding]+      ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env)+                            bind_cxt old_bndr+                            eta_rhs (idType new_bndr) new_arity old_unf++      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding+        -- See Note [In-scope set as a substitution]++      ; if postInlineUnconditionally env bind_cxt old_bndr new_bndr_w_info eta_rhs++        then -- Inline and discard the binding+             do  { tick (PostInlineUnconditionally old_bndr)+                 ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs+                          -- See Note [Use occ-anald RHS in postInlineUnconditionally]+                 ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $+                   return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx unf_rhs (idJoinPointHood new_bndr)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding++        else -- Keep the binding; do cast worker/wrapper+--             simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr+--                                             , text "eta_rhs" <+> ppr eta_rhs ]) $+             tryCastWorkerWrapper env bind_cxt old_bndr new_bndr_w_info eta_rhs }++addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity_type new_unf+  = new_bndr `setIdInfo` info5+  where+    new_arity = arityTypeArity new_arity_type+    info1 = idInfo new_bndr `setArityInfo` new_arity++    -- Unfolding info: Note [Setting the new unfolding]+    info2 = info1 `setUnfoldingInfo` new_unf++    -- Demand info: Note [Setting the demand info]+    info3 | isEvaldUnfolding new_unf+          = lazifyDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 = case arityTypeBotSigs_maybe new_arity_type of+        Nothing -> info3+        Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $+                                       info3 `setDmdSigInfo` str_sig+                                             `setCprSigInfo` cpr_sig++     -- Zap call arity info. We have used it by now (via+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this+     -- information, leading to broken code later (e.g. #13479)+    info5 = zapCallArityInfo info4+++{- Note [Bottoming bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   let x = error "urk"+   in ...(case x of <alts>)...+or+   let f = \y. error (y ++ "urk")+   in ...(case f "foo" of <alts>)...++Then we'd like to drop the dead <alts> immediately.  So it's good to+propagate the info that x's (or f's) RHS is bottom to x's (or f's)+IdInfo as rapidly as possible.++We use tryEtaExpandRhs on every binding, and it turns out that the+arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already+does a simple bottoming-expression analysis.  So all we need to do+is propagate that info to the binder's IdInfo.++This showed up in #12150; see comment:16.++There is a second reason for settting  the strictness signature. Consider+   let -- f :: <[S]b>+       f = \x. error "urk"+   in ...(f a b c)...+Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f`+to eta-expand to+   let f = \x y z. error "urk"+   in ...(f a b c)...++But now f's strictness signature has too short an arity; see+GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth].+Fortuitously, the same strictness-signature-fixup code+gives the function a new strictness signature with the right number of+arguments.  Example in stranal/should_compile/EtaExpansion.++Note [Setting the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the unfolding is a value, the demand info may+go pear-shaped, so we nuke it.  Example:+     let x = (a,b) in+     case x of (p,q) -> h p q x+Here x is certainly demanded. But after we've nuked+the case, we'll get just+     let x = (a,b) in h a b x+and now x is not demanded (I'm assuming h is lazy)+This really happens.  Similarly+     let f = \x -> e in ...f..f...+After inlining f at some of its call sites the original binding may+(for example) be no longer strictly demanded.+The solution here is a bit ad hoc...++Note [Use occ-anald RHS in postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we postInlineUnconditionally 'f in+  let f = \x -> x True in ...(f blah)...+then we'd like to inline the /occ-anald/ RHS for 'f'.  If we+use the non-occ-anald version, we'll end up with a+    ...(let x = blah in x True)...+and hence an extra Simplifier iteration.++We already /have/ the occ-anald version in the Unfolding for+the Id.  Well, maybe not /quite/ always.  If the binder is Dead,+postInlineUnconditionally will return True, but we may not have an+unfolding because it's too big. Hence the belt-and-braces `orElse`+in the defn of unf_rhs.  The Nothing case probably never happens.++Note [Environment for simplLetUnfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be rather careful about the static environment in which+we simplify a stable unfolding.  Consider (#24242):++  f x = let y_Xb = ... in+        let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in+         ...++Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen;+see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier].+This is perfectly fine. The `y_Xb` in the stable unfolding of the non-+recursive binding for `step1` refers, of course, to `let y_Xb = ....`.+When simplifying the binder `step1_Xb` we'll give it a new unique, and+extend the static environment with [Xb :-> step1_Xc], say.++But when simplifying step1's stable unfolding, we must use static environment+/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps+[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc].++That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping+track of the right environment for the unfolding of that InId.  See the type+of `simplLazyBind`, `simplJoinBind`, `completeBind`.++This only matters when we have+  - A non-recursive binding for f+  - has a stable unfolding+  - and that unfolding mentions a variable y+  - that has the same unique as f.+So triggering  a bug here is really hard!++************************************************************************+*                                                                      *+\subsection[Simplify-simplExpr]{The main function: simplExpr}+*                                                                      *+************************************************************************++The reason for this OutExprStuff stuff is that we want to float *after*+simplifying a RHS, not before.  If we do so naively we get quadratic+behaviour as things float out.++To see why it's important to do it after, consider this (real) example:++        let t = f x+        in fst t+==>+        let t = let a = e1+                    b = e2+                in (a,b)+        in fst t+==>+        let a = e1+            b = e2+            t = (a,b)+        in+        a       -- Can't inline a this round, cos it appears twice+==>+        e1++Each of the ==> steps is a round of simplification.  We'd save a+whole round if we float first.  This can cascade.  Consider++        let f = g d+        in \x -> ...f...+==>+        let f = let d1 = ..d.. in \y -> e+        in \x -> ...f...+==>+        let d1 = ..d..+        in \x -> ...(\y ->e)...++Only in this second round can the \y be applied, and it+might do the same again.+-}++simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]+       ; return (Type ty') }++simplExpr env expr+  = simplExprC env expr (mkBoringStop expr_out_ty)+  where+    expr_out_ty :: OutType+    expr_out_ty = substTy env (exprType expr)+    -- NB: Since 'expr' is term-valued, not (Type ty), this call+    --     to exprType will succeed.  exprType fails on (Type ty).++simplExprC :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM OutExpr+        -- Simplify an expression, given a continuation+simplExprC env expr cont+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $+    do  { (floats, expr') <- simplExprF env expr cont+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $+          return (wrapFloats floats expr') }++--------------------------------------------------+simplExprF :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> 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)+    --  ]) $+    simplExprF1 env e cont++simplExprF1 :: HasDebugCallStack+            => SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplFloats, OutExpr)++simplExprF1 _ (Type ty) cont+  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)+    -- simplExprF does only with term-valued expressions+    -- The (Type ty) case is handled separately by simplExpr+    -- and by the other callers of simplExprF++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+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = {-#SCC "simplExprF1-App" #-} case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       ->+          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will+          -- be forced only if we need to run contHoleType.+          -- When these are forced, we might get quadratic behavior;+          -- this quadratic blowup could be avoided by drilling down+          -- to the function and getting its multiplicities all at once+          -- (instead of one-at-a-time). But in practice, we have not+          -- observed the quadratic behavior, so this extra entanglement+          -- seems not worthwhile.+        simplExprF env fun $+        ApplyToVal { sc_arg = arg, sc_env = env+                   , sc_hole_ty = substTy env (exprType fun)+                   , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = {-#SCC "simplExprF1-Lam" #-}+    simplLam env (zapLambdaBndrs expr n_args) cont+        -- zapLambdaBndrs: the issue here is under-saturated lambdas+        --   (\x1. \x2. e) arg1+        -- Here x1 might have "occurs-once" occ-info, because occ-info+        -- is computed assuming that a group of lambdas is applied+        -- all at once.  If there are too few args, we must zap the+        -- occ-info, UNLESS the remaining binders are one-shot+  where+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++simplExprF1 env (Case scrut bndr _ alts) cont+  = {-#SCC "simplExprF1-Case" #-}+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr+                                 , sc_alts = alts+                                 , sc_env = env, sc_cont = cont })++simplExprF1 env (Let (Rec pairs) body) cont+  | Just pairs' <- joinPointBindings_maybe pairs+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont++  | otherwise+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont++simplExprF1 env (Let (NonRec bndr rhs) body) cont+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}+    assert (isTyVar bndr) $+    do { ty' <- simplType env ty+       ; simplExprF (extendTvSubst env bndr ty') body cont }++  | 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 { 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+  -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial+  -- binding like { j = j2 |> co } would first be eta-expanded and then inlined+  -- Better to test preInlineUnconditionally first.+  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-}+    simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-}+    simplNonRecE env FromLet bndr (rhs, env) body cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Join points and case-of-case].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | JoinPoint arity <- idJoinPointHood bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+              mult = contHoleScaling cont+        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)+        ; join_body' <- simplExprC env' join_body cont+        ; return $ mkLams join_bndrs' join_body' }++  | otherwise+  = pprPanic "simplJoinRhs" (ppr bndr)++---------------------------------+simplType :: SimplEnv -> InType -> SimplM OutType+        -- Kept monadic just so we can do the seqType+        -- See Note [Avoiding space leaks in OutType]+simplType env ty+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $+    seqType new_ty `seq` return new_ty+  where+    new_ty = substTy env ty++---------------------------------+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont+               -> SimplM (SimplFloats, OutExpr)+simplCoercionF env co cont+  = do { co' <- simplCoercion env co+       ; rebuild env (Coercion co') cont }++simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion+simplCoercion env co+  = do { let opt_co | reSimplifying env = substCo env co+                    | otherwise         = optCoercion opts subst co+             -- If (reSimplifying env) is True we have already simplified+             -- this coercion once, and we don't want do so again; doing+             -- so repeatedly risks non-linear behaviour+             -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env+       ; seqCo opt_co `seq` return opt_co }+  where+    subst = getTCvSubst env+    opts  = seOptCoercionOpts env++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplTick env tickish expr cont+  -- A scoped tick turns into a continuation, so that we can spot+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do+  -- it this way, then it would take two passes of the simplifier to+  -- reduce ((scc t (\x . e)) e').+  -- NB, don't do this with counting ticks, because if the expr is+  -- bottom, then rebuildCall will discard the continuation.++--------------------------+--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)+-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<f>  case expensive of p -> e+-- becomes+--    case expensive of p -> scc<f> e+--+-- So I'm disabling this for now.  It just means we will do more+-- simplifier iterations that necessary in some cases.+--------------------------++  -- For unscoped or soft-scoped ticks, we are allowed to float in new+  -- cost, so we simply push the continuation inside the tick.  This+  -- has the effect of moving the tick to the outside of a case or+  -- application context, allowing the normal case and application+  -- optimisations to fire.+  | tickish `tickishScopesLike` SoftScope+  = do { (floats, expr') <- simplExprF env expr cont+       ; return (floats, mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)+         ts_scope         = map mkNoCount $+                            filter (not . (`tickishScopesLike` NoScope)) ticks++  no_floating_past_tick =+    do { let (inc,outc) = splitCont cont+       ; (floats, expr1) <- simplExprF env expr inc+       ; let expr2    = wrapFloats floats expr1+             tickish' = simplTickish env tickish+       ; rebuild env (mkTick tickish' expr2) outc+       }++-- Alternative version that wraps outgoing floats with the tick.  This+-- results in ticks being duplicated, as we don't make any attempt to+-- eliminate the tick if we re-inline the binding (because the tick+-- semantics allows unrestricted inlining of HNFs), so I'm not doing+-- this any more.  FloatOut will catch any real opportunities for+-- floating.+--+--  wrap_floats =+--    do { let (inc,outc) = splitCont cont+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc+--       ; let tickish' = simplTickish env tickish+--       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),+--                                   mkTick (mkNoCount tickish') rhs)+--              -- when wrapping a float with mkTick, we better zap the Id's+--              -- strictness info and arity, because it might be wrong now.+--       ; let env'' = addFloats env (mapFloats env' wrap_float)+--       ; rebuild env'' expr' (TickIt tickish' outc)+--       }+++  simplTickish env tickish+    | Breakpoint ext bid ids <- tickish+          = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont cont@(CastIt { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = Just id+  getDoneId (DoneEx (Var id) _) = Just id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst+  getDoneId other = pprPanic "getDoneId" (ppr other)++-- Note [case-of-scc-of-case]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It's pretty important to be able to transform case-of-case when+-- there's an SCC in the way.  For example, the following comes up+-- in nofib/real/compress/Encode.hs:+--+--        case scctick<code_string.r1>+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->+--             (ww1_s13f, ww2_s13g, ww3_s13h)+--             }+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->+--        tick<code_string.f1>+--        (ww_s12Y,+--         ww1_s12Z,+--         PTTrees.PT+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)+--        }+--+-- We really want this case-of-case to fire, because then the 3-tuple+-- will go away (indeed, the CPR optimisation is relying on this+-- happening).  But the scctick is in the way - we need to push it+-- inside to expose the case-of-case.  So we perform this+-- transformation on the inner case:+--+--   scctick c (case e of { p1 -> e1; ...; pn -> en })+--    ==>+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }+--+-- So we've moved a constant amount of work out of the scc to expose+-- the case.  We only do this when the continuation is interesting: in+-- for now, it has to be another Case (maybe generalise this later).++{-+************************************************************************+*                                                                      *+\subsection{The main rebuilder}+*                                                                      *+************************************************************************+-}++rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+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_go env (mkTick t expr) cont+      CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }+        -> rebuild_go env (mkCast expr co') cont+           -- NB: mkCast implements the (Coercion co |> g) optimisation+        where+          co' = optOutCoercion env co opt++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> 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++      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_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_go env (App expr arg') cont }++completeBindX :: SimplEnv+              -> FromWhat+              -> InId -> OutExpr   -- Non-recursively bind this Id to this (simplified) expression+                                   -- (the let-can-float invariant may not be satisfied)+              -> InExpr            -- In this body+              -> SimplCont         -- Consumed by this continuation+              -> SimplM (SimplFloats, OutExpr)+completeBindX env from_what bndr rhs body cont+  | FromBeta arg_levity <- from_what+  , needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant+  = do { (env1, bndr1)   <- simplNonRecBndr env bndr  -- Lambda binders don't have rules+       ; (floats, expr') <- simplNonRecBody env1 from_what body cont+       -- Do not float floats past the Case binder below+       ; let expr'' = wrapFloats floats expr'+             case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']+       ; return (emptyFloats env, case_expr) }++  | otherwise -- Make a let-binding+  = do  { (env1, bndr1) <- simplNonRecBndr env bndr+        ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)++        ; let is_strict = isStrictId bndr2+              -- isStrictId: use simplified binder because the InId bndr might not have+              -- a fixed runtime representation, which isStrictId doesn't expect+              -- c.f. Note [Dark corner with representation polymorphism]++        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+                                               bndr2 (emptyFloats env) rhs+              -- NB: it makes a surprisingly big difference (5% in compiler allocation+              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',+              -- because this is completeBindX, so bndr is not in scope in the RHS.++        ; let env3 = env2 `setInScopeFromF` rhs_floats+        ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (bndr2, rhs1, env3)+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr]++        -- Simplify the body+        ; (body_floats, body') <- simplNonRecBody env4 from_what body cont++        ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats+        ; return ( all_floats, body' ) }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we will use pushCoTyArg and pushCoValArg successively, which+   build up SelCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.++Note [Avoid re-simplifying coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In some benchmarks (with deeply nested cases) we successively push+casts onto the SimplCont.  We don't want to call the coercion optimiser+on each successive composition -- that's at least quadratic.  So:++* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to+  record whether the coercion optimiser has been applied to the coercion.++* In `simplCast`, when we see (Cast e co), we simplify `co` to get+  an OutCoercion, and built a CastIt with sc_opt=True.++  Actually not quite: if we are simplifying the result of inlining an+  unfolding (seInlineDepth > 0), then instead of /optimising/ it again,+  just /substitute/ which is cheaper.  See `simplCoercion`.++* In `addCoerce` (in `simplCast`) if we combine this new coercion with+  an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False.++* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise+  the (presumably composed) coercion if sc_opt=False; this is done+  by `optOutCoercion`.++* When duplicating a continuation in `mkDupableContWithDmds`, before+  duplicating a CastIt, optimise the coercion. Otherwise we'll end up+  optimising it separately in the duplicate copies.+-}+++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]+  | otherwise         = optCoercion opts empty_subst co+  where+    empty_subst = mkEmptySubst (seInScope env)+    opts = seOptCoercionOpts env++simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}+                   if isReflCo co1+                   then return cont0  -- See Note [Optimising reflexivity]+                   else addCoerce co1 True cont0+                        -- True <=> co1 is optimised+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where++        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl    _   cont = return cont+        addCoerceM (MCo co) opt cont = addCoerce co opt cont++        addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont+        addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont })  -- See Note [Optimising reflexivity]+          = addCoerce (mkTransCo co1 co2) False cont+                      -- False: (mkTransCo co1 co2) is not fully optimised+                      -- See Note [Avoid re-simplifying coercions]++        addCoerce co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+          = {-#SCC "addCoerce-pushCoTyArg" #-}+            do { tail' <- addCoerceM m_co' opt tail+               ; return (ApplyToTy { sc_arg_ty  = arg_ty'+                                   , sc_cont    = tail'+                                   , sc_hole_ty = coercionLKind co }) }+                                        -- NB!  As the cast goes past, the+                                        -- type of the hole changes (#16312)+        -- (f |> co) e   ===>   (f (e |> co1)) |> co2+        -- where   co :: (s1->s2) ~ (t1->t2)+        --         co1 :: t1 ~ s1+        --         co2 :: s2 ~ t2+        addCoerce co opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                          , sc_dup = dup, sc_cont = tail+                                          , sc_hole_ty = fun_ty })+          | not opt  -- pushCoValArg duplicates the coercion, so optimise first+          = addCoerce (optOutCoercion (zapSubstEnv env) co opt) True cont++          | Just (m_co1, m_co2) <- pushCoValArg co+          , fixed_rep m_co1+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 opt tail+               ; case m_co1 of {+                   MRefl -> return (cont { sc_cont = tail'+                                         , sc_hole_ty = coercionLKind co }) ;+                      -- See Note [Avoiding simplifying repeatedly]++                   MCo co1 ->+            do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail'+                                    , sc_hole_ty = coercionLKind co }) } } }++        addCoerce co opt cont+          | isReflCo co = return cont  -- Having this at the end makes a huge+                                       -- difference in T12227, for some reason+                                       -- See Note [Optimising reflexivity]+          | otherwise = return (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })++        fixed_rep :: MCoercionR -> Bool+        fixed_rep MRefl    = True+        fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co+          -- Without this check, we can get an argument which does not+          -- have a fixed runtime representation.+          -- See Note [Representation polymorphism invariants] in GHC.Core+          -- test: typecheck/should_run/EtaExpandLevPoly++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+                                        --   how `f` uses `ai`, affecting the Stop+                                        --   continuation passed to 'simplExprC'+             -> StaticEnv -> CoreExpr   -- ^ Expression with its static envt+             -> SimplM (DupFlag, StaticEnv, OutExpr)+simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { let arg_env' = arg_env `setInScopeFromE` env+       ; let arg_ty = funArgTy fun_ty+       ; let stop = case mb_arg_info of+               Nothing -> mkBoringStop arg_ty+               Just ai -> mkLazyArgStop arg_ty ai+       ; arg' <- simplExprC arg_env' arg stop+       ; return (Simplified, zapSubstEnv arg_env', arg') }+         -- Return a StaticEnv that includes the in-scope set from 'env',+         -- because arg' may well mention those variables (#20639)++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplNonRecBody :: SimplEnv -> FromWhat+                -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+simplNonRecBody env from_what body cont+  = case from_what of+      FromLet     -> simplExprF env body cont+      FromBeta {} -> simplLam   env body cont++simplLam :: SimplEnv -> InExpr -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont+simplLam env expr            cont = simplExprF env expr cont++simpl_lam :: HasDebugCallStack+          => SimplEnv -> InBndr -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- Type beta-reduction+simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) body cont }++-- Coercion beta-reduction+simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se+                                    , sc_cont = cont })+  = assertPpr (isCoVar bndr) (ppr bndr) $+    do { tick (BetaReduction bndr)+       ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co+       ; simplLam (extendCvSubst env bndr arg_co') body cont }++-- Value beta-reduction+-- This works for /coercion/ lambdas too+simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                    , sc_cont = cont, sc_dup = dup+                                    , sc_hole_ty = fun_ty})+  = do { tick (BetaReduction bndr)+       ; let from_what = FromBeta arg_levity+             arg_levity+               | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted+               | otherwise         = typeLevity (funArgTy fun_ty)+             -- Example:  (\(cv::a ~# b). blah) co+             -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType++             -- Using fun_ty: see Note [Dark corner with representation polymorphism]+             -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg+             --      When we come to `x=arg` we must choose lazy/strict correctly+             --      It's wrong to err in either direction+             --      But fun_ty is an OutType, so is fully substituted++       ; 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+            , 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 }++-- Discard a non-counting tick on a lambda.  This may change the+-- cost attribution slightly (moving the allocation of the+-- lambda elsewhere), but we don't care: optimisation changes+-- cost attribution all the time.+simpl_lam env bndr body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simpl_lam env bndr body cont++-- Not enough args, so there are real lambdas left to put in the result+simpl_lam env bndr body cont+  = do  { let (inner_bndrs, inner_body) = collectBinders body+        ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)+        ; body'   <- simplExpr env' inner_body+        ; new_lam <- rebuildLam env' bndrs' body' cont+        ; rebuild env' new_lam cont }++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Historically this had a special case for when a lambda-binder+-- could have a stable unfolding;+-- see Historical Note [Case binders and join points]+-- But now it is much simpler! We now only remove unfoldings.+-- See Note [Never put `OtherCon` unfoldings on lambda binders]+simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++------------------+simplNonRecE :: HasDebugCallStack+             => SimplEnv+             -> FromWhat+             -> InId               -- The binder, always an Id+                                   -- Never a join point+                                   -- The static env for its unfolding (if any) is the first parameter+             -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)+             -> InExpr             -- Body of the let/lambda+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * from=FromLet:  a non-top-level non-recursive non-join-point let-expression+--  * from=FromBeta: a binding arising from a beta reduction+--+-- simplNonRecE env b (rhs, rhs_se) body k+--   = let env in+--     cont< let b = rhs_se(rhs) in body >+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process.+--+-- from_what=FromLet => the RHS satisfies the let-can-float invariant+-- Otherwise it may or may not satisfy it.++simplNonRecE env from_what bndr (rhs, rhs_se) body cont+  | assert (isId bndr && not (isJoinId bndr) ) $+    is_strict_bind+  = -- Evaluate RHS strictly+    simplExprF (rhs_se `setInScopeFromE` env) rhs+               (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })++  | otherwise  -- Evaluate RHS lazily+  = do { (env1, bndr1)    <- simplNonRecBndr env bndr+       ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+       ; (floats1, env3)  <- simplLazyBind NotTopLevel NonRecursive+                                           (bndr,env) (bndr2,env2) (rhs,rhs_se)+       ; (floats2, expr') <- simplNonRecBody env3 from_what body cont+       ; return (floats1 `addFloats` floats2, expr') }++  where+    is_strict_bind = case from_what of+       FromBeta Unlifted -> True+       -- If we are coming from a beta-reduction (FromBeta) we must+       -- establish the let-can-float invariant, so go via StrictBind+       -- If not, the invariant holds already, and it's optional.++       -- (FromBeta Lifted) or FromLet: look at the demand info+       _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)+++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+-- Precondition: not a join-point binding+simplRecE env pairs body cont+  = do  { let bndrs = map fst pairs+        ; massert (all (not . isJoinId) bndrs)+        ; env1 <- simplRecBndrs env bndrs+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; (floats1, env2)  <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs+        ; (floats2, expr') <- simplExprF env2 body cont+        ; return (floats1 `addFloats` floats2, expr') }++{- Note [Dark corner with representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail+if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).+So we are careful to call `isStrictId` on the OutId, not the InId, in case we have+     ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)+That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell+if x is lifted or unlifted from that.++We only get such redexes from the compulsory inlining of a wired-in,+representation-polymorphic function like `rightSection` (see+GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined+such compulsory inlinings already, but belt and braces does no harm.++Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the+Simplifier without first calling SimpleOpt, so anything involving+GHCi or TH and operator sections will fall over if we don't take+care here.++Note [Avoiding simplifying repeatedly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and then re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression (#13379).++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+   (forcing this simplification is why we have the RULE in this example)+ * We inline f = \x. g x, in `simpl_lam`+ * So if `simpl_lam` did preInlineUnconditionally we get (g BIG)+ * Now if g has a RULE we'll simplify BIG again, and this whole thing can+   iterate.+ * However, if `f` did not have a RULE, so that BIG has /not/ already been+   simplified, we /want/ to do preInlineUnconditionally in simpl_lam.++So we go to some effort to avoid repeatedly simplifying the same thing:++* ApplyToVal has a (sc_dup :: DupFlag) field which records if the argument+  has been evaluated.++* simplArg checks this flag to avoid re-simplifying.++* simpl_lam has:+    - a case for (isSimplified dup), which goes via completeBindX, and+    - a case for an un-simplified argument, which tries preInlineUnconditionally++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - We sometimes try rewrite RULES befoe simplifying arguments;+      see Note [tryRules: plan (BEFORE)]++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+*                                                                      *+********************************************************************* -}++{- Note [Rules and unfolding for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   simplExpr (join j x = rhs                         ) cont+             (      {- RULE j (p:ps) = blah -}       )+             (      {- StableUnfolding j = blah -}   )+             (in blah                                )++Then we will push 'cont' into the rhs of 'j'.  But we should *also* push+'cont' into the RHS of+  * Any RULEs for j, e.g. generated by SpecConstr+  * Any stable unfolding for j, e.g. the result of an INLINE pragma++Simplifying rules and stable-unfoldings happens a bit after+simplifying the right-hand side, so we remember whether or not it+is a join point, and what 'cont' is, in a value of type MaybeJoinCont++#13900 was caused by forgetting to push 'cont' into the RHS+of a SpecConstr-generated RULE for a join point.+-}++simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr+                     -> InExpr -> SimplCont+                     -> SimplM (SimplFloats, OutExpr)+simplNonRecJoinPoint env bndr rhs body cont+   = assert (isJoinId bndr ) $+     wrapJoinCont env cont $ \ env cont ->+     do { -- We push join_cont into the join RHS and the body;+          -- and wrap wrap_cont around the whole thing+        ; let mult   = contHoleScaling cont+              res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)+        ; (floats1, env3)  <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)+        ; (floats2, body') <- simplExprF env3 body cont+        ; return (floats1 `addFloats` floats2, body') }+++------------------+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]+                  -> InExpr -> SimplCont+                  -> SimplM (SimplFloats, OutExpr)+simplRecJoinPoint env pairs body cont+  = wrapJoinCont env cont $ \ env cont ->+    do { let bndrs  = map fst pairs+             mult   = contHoleScaling cont+             res_ty = contResultType cont+       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty+               -- NB: bndrs' don't have unfoldings or rules+               -- We add them as we go down+       ; (floats1, env2)  <- simplRecBind env1 (BC_Join Recursive cont) pairs+       ; (floats2, body') <- simplExprF env2 body cont+       ; return (floats1 `addFloats` floats2, body') }++--------------------+wrapJoinCont :: SimplEnv -> SimplCont+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))+             -> SimplM (SimplFloats, OutExpr)+-- Deal with making the continuation duplicable if necessary,+-- and with the no-case-of-case situation.+wrapJoinCont env cont thing_inside+  | contIsStop cont        -- Common case; no need for fancy footwork+  = thing_inside env cont++  | not (seCaseCase env)+    -- See Note [Join points with -fno-case-of-case]+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont+       ; return (floats2 `addFloats` floats3, expr3) }++  | otherwise+    -- Normal case; see Note [Join points and case-of-case]+  = do { (floats1, cont')  <- mkDupableCont env cont+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'+       ; return (floats1 `addFloats` floats2, result) }+++--------------------+trimJoinCont :: Id         -- Used only in error message+             -> JoinPointHood+             -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ NotJoinPoint cont+  = cont -- Not a jump+trimJoinCont var (JoinPoint arity) cont+  = trim arity cont+  where+    trim 0 cont@(Stop {})+      = cont+    trim 0 cont+      = mkBoringStop (contResultType cont)+    trim n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim (n-1) k }+    trim n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!+    trim _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont+++{- Note [Join points and case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++We need to be very careful here to remain consistent---neither part is+optional!++We need do make the continuation E duplicable (since we are duplicating it)+with mkDupableCont.+++Note [Join points with -fno-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Supose case-of-case is switched off, and we are simplifying++    case (join j x = <j-rhs> in+          case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++Usually, we'd push the outer continuation (case . of <outer-alts>) into+both the RHS and the body of the join point j.  But since we aren't doing+case-of-case we may then end up with this totally bogus result++    join x = case <j-rhs> of <outer-alts> in+    case (case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++This would be OK in the language of the paper, but not in GHC: j is no longer+a join point.  We can only do the "push continuation into the RHS of the+join point j" if we also push the continuation right down to the /jumps/ to+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to++    join x = case <j-rhs> of <outer-alts> in+    case y of+      A -> j 1+      B -> j 2+      C -> case e of <outer-alts>++which is great.++Bottom line: if case-of-case is off, we must stop pushing the continuation+inwards altogether at any join point.  Instead simplify the (join ... in ...)+with a Stop continuation, and wrap the original continuation around the+outside.  Surprisingly tricky!+++************************************************************************+*                                                                      *+                     Variables+*                                                                      *+************************************************************************++Note [zapSubstEnv]+~~~~~~~~~~~~~~~~~~+When simplifying something that has already been simplified, be sure to+zap the SubstEnv.  This is VITAL.  Consider+     let x = e in+     let y = \z -> ...x... in+     \ x -> ...y...++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 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+* 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.+-}++simplInVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplInVar env var+  -- Why $! ? See Note [Bangs in the Simplifier]+  | isTyVar var = return $! Type $! (substTyVar env var)+  | isCoVar var = return $! Coercion $! (substCoVar env var)+  | otherwise+  = case substId env var of+        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids+                                in simplExpr env' e+        DoneId var1          -> return (Var var1)+        DoneEx e _           -> return e++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+        -- Don't trimJoinCont; haven't already simplified e,+        -- so the cont is not embodied in e+        where+          env' = setSubstEnv env tvs cvs ids++      DoneId out_id -> simplOutId zapped_env out_id cont'+        where+          cont' = trimJoinCont out_id (idJoinPointHood out_id) cont++      DoneEx e mb_join -> simplExprF zapped_env e cont'+        where+          cont' = trimJoinCont var mb_join cont+  where+    zapped_env =  zapSubstEnv env  -- See Note [zapSubstEnv]++---------------------------------------------------------+simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)++---------- 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 @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 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, 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]++       -- If the argument is a literal lambda already, take a short cut+       -- This isn't just efficiency:+       --    * If we don't do this we get a beta-redex every time, so the+       --      simplifier keeps doing more iterations.+       --    * Even more important: see Note [No eta-expansion in runRW#]+       ; arg' <- case arg of+           Lam s body -> do { (env', s') <- simplBinder arg_env s+                            ; body' <- simplExprC env' body inner_cont+                            ; return (Lam s' body') }+                            -- Important: do not try to eta-expand this lambda+                            -- See Note [No eta-expansion in runRW#]++           _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy+                   ; let (m,_,_) = splitFunTy fun_ty+                         env'  = arg_env `addNewInScopeIds` [s']+                         cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'+                                            , sc_env = env', sc_cont = inner_cont+                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }+                                -- cont' applies to s', then K+                   ; body' <- simplExprC env' arg cont'+                   ; return (Lam s' body') }++       ; let rr'   = getRuntimeRep new_runrw_res_ty+             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+                        , sc_dup = dup_flag, sc_hole_ty = fun_ty+                        , sc_cont = cont })+  -- Argument is already simplified+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont++  -- Strict arguments+  | isStrictArgInfo fun_info+  , seCaseCase env    -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+                      --    Note [Case-of-case and full laziness]+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty+                          , sc_dup = Simplified+                          , sc_cont = cont })+                -- Note [Shadowing in the Simplifier]++  -- Lazy arguments+  | otherwise+        -- DO NOT float anything outside, hence simplExprC+        -- There is no benefit (unlike in a let-binding), and we'd+        -- have to be very careful about bogus strictness through+        -- floating a demanded let.+  = do  { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg+        ; 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, 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)+tryInlining env logger var cont+  | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont+  = do { dump_inline expr cont+       ; return (Just expr) }++  | otherwise+  = return Nothing++  where+    (lone_variable, arg_infos, call_cont) = contArgs cont+    interesting_cont = interestingCallContext env call_cont++    log_inlining doc+      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)+           Opt_D_dump_inlinings+           "" FormatText doc++    dump_inline unfolding cont+      | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()+      | not (logHasDumpFlag logger Opt_D_verbose_core2core)+      = when (isExternalName (idName var)) $+            log_inlining $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = log_inlining $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]+++{- 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)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is sometimes desirable to apply RULES before simplifying the function+arguments.  We do so in `simplOutId`.++We do so /selectively/ (see (BF2)), in two particular cases:++* 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.++  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.++  So if the Id has an unfolding, we want to try RULES before we try inlining.++Wrinkles:++(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.++(BF2) The "selectively" in Plan (BEFORE) is a bit ad-hoc:++  * We want Plan (BEFORE) for class ops (see above in this Note)++  * 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.++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`.++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 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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This part of the simplifier may return an expression that has shadowing.+(See Note [Shadowing in Core] in GHC.Core.hs.) Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!++See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils.++Note [No eta-expansion in runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that+lambda.  Why not?  Because+* `blah` can mention join points bound outside the runRW#+* eta-expansion uses arityType, and+* `arityType` cannot cope with free join Ids:++So the simplifier spots the literal lambda, and simplifies inside it.+It's a very special lambda, because it is the one the OccAnal spots and+allows join points bound /outside/ to be called /inside/.++See Note [No free join points in arityType] in GHC.Core.Opt.Arity++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> OutId -> [OutExpr]+         -> SimplM (Maybe (FullArgCount, CoreExpr))++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 occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump logger rule rule_rhs+       ; return (Just (ruleArity rule, occ_anald_rhs)) }++  | otherwise  -- No rule fires+  = do { logger <- getLogger+       ; nodump logger  -- This ensures that an empty file is written+       ; return Nothing }++  where+    ropts        = seRuleOpts env :: RuleOpts+    in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv+    act_fun      = activeRule (seMode env) :: Activation -> Bool++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump logger rule rule_rhs+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = 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: " <+> pprCoreExpr rule_rhs ]++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = log_rule Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump logger+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_rewrites++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_firings++      | otherwise+      = return ()++    log_rule flag hdr details+      = do+      { logger <- getLogger+      ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText+               $ sep [text hdr, nest 4 details]+      }++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> 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+       ; 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+    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b+    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty+    res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty+    rhs_ty    = substTy in_env (exprType rhs)+    rhs_rep   = getRuntimeRep rhs_ty++    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 } ]+    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++{- Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+   case (scrut |> co) of _ -> rhs+look for rules that match the expression+   seq @t1 @t2 scrut+where scrut :: t1+      rhs   :: t2++If you find a match, rewrite it, and apply to 'rhs'.++Notice that we can simply drop casts on the fly here, which+makes it more likely that a rule will match.++See Note [User-defined RULES for seq] in GHC.Types.Id.Make.++Note [Occurrence-analyse after rule firing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After firing a rule, we occurrence-analyse the instantiated RHS before+simplifying it.  Usually this doesn't make much difference, but it can+be huge.  Here's an example (simplCore/should_compile/T7785)++  map f (map f (map f xs)++= -- Use build/fold form of map, twice+  map f (build (\cn. foldr (mapFB c f) n+                           (build (\cn. foldr (mapFB c f) n xs))))++= -- Apply fold/build rule+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))++= -- Beta-reduce+  -- Alas we have no occurrence-analysed, so we don't know+  -- that c is used exactly once+  map f (build (\cn. let c1 = mapFB c f in+                     foldr (mapFB c1 f) n xs))++= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)+  -- We can do this because (mapFB c n) is a PAP and hence expandable+  map f (build (\cn. let c1 = mapFB c n in+                     foldr (mapFB c (f.f)) n x))++This is not too bad.  But now do the same with the outer map, and+we get another use of mapFB, and t can interact with /both/ remaining+mapFB calls in the above expression.  This is stupid because actually+that 'c1' binding is dead.  The outer map introduces another c2. If+there is a deep stack of maps we get lots of dead bindings, and lots+of redundant work as we repeatedly simplify the result of firing rules.++The easy thing to do is simply to occurrence analyse the result of+the rule firing.  Note that this occ-anals not only the RHS of the+rule, but also the function arguments, which by now are OutExprs.+E.g.+      RULE f (g x) = x+1++Call   f (g BIG)  -->   (\x. x+1) BIG++The rule binders are lambda-bound and applied to the OutExpr arguments+(here BIG) which lack all internal occurrence info.++Is this inefficient?  Not really: we are about to walk over the result+of the rule firing to simplify it, so occurrence analysis is at most+a constant factor.++Note, however, that the rule RHS is /already/ occ-analysed; see+Note [OccInfo in unfoldings and rules] in GHC.Core.  There is something+unsatisfactory about doing it twice; but the rule RHS is usually very+small, and this is simple.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise+this idea to look for a case where we're scrutinising a variable, and we know+that only the default case can match.  For example:++        case x of+          0#      -> ...+          DEFAULT -> ...(case x of+                         0#      -> ...+                         DEFAULT -> ...) ...++Here the inner case is first trimmed to have only one alternative, the+DEFAULT, after which it's an instance of the previous case.  This+really only shows up in eliminating error-checking code.++Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be eliminated by the CaseElim transformation.+This includes things like (==# a# b#)::Bool so that we simplify+      case ==# a# b# of { True -> x; False -> x }+to just+      x+This particular example shows up in default methods for+comparison operations (e.g. in (>=) for Int.Int32)++Note [Case to let transformation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a case over a lifted type has a single alternative, and is being+used as a strict 'let' (all isDeadBinder bndrs), we may want to do+this transformation:++    case e of r       ===>   let r = e in ...r...+      _ -> ...r...++We treat the unlifted and lifted cases separately:++* Unlifted case: 'e' satisfies exprOkForSpeculation+  (ok-for-spec is needed to satisfy the let-can-float invariant).+  This turns     case a +# b of r -> ...r...+  into           let r = a +# b in ...r...+  and thence     .....(a +# b)....++  However, if we have+      case indexArray# a i of r -> ...r...+  we might like to do the same, and inline the (indexArray# a i).+  But indexArray# is not okForSpeculation, so we don't build a let+  in rebuildCase (lest it get floated *out*), so the inlining doesn't+  happen either.  Annoying.++* Lifted case: we need to be sure that the expression is already+  evaluated (exprIsHNF).  If it's not already evaluated+      - we risk losing exceptions, divergence or+        user-specified thunk-forcing+      - even if 'e' is guaranteed to converge, we don't want to+        create a thunk (call by need) instead of evaluating it+        right away (call by value)++  However, we can turn the case into a /strict/ let if the 'r' is+  used strictly in the body.  Then we won't lose divergence; and+  we won't build a thunk because the let is strict.+  See also Note [Case-to-let for strictly-used binders]++Note [Case-to-let for strictly-used binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case <scrut> of r { _ -> ..r.. }+where 'r' is used strictly in (..r..), we /could/ safely transform to+   let r = <scrut> in ...r...+As a special case,  we have a plain `seq` like+   case r of r1 { _ -> ...r1... }+where `r` is used strictly, we /could/ simply drop the `case` to get+   ...r....++HOWEVER, there are some serious downsides to this transformation, so+GHC doesn't do it any longer (#24251):++* Suppose the Simplifier sees+     case x of y* { __DEFAULT ->+     let z = case y of { __DEFAULT -> expr } in+     z+1 }+  The "y*" means "y is used strictly in its scope.  Now we may:+     - Eliminate the inner case because `y` is evaluated.+  Now the demand-info on `y` is not right, because `y` is no longer used+  strictly in its scope.  But it is hard to spot that without doing a new+  demand analysis.  So there is a danger that we will subsequently:+     - Eliminate the outer case because `y` is used strictly+  Yikes!  We can't eliminate both!++* It introduces space leaks (#24251).  Consider+      go 0 where go x = x `seq` go (x + 1)+  It is an infinite loop, true, but it should not leak space. Yet if we drop+  the `seq`, it will.  Another great example is #21741.++* Dropping the outer `case` can change the error behaviour.  For example,+  we might transform+       case x of { _ -> error "bad" }    -->     error "bad"+  which is might be puzzling if 'x' currently lambda-bound, but later gets+  let-bound to (error "good").  Tht is OK accoring to the paper "A semantics for+  imprecise exceptions", but see #8900 for an example where the loss of this+  transformation bit us in practice.++* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x`+  is strictly used, and we could soundly transform to+     let x = e in f x+  But if f's strictness info got worse (which can happen in in obscure cases;+  see #21392) then we might have turned a non-thunk into a thunk!  Bad.++Lacking this "drop-strictly-used-seq" transformation means we can end up with+some redundant-looking evals.  For example, consider+    f x y = case x of DEFAULT ->    -- A redundant-looking eval+            case y of+              True  -> case x of { Nothing -> False; Just z  -> z }+              False -> case x of { Nothing -> True;  Just z  -> z }+That outer eval will be retained right through to code generation.  But,+perhaps surprisingly, that is probably a /good/ thing:++   Key point: those inner (case x) expressions will be compiled a simple 'if',+   because the code generator can see that `x` is, at those points, evaluated+   and properly tagged.++If we dropped the outer eval, both the inner (case x) expressions would need to+do a proper eval, pushing a return address, with an info table. See the example+in #15631 where, in the Description, the (case ys) will be a simple multi-way+jump.++In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs+transformation, binary sizes fell by 1%, and a few programs actually allocated+less and ran faster.  A case in point is nofib/imaginary/digits-of-e2. (I'm not+sure exactly why it improves so much, though.)++Slightly related: Note [Empty case alternatives] in GHC.Core.++Historical notes:++There have been various earlier versions of this patch:++* By Sept 18 the code looked like this:+     || scrut_is_demanded_var scrut++    scrut_is_demanded_var :: CoreExpr -> Bool+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s+    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False++  This only fired if the scrutinee was a /variable/, which seems+  an unnecessary restriction. So in #15631 I relaxed it to allow+  arbitrary scrutinees.  Less code, less to explain -- but the change+  had 0.00% effect on nofib.++* Previously, in Jan 13 the code looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++  This patch was part of fixing #7542. See also+  Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.)+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+we cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear.++Note [Do not duplicate constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#20125)+   let x = (a,b)+   in ...(case x of x' -> blah)...x...x...++We want that `case` to vanish (since `x` is bound to a data con) leaving+   let x = (a,b)+   in ...(let x'=x in blah)...x..x...++In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,+since is bound to (a,b).  But in eliminating the case, if the scrutinee+is trivial, we want to bind the case-binder to the scrutinee, /not/ to+the constructor application.  Hence the case_bndr_rhs in rebuildCase.++This applies equally to a non-DEFAULT case alternative, say+   let x = (a,b) in ...(case x of x' { (p,q) -> blah })...+This variant is handled by bind_case_bndr in knownCon.++We want to bind x' to x, and not to a duplicated (a,b)).+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (increasing order)+   -> SimplCont+   -> SimplM (SimplFloats, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing             -> missingAlt env case_bndr alts cont+            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }++  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'+  = do  { tick (KnownBranch case_bndr)+        ; let scaled_wfloats = map scale_float wfloats+              -- case_bndr_unf: see Note [Do not duplicate constructor applications]+              case_bndr_rhs | exprIsTrivial scrut = scrut+                            | otherwise           = con_app+              con_app = Var (dataConWorkId con) `mkTyApps` ty_args+                                                `mkApps`   other_args+        ; case findAlt (DataAlt con) alts of+            Nothing                   -> missingAlt env0 case_bndr alts cont+            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs+            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args+                                                  other_args case_bndr bs rhs cont+        }+  where+    simple_rhs env wfloats case_bndr_rhs bs rhs =+      assert (null bs) $+      do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs+             -- scrut is a constructor application,+             -- hence satisfies let-can-float invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     GHC.Core.Make.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}++    -- This scales case floats by the multiplicity of the continuation hole (see+    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because+    -- they are aliases anyway.+    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =+      let+        scale_id id = scaleVarBy holeScaling id+      in+      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)+    scale_float f = f++    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr+     -- We are in the following situation+     --   case[p] case[q] u of { D x -> C v } of { C x -> w }+     -- And we are producing case[??] u of { D x -> w[x\v]}+     --+     -- What should the multiplicity `??` be? In order to preserve the usage of+     -- variables in `u`, it needs to be `pq`.+     --+     -- As an illustration, consider the following+     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }+     -- Where C :: A %1 -> T is linear+     -- If we were to produce a case[1], like the inner case, we would get+     --   case[1] of { C x -> (x, x) }+     -- Which is ill-typed with respect to linearity. So it needs to be a+     -- case[Many].++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont+  -- See if we can get rid of the case altogether+  -- See Note [Case elimination]+  -- mkCase made sure that if all the alternatives are equal,+  -- then there is now only one (DEFAULT) rhs++  -- 2a.  Dropping the case altogether, if+  --      a) it binds nothing (so it's really just a 'seq')+  --      b) evaluating the scrutinee has no side effects+  | is_plain_seq+  , exprOkToDiscard scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  -- See Note [Case to let transformation]+  | all_dead_bndrs+  , doCaseToLet scrut case_bndr+  = do { tick (CaseElim case_bndr)+       ; (floats1, env')  <- simplAuxBind "rebuildCaseAlt1" env case_bndr scrut+       ; (floats2, expr') <- simplExprF env' rhs cont+       ; return (floats1 `addFloats` floats2, expr') }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont'+           Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }++--------------------------------------------------+--      3. Primop-related case-rules+--------------------------------------------------++  |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts+  = reallyRebuildCase env scrut' case_bndr' alts' cont++  where+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont++doCaseToLet :: OutExpr          -- Scrutinee+            -> InId             -- Case binder+            -> Bool+-- The situation is         case scrut of b { DEFAULT -> body }+-- Can we transform thus?   let { b = scrut } in body+doCaseToLet scrut case_bndr+  | isTyCoVar case_bndr    -- Respect GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]++  | isUnliftedType (exprType scrut)+    -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).+    -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'+    -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].+    -- Using `exprType` is typically cheap because `scrut` is typically a variable.+    -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts+    -- the brain more.  Consider that if this test ever turns out to be a perf+    -- problem (which seems unlikely).+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+       --    || isStrUsedDmd (idDemandInfo case_bndr)+       -- We no longer look at the demand on the case binder+       -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (seCaseCase env)    -- Only when case-of-case is on.+                            -- See GHC.Driver.Config.Core.Opt.Simplify+                            --    Note [Case-of-case and full laziness]+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild (zapSubstEnv env) case_expr cont }++  | otherwise+  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts env' scrut+                                (scaleIdBy holeScaling case_bndr)+                                (scaleAltsBy holeScaling alts)+                                cont'+       ; return (floats, case_expr) }+  where+    holeScaling = contHoleScaling cont+    -- Note [Scaling in case-of-case]++{-+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,+try to eliminate uses of v in the RHSs in favour of case_bndr; that+way, there's a chance that v will now only be used once, and hence+inlined.++Historical note: we use to do the "case binder swap" in the Simplifier+so there were additional complications if the scrutinee was a variable.+Now the binder-swap stuff is done in the occurrence analyser; see+"GHC.Core.Opt.OccurAnal" Note [Binder swap].++Note [knownCon occ info]+~~~~~~~~~~~~~~~~~~~~~~~~+If the case binder is not dead, then neither are the pattern bound+variables:+        case <any> of x { (a,b) ->+        case x of { (p,q) -> p } }+Here (a,b) both look dead, but come alive after the inner case is eliminated.+The point is that we bring into the envt a binding+        let x = (a,b)+after the outer case, and that makes (a,b) alive.  At least we do unless+the case binder is guaranteed dead.++Note [DataAlt occ info]+~~~~~~~~~~~~~~~~~~~~~~~+Our general goal is to preserve dead-ness occ-info on the field binders of a+case alternative. Why? It's generally a good idea, but one specific reason is to+support (SEQ4) of Note [seq# magic].++But we have to be careful: even if the field binder is not mentioned in the case+alternative and thus annotated IAmDead by OccurAnal, it might "come back to+life" in one of two ways:++ 1. If the case binder is alive, its unfolding might bring back the field+    binder, as in Note [knownCon occ info]:+      case blah of y { I# _ -> $wf (case y of I# v -> v) }+      ==>+      case blah of y { I# v -> $wf v }+ 2. Even if the case binder appears to be dead, there is the scenario in+    Note [Add unfolding for scrutinee], in which the fields come back to live+    through the unfolding of variable scrutinee, as follows:+      join j = case x of Just v -> blah v; Nothing -> ... in+      case x of Just _ -> jump j; Nothing -> ...+      ==> { inline j, unfold x to Just v, simplify }+      join j = case x of Just v -> blah v; Nothing -> ... in+      case x of Just v -> blah v; Nothing -> ...++Thus, when we are simply reconstructing a case (the common case), and the+case binder is not dead, or the scrutinee is a variable, we zap the+occurrence info on DataAlt field binders. See `adjustFieldOccInfo`.++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)++Note [Scaling in case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When two cases commute, if done naively, the multiplicities will be wrong:++  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]+  { (z[Many], t[Many]) -> z+  }++The multiplicities here, are correct, but if I perform a case of case:++  case u of w[1]+  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and+`y` must have multiplicities `Many` not `1`! The correct solution is to make+all the `1`-s be `Many`-s instead:++  case u of w[Many]+  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++In general, when commuting two cases, the rule has to be:++  case (case … of x[p] {…}) of y[q] { … }+  ===> case … of x[p*q] { … case … of y[q] { … } }++This is materialised, in the simplifier, by the fact that every time we simplify+case alternatives with a continuation (the surrounded case (or more!)), we must+scale the entire case we are simplifying, by a scaling factor which can be+computed in the continuation (with function `contHoleScaling`).+-}++simplAlts :: SimplEnv+          -> OutExpr         -- Scrutinee+          -> InId            -- Case binder+          -> [InAlt]         -- Non-empty+          -> SimplCont+          -> SimplM OutExpr  -- Returns the complete simplified case expression++simplAlts env0 scrut case_bndr alts cont'+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr+                                      , text "cont':" <+> ppr cont'+                                      , text "in_scope" <+> ppr (seInScope env0) ])+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding+              env2       = modifyInScope env1 case_bndr2+              -- See Note [Case binder evaluated-ness]+              fam_envs   = seFamEnvs env0++        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          --     by the caller (rebuildCase) in the missingAlt function+          -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts+          --     See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils++        ; alts' <- forM in_alts $+            simplAlt alt_env' (Just scrut') imposs_deflt_cons+                     case_bndr' (scrutOkForBinderSwap scrut) cont'++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]+  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr       -- The scrutinee+         -> [AltCon]            -- These constructors can't be present when+                                -- matching the DEFAULT alternative+         -> OutId               -- The case binder `bndr`+         -> BinderSwapDecision  -- DoBinderSwap v co <==> scrut = Just (v |> co),+                                --           add unfolding `v :-> bndr |> sym co`+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt DEFAULT [] rhs') }++simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt (LitAlt lit) [] rhs') }++simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          -- and Note [DataAlt occ info]+        ; let vs_with_info = adjustFieldsIdInfo scrut' case_bndr' bndr_swap' con vs+          -- Adjust evaluated-ness and occ-info flags before `simplBinders`+          -- because the latter extends the in-scope set, which propagates this+          -- adjusted info to use sites.+        ; (env', vs') <- simplBinders env vs_with_info++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app = mkConApp2 con inst_tys' vs'+              env''   = addAltUnfoldings env' case_bndr' bndr_swap' con_app++        ; rhs' <- simplExprC env'' rhs cont'+        ; return (Alt (DataAlt con) vs' rhs') }++{- Note [Adding evaluatedness info to pattern-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+addEvals records the evaluated-ness of the bound variables of+a case pattern.  This is *important*.  Consider++     data T = T !Int !Int++     case x of { T a b -> T (a+1) b }++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 [Strict fields in Core] in GHC.Core.++NB: simplLamBndrs preserves this eval info++In addition to handling data constructor fields with !s, addEvals+also records the fact that the result of seq# is always in WHNF.+See Note [seq# magic] in GHC.Types.Id.Make.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++adjustFieldsIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+-- and Note [DataAlt occ info]+adjustFieldsIdInfo scrut case_bndr bndr_swap con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , isUnboxedTupleDataCon con+  , [s,x] <- vs+    -- Use stripNArgs rather than collectArgsTicks to avoid building+    -- a list of arguments only to throw it away immediately.+  , Just (Var f) <- stripNArgs 4 scr+  , f `hasKey` seqHashKey+  , let x' = setCaseBndrEvald MarkedStrict x+  = map (adjustFieldOccInfo case_bndr bndr_swap) [s, x']++  -- Deal with banged datacon fields+  -- This case is quite allocation sensitive to T9233 which has a large record+  -- with strict fields. Hence we try not to update vs twice!+adjustFieldsIdInfo _scrut case_bndr bndr_swap con vs+  | Nothing <- dataConWrapId_maybe con+      -- A common fast path; no need to allocate the_strs when they are all lazy+      -- anyway! It shaves off 2% in T9675+  = map (adjustFieldOccInfo case_bndr bndr_swap) vs+  | otherwise+  = go vs the_strs+  where+    the_strs = dataConRepStrictness con++    go [] [] = []+    go (v:vs') strs | isTyVar v = v : go vs' strs+    go (v:vs') (str:strs) = adjustFieldOccInfo case_bndr bndr_swap (setCaseBndrEvald str v) : go vs' strs+    go _ _ = pprPanic "Simplify.adjustFieldsIdInfo"+              (ppr con $$+               ppr vs  $$+               ppr_with_length (map strdisp the_strs) $$+               ppr_with_length (dataConRepArgTys con) $$+               ppr_with_length (dataConRepStrictness con))+      where+        ppr_with_length list+          = ppr list <+> parens (text "length =" <+> ppr (length list))+        strdisp :: StrictnessMark -> SDoc+        strdisp MarkedStrict = text "MarkedStrict"+        strdisp NotMarkedStrict = text "NotMarkedStrict"++adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr+-- Kill occ info if we do binder swap and the case binder is alive;+-- see Note [DataAlt occ info]+adjustFieldOccInfo case_bndr bndr_swap field_bndr+  | isTyVar field_bndr+  = field_bndr++  | not (isDeadBinder case_bndr)  -- (1) in the Note: If the case binder is alive,+  = zapIdOccInfo field_bndr       -- the field binders might come back alive++  | DoBinderSwap{} <- bndr_swap   -- (2) in the Note: If binder swap might take place,+  = zapIdOccInfo field_bndr       -- the case binder might come back alive++  | otherwise+  = field_bndr                    -- otherwise the field binders stay dead++addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv+addDefaultUnfoldings env case_bndr bndr_swap imposs_deflt_cons+  = env2+  where+    unf = mkOtherCon imposs_deflt_cons+          -- Record the constructors that the case-binder *can't* be.+    env1 = addBinderUnfolding env case_bndr unf+    env2 | DoBinderSwap v _mco <- bndr_swap+         = addBinderUnfolding env1 v unf+         | otherwise = env1+++addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv+addAltUnfoldings env case_bndr bndr_swap con_app+  = env2+  where+    con_app_unf = mk_simple_unf con_app+    env1 = addBinderUnfolding env case_bndr con_app_unf++    -- See Note [Add unfolding for scrutinee]+    env2 | DoBinderSwap v mco <- bndr_swap+         = addBinderUnfolding env1 v $+              if isReflMCo mco  -- isReflMCo: avoid calling mk_simple_unf+              then con_app_unf  --            twice in the common case+              else mk_simple_unf (mkCastMCo con_app mco)++         | otherwise = env1++    -- Force the opts, so that the whole SimplEnv isn't retained+    !opts = seUnfoldingOpts env+    mk_simple_unf = mkSimpleUnfolding opts++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))+          "unfolding type mismatch"+          (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $+          modifyInScope env (bndr `setIdUnfolding` unf)++  | otherwise+  = modifyInScope env (bndr `setIdUnfolding` unf)++zapBndrOccInfo :: Bool -> Id -> Id+-- Consider  case e of b { (a,b) -> ... }+-- Then if we bind b to (a,b) in "...", and b is not dead,+-- then we must zap the deadness info on a,b+zapBndrOccInfo keep_occ_info pat_id+  | keep_occ_info = pat_id+  | otherwise     = zapIdOccInfo pat_id++{- Note [Case binder evaluated-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin on a (OtherCon []) unfolding to the case-binder of a Case,+even though it'll be over-ridden in every case alternative with a more+informative unfolding.  Why?  Because suppose a later, less clever, pass+simply replaces all occurrences of the case binder with the binder itself;+then Lint may complain about the let-can-float invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....+                ; K       -> blah }++The let-can-float invariant requires that y is evaluated in the call to+reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccurAnal has got rid of all such occurrences+See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".++BUT it is still VERY IMPORTANT to add a suitable unfolding for a+variable scrutinee, in simplAlt.  Here's why+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+There is no occurrence of 'b' in the (...(f y)...).  But y gets+the unfolding (a,b), and *that* mentions b.  If f has a RULE+    RULE f (p, I# q) = ...+we want that rule to match, so we must extend the in-scope env with a+suitable unfolding for 'y'.  It's *essential* for rule matching; but+it's also good for case-elimination -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.++Since this transformation is tantamount to a binder swap, we use+GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap to do the check.++Exactly the same issue arises in GHC.Core.Opt.SpecConstr;+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative+         -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont+  = do  { (floats1, env1)  <- bind_args env bs dc_args+        ; (floats2, env2)  <- bind_case_bndr env1+        ; (floats3, expr') <- simplExprF env2 rhs cont+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , GHC.Core.Make.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return (emptyFloats env', env')++    bind_args env' (b:bs') (Type ty : args)+      = assert (isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = assert (isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = assert (isId b) $+        do { let b' = zap_occ b+             -- zap_occ: the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplAuxBind may therefore discard it.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; (floats1, env2) <- simplAuxBind "knownCon" env' b' arg  -- arg satisfies let-can-float invariant+           ; (floats2, env3) <- bind_args env2 bs' args+           ; return (floats1 `addFloats` floats2, env3) }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return (emptyFloats env, env)+      | exprIsTrivial scrut = return (emptyFloats env+                                     , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))+                              -- See Note [Do not duplicate constructor applications]+      | otherwise           = do { dc_args <- mapM (simplInVar env) bs+                                         -- dc_ty_args are already OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplAuxBind "case-bndr" env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont+           -> SimplM (SimplFloats, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = warnPprTrace True "missingAlt" (ppr case_bndr) $+    -- See Note [Avoiding space leaks in OutType]+    let cont_ty = contResultType cont+    in seqType cont_ty `seq`+       return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt")++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************++Consider+  let x* = case e of { True -> e1; False -> e2 }+  in b+where x* is a strict binding.  Then mkDupableCont will be given+the continuation+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop+and will split it into+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop+   join floats:  $j1 = e1, $j2 = e2+   non_dupable:  let x* = [] in b; stop++Putting this back together would give+   let x* = let { $j1 = e1; $j2 = e2 } in+            case e of { True -> $j1; False -> $j2 }+   in b+(Of course we only do this if 'e' wants to duplicate that continuation.)+Note how important it is that the new join points wrap around the+inner expression, and not around the whole thing.++In contrast, any let-bindings introduced by mkDupableCont can wrap+around the entire thing.++Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See #4930.+-}++--------------------+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont+                  -> SimplM ( SimplFloats  -- Join points (if any)+                            , SimplEnv     -- Use this for the alts+                            , SimplCont)+mkDupableCaseCont env alts cont+  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont+                           ; let env' = bumpCaseDepth $+                                        env `setInScopeFromF` floats+                           ; return (floats, env', cont) }+  | otherwise         = return (emptyFloats env, env, cont)++altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative+altsWouldDup []  = False        -- See Note [Bottom alternatives]+altsWouldDup [_] = False+altsWouldDup (alt:alts)+  | is_bot_alt alt = altsWouldDup alts+  | otherwise      = not (all is_bot_alt alts)+    -- otherwise case: first alt is non-bot, so all the rest must be bot+  where+    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs++-------------------------+mkDupableCont :: SimplEnv+              -> SimplCont+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with+                                       --   extra let/join-floats and in-scope variables+                        , SimplCont)   -- dup_cont: duplicable continuation+mkDupableCont env cont+  = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont++mkDupableContWithDmds+   :: 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)++mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, CastIt { sc_co = optOutCoercion env co opt+                                 , sc_opt = True, sc_cont = cont' }) }+                 -- optOutCoercion: see Note [Avoid re-simplifying coercions]++-- Duplicating ticks for now, not sure if this is good or not+mkDupableContWithDmds env dmds (TickIt t cont)+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, TickIt t cont') }++mkDupableContWithDmds env _+     (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                 , sc_env = se, sc_cont = cont})+-- See Note [Duplicating StrictBind]+-- K[ let x = <> in b ]  -->   join j x = K[ b ]+--                             j <>+  = do { let sb_env = se `setInScopeFromE` env+       ; (sb_env1, bndr')      <- simplBinder sb_env bndr+       ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont+          -- No need to use mkDupableCont before simplNonRecBody; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; mkDupableStrictBind env bndr' join_body res_ty }++mkDupableContWithDmds env _+    (StrictArg { sc_fun = fun, sc_cont = cont+               , sc_fun_ty = fun_ty })+  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+  | isNothing (isDataConId_maybe (ai_fun fun))+         -- isDataConId: see point (DJ4) of Note [Duplicating join points]+  , 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 = 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+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)+                                           (ai_args fun)+       ; return ( foldl' addLetFloats floats1 floats_s+                , StrictArg { sc_fun = fun { ai_args = args' }+                            , sc_cont = cont'+                            , sc_fun_ty = fun_ty+                            , sc_dup = OkToDup} ) }++  | otherwise+  = -- Use Plan B of Note [Duplicating StrictArg]+    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]+    --                         j <>+    do { let rhs_ty       = contResultType cont+             (m,arg_ty,_) = splitFunTy fun_ty+       ; arg_bndr <- newId (fsLit "arg") m arg_ty+       ; let env' = env `addNewInScopeIds` [arg_bndr]+       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont+       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }+  where+    thumbsUpPlanA (StrictArg {})               = False+    thumbsUpPlanA (StrictBind {})              = True+    thumbsUpPlanA (Stop {})                    = True+    thumbsUpPlanA (Select {})                  = True+    thumbsUpPlanA (CastIt { sc_cont = k })     = thumbsUpPlanA k+    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k++mkDupableContWithDmds env dmds+    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, ApplyToTy { sc_cont = cont'+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env dmds+    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se+                , sc_cont = cont, sc_hole_ty = hole_ty })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    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+        ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'+        ; let all_floats = floats1 `addLetFloats` let_floats2+        ; return ( all_floats+                 , ApplyToVal { sc_arg = arg''+                              , sc_env = se' `setInScopeFromF` all_floats+                                         -- Ensure that sc_env includes the free vars of+                                         -- arg'' in its in-scope set, even if makeTrivial+                                         -- has turned arg'' into a fresh variable+                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                              , sc_dup = OkToDup, sc_cont = cont'+                              , sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env _+    (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+  =     -- e.g.         (case [...hole...] of { pi -> ei })+        --      ===>+        --              let ji = \xij -> ei+        --              in case [...hole...] of { pi -> ji xij }+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { tick (CaseOfCase case_bndr)+        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont+                -- NB: We call mkDupableCaseCont here to make cont duplicable+                --     (if necessary, depending on the number of alts)+                -- And this is important: see Note [Fusing case continuations]++        ; let cont_scaling = contHoleScaling cont+          -- See Note [Scaling in case-of-case]+        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)+        ; alts' <- forM (scaleAltsBy cont_scaling alts) $+            simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont+                -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt env case_bndr')+                                              emptyJoinFloats alts'++        ; let all_floats = floats `addJoinFloats` join_floats+                           -- Note [Duplicated env]+        ; return (all_floats+                 , Select { sc_dup  = OkToDup+                          , sc_bndr = case_bndr'+                          , sc_alts = alts''+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats+                                      -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                          , sc_cont = mkBoringStop (contResultType cont) } ) }++mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType+                    -> SimplM (SimplFloats, SimplCont)+mkDupableStrictBind env arg_bndr join_rhs res_ty+  | uncondInlineJoin [arg_bndr] join_rhs+     -- See point (DJ2) of Note [Duplicating join points]+  = return (emptyFloats env+           , StrictBind { sc_bndr = arg_bndr+                        , sc_body = join_rhs+                        , sc_env  = zapSubstEnv env+                        , sc_from = FromLet+                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                        , sc_dup  = OkToDup+                        , sc_cont = mkBoringStop res_ty } )+  | otherwise+  = do { join_bndr <- newJoinId [arg_bndr] res_ty+       ; let arg_info = ArgInfo { ai_fun   = join_bndr+                                , ai_rules = [], ai_args  = []+                                , ai_encl  = False, ai_dmds  = repeat topDmd+                                , ai_discs = repeat 0 }+       ; return ( addJoinFloats (emptyFloats env) $+                  unitJoinFloat                   $+                  NonRec join_bndr                $+                  Lam (setOneShotLambda arg_bndr) join_rhs+                , StrictArg { sc_dup    = OkToDup+                            , sc_fun    = arg_info+                            , sc_fun_ty = idType join_bndr+                            , sc_cont   = mkBoringStop res_ty+                            } ) }++mkDupableAlt :: SimplEnv -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt _env case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)+  | uncondInlineJoin alt_bndrs alt_rhs_in+    -- See point (DJ2) of Note [Duplicating join points]+  = return (jfloats, Alt con alt_bndrs alt_rhs_in)++  | otherwise+  = do  { let rhs_ty'  = exprType alt_rhs_in++              bangs+                | DataAlt c <- con+                = dataConRepStrictness c+                | otherwise = []++              abstracted_binders = abstract_binders alt_bndrs bangs++              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]+              abstract_binders [] []+                -- Abstract over the case binder too if it's used.+                | isDeadBinder case_bndr  = []+                | otherwise               = [(case_bndr,MarkedStrict)]+              abstract_binders (alt_bndr:alt_bndrs) marks+                -- Abstract over all type variables just in case+                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks+              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)+                -- The deadness info on the new Ids is preserved by simplBinders+                -- We don't abstract over dead ids here.+                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks+                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks+              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)++              filtered_binders = map fst abstracted_binders+              -- We want to make any binder with an evaldUnfolding strict in the rhs.+              -- See Note [Call-by-value for worker args] (which also applies to join points)+              rhs_with_seqs = mkStrictFieldSeqs abstracted_binders alt_rhs_in++              final_args = varsToCoreExprs filtered_binders+                           -- Note [Join point abstraction]++                -- We make the lambdas into one-shot-lambdas.  The+                -- join point is sure to be applied at most once, and doing so+                -- prevents the body of the join point being floated out by+                -- the full laziness pass+              final_bndrs     = map one_shot filtered_binders+              one_shot v | isId v    = setOneShotLambda v+                         | otherwise = v++              -- No lambda binder has an unfolding, but (currently) case binders can,+              -- so we must zap them here.+              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs++        ; join_bndr <- newJoinId filtered_binders rhs_ty'+        ; let -- join_bndr_w_unf = join_bndr `setIdUnfolding`+              --                   mkUnfolding uf_opts VanillaSrc False False join_rhs Nothing+              -- See Note [Do not add unfoldings to join points at birth]+              join_call = mkApps (Var join_bndr) final_args+              alt'      = Alt con alt_bndrs join_call++        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)+                 , alt') }+                -- See Note [Duplicated env]++{-+Note [Do not add unfoldings to join points at birth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15360)++   case (case (case (case ...))) of+      Left x  -> e1+      Right y -> e2++We will make a join point for e1, e2, thus+    $j1a x = e1+    $j1b y = e2++Now those join point calls count as "duplicable" , so we feel free to duplicate+them into the loop nest.  And each of those calls are then subject to+callSiteInline, which might inline them, if e1, e2 are reasonably small.  Now,+if this applies recursive to the next `case` inwards, and so on, the net+effect is that we can get an exponential number of calls to $j1a and $j1b, and+an exponential number of inlinings (since each is done independently).++This hit #15360 (not a complicated program!) badly.  Our simple solution is this:+when a join point is born, we don't give it an unfolding, so it will not be inlined+at its call sites, at least not in that pass.  So we end up with+    $j1a x = e1+    $j1b y = e2+    $j2a x = ...$j1a ... $j1b...+    $j2b x = ...$j1a ... $j1b...+    ... and so on...++In the next iteration of the Simplifier we are into Note [Avoid inlining into+deeply nested cases] in Simplify.Inline, which is still a challenge.  But at+least we have a chance. If we add inlinings at birth we never get that chance.++Wrinkle++(JU1) It turns out that the same problem shows up in a different guise, via+      Note [Post-inline for single-use things] in Simplify.Utils.  I think+      we have something like+         case K (join $j x = <rhs> in jblah) of K y{OneOcc} -> blah+      where $j is a freshly-born join point.  After case-of-known-constructor+      wo we end up substituting (join $j x = <rhs> in jblah) for `y` in `blah`;+      and thus we re-simplify that join binding.  In test T15630 this results in+      massive duplication.++      So in `simplLetUnfolding` we spot this case a bit hackily; a freshly-born+      join point will have OccInfo of ManyOccs, unlike an existing join point which+      will have OneOcc.  So in simplLetUnfolding we kill the unfolding of a freshly+      born join point.++I can't quite articulate precisely why this is so important.  But it makes a+MASSIVE difference in T15630 (a fantastic test case); and at worst it'll merely+delay inlining join points by one simplifier iteration.++In effect (JU1) just extends the original Note [Do not add unfoldings to join+points at birth] to occasions where we re-visit the same join-point in the same+Simplifier iteration.++Note [Fusing case continuations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important to fuse two successive case continuations when the+first has one alternative.  That's why we call prepareCaseCont here.+Consider this, which arises from thunk splitting (see Note [Thunk+splitting] in GHC.Core.Opt.WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StrictBind body Stop)+Supposing that body is big, we end up with+          let $j a = <let x = I# a in body>+          in case v of { pn -> case rn of+                                 I# a -> $j a }+This is just what we want because the rn produces a box that+the case rn cancels with.++See #4957 a fuller example.++Note [Duplicating join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19996 we discovered that we want to be really careful about+inlining join points.   Consider+    case (join $j x = K f x )+         (in case v of      )+         (     p1 -> $j x1  ) of+         (     p2 -> $j x2  )+         (     p3 -> $j x3  )+      K g y -> blah[g,y]++Here the join-point RHS is very small, just a constructor+application (K f x).  So we might inline it to get+    case (case v of          )+         (     p1 -> K f x1  ) of+         (     p2 -> K f x2  )+         (     p3 -> K f x3  )+      K g y -> blah[g,y]++But now we have to make `blah` into a join point, /abstracted/+over `g` and `y`. We get+    join $j2 g y = blah+    in case v of+         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.+So not-inlining join points is our default: but see Note [Inlining join points]+in GHC.Core.Opt.Simplify.Inline for when we /do/ inline them.++To achieve this parsimonious inlining of join points, we need to do two things:+(a) create a join point even if the RHS is small; and (b) don't do+unconditional-inlining for join points.++(DJ1) Do not postInlineUnconditionally a join point, ever. Doing+   postInlineUnconditionally is primarily to push allocation into cold+   branches; but a join point doesn't allocate, so that's a non-motivation.++(DJ2) In mkDupableAlt and mkDupableStrictBind, generate an alterative for /all/+   alternatives, /except/ for ones that will definitely inline unconditionally+   straight away.  (In that case it's silly to make a join point in the first+   place; it just takes an extra Simplifier iteration to undo.)  This choice is+   made by GHC.Core.Unfold.uncondInlineJoin.++   This plan generates a lot of join points, but makes them much more+   case-of-case friendly.++(DJ3) When should `uncondInlineJoin` return True?+   (a) (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see+     the defn of exprIsTrivial.  Also nullary constructors.++   (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+   call to isDataConId in the StrictArg case of mkDupableContWithDmds.++   That same Note [Duplicating StrictArg] explains why we sometimes want Plan A+   when the RHS of the new join point would be a non-data-constructor+   application++(DJ5) You might worry that $j = K x y might look so small that it is inlined+   by the call site inliner, defeating (DJ3). But in fact++   - The UnfoldingGuidance for a join point is only UnfWhen (unconditional)+     if `uncondInlineJoin` is true; see GHC.Core.Unfold.uncondInline++   - `GHC.Core.Opt.Simplify.Inline.tryUnfolding` has a special case for join+     points, described Note [Inlining join points] in that module.++Historical Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: this entire Note is now irrelevant.  In Jun 21 we stopped+adding unfoldings to lambda binders (#17530).  It was always a+hack and bit us in multiple small and not-so-small ways++Consider this+   case (case .. ) of c {+     I# c# -> ....c....++If we make a join point with c but not c# we get+  $j = \c -> ....c....++But if later inlining scrutinises the c, thus++  $j = \c -> ... case c of { I# y -> ... } ...++we won't see that 'c' has already been scrutinised.  This actually+happens in the 'tabulate' function in wave4main, and makes a significant+difference to allocation.++An alternative plan is this:++   $j = \c# -> let c = I# c# in ...c....++but that is bad if 'c' is *not* later scrutinised.++So instead we do both: we pass 'c' and 'c#' , and record in c's inlining+(a stable unfolding) that it's really I# c#, thus++   $j = \c# -> \c[=I# c#] -> ...c....++Absence analysis may later discard 'c'.++NB: take great care when doing strictness analysis;+    see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.++Also note that we can still end up passing stuff that isn't used.  Before+strictness analysis we have+   let $j x y c{=(x,y)} = (h c, ...)+   in ...+After strictness analysis we see that h is strict, we end up with+   let $j x y c{=(x,y)} = ($wh x y, ...)+and c is unused.++Note [Duplicated env]+~~~~~~~~~~~~~~~~~~~~~+Some of the alternatives are simplified, but have not been turned into a join point+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to+bind the join point, because it might to do PostInlineUnconditionally, and+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,+but zapping it (as we do in mkDupableCont, the Select case) is safe, and+at worst delays the join-point inlining.++Note [Funky mkLamTypes]+~~~~~~~~~~~~~~~~~~~~~~+Notice the funky mkLamTypes.  If the constructor has existentials+it's possible that the join point will be abstracted over+type variables as well as term variables.+ Example:  Suppose we have+        data T = forall t.  C [t]+ Then faced with+        case (case e of ...) of+            C t xs::[t] -> rhs+ We get the join point+        let j :: forall t. [t] -> ...+            j = /\t \xs::[t] -> rhs+        in+        case (case e of ...) of+            C t xs::[t] -> j t xs++Note [Duplicating StrictArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dealing with making a StrictArg continuation duplicable has turned out+to be one of the trickiest corners of the simplifier, giving rise+to several cases in which the simplier expanded the program's size+*exponentially*.  They include+  #13253 exponential inlining+  #10421 ditto+  #18140 strict constructors+  #18282 another nested-function call case++Suppose we have a call+  f e1 (case x of { True -> r1; False -> r2 }) e3+and f is strict in its second argument.  Then we end up in+mkDupableCont with a StrictArg continuation for (f e1 <> e3).+There are two ways to make it duplicable.++* Plan A: move the entire call inwards, being careful not+  to duplicate e1 or e3, thus:+     let a1 = e1+         a3 = e3+     in case x of { True  -> f a1 r1 a3+                  ; False -> f a1 r2 a3 }++* Plan B: make a join point:+     join $j x = f e1 x e3+     in case x of { True  -> jump $j r1+                  ; False -> jump $j r2 }++  Notice that Plan B is very like the way we handle strict bindings;+  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd+  get if we turned use a case expression to evaluate the strict arg:++       case (case x of { True -> r1; False -> r2 }) of+         r -> f e1 r e3++  So, looking at Note [Duplicating join points], we also want Plan B+  when `f` is a data constructor.++Plan A is often good:++* The calls to `f` may well be able to inline, since they are now applied+  to more informative arguments, `r1`, `r2`. For example:+        && E (case x of { T -> F; F -> T })+  Pushing the call inward (being careful not to duplicate E) we get+        let a = E+        in case x of { T -> && a F; F -> && a T }+  and now the (&& a F) etc can optimise.++* Moreover there might be a RULE for the function that can fire when it "sees"+  the particular case alternative.++* More specialisation can happen.  Here's an example from #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')++  If we pushed the entire call for 'go' inside the case, we get+  call-pattern specialisation for 'go', which is *crucial* for+  this particular program.++But Plan A can have terrible, terrible behaviour. Here is a classic+case:+  f (f (f (f (f True))))++Suppose f is strict, and has a body that is small enough to inline.+The innermost call inlines (seeing the True) to give+  f (f (f (f (case v of { True -> e1; False -> e2 }))))++Now, suppose we naively push the entire continuation into both+case branches (it doesn't look large, just f.f.f.f). We get+  case v of+    True  -> f (f (f (f e1)))+    False -> f (f (f (f e2)))++And now the process repeats, so we end up with an exponentially large+number of copies of f. No good!++CONCLUSION: we want Plan A in general, but do Plan B is there a+danger of this nested call behaviour. The function that decides+this is called thumbsUpPlanA.++Note [Keeping demand info in StrictArg Plan A]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Following on from Note [Duplicating StrictArg], another common code+pattern that can go bad is this:+   f (case x1 of { T -> F; F -> T })+     (case x2 of { T -> F; F -> T })+     ...etc...+when f is strict in all its arguments.  (It might, for example, be a+strict data constructor whose wrapper has not yet been inlined.)++We use Plan A (because there is no nesting) giving+  let a2 = case x2 of ...+      a3 = case x3 of ...+  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }++Now we must be careful!  a2 and a3 are small, and the OneOcc code in+postInlineUnconditionally may inline them both at both sites; see Note+Note [Inline small things to avoid creating a thunk] in+Simplify.Utils. But if we do inline them, the entire process will+repeat -- back to exponential behaviour.++So we are careful to keep the demand-info on a2 and a3.  Then they'll+be /strict/ let-bindings, which will be dealt with by StrictBind.+That's why contIsDupableWithDmds is careful to propagage demand+info to the auxiliary bindings it creates.  See the Demand argument+to makeTrivial.++Note [Duplicating StrictBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictBind duplicable in a very similar way to+that for case expressions.  After all,+   let x* = e in b   is similar to    case e of x -> b++So we potentially make a join-point for the body, thus:+   let x = <> in b   ==>   join j x = b+                           in j <>++Just like StrictArg in fact -- and indeed they share code.++Note [Join point abstraction]  Historical note+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This note is now historical, describing how (in the past) we used+to add a void argument to nullary join points.  But now that "join+point" is not a fuzzy concept but a formal syntactic construct (as+distinguished by the JoinId constructor of IdDetails), each of these+concerns is handled separately, with no need for a vestigial extra+argument.++Join points always have at least one value argument,+for several reasons++* If we try to lift a primitive-typed something out+  for let-binding-purposes, we will *caseify* it (!),+  with potentially-disastrous strictness results.  So+  instead we turn it into a function: \v -> e+  where v::Void#.  The value passed to this function is void,+  which generates (almost) no code.++* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now+  we make the join point into a function whenever used_bndrs'+  is empty.  This makes the join-point more CPR friendly.+  Consider:       let j = if .. then I# 3 else I# 4+                  in case .. of { A -> j; B -> j; C -> ... }++  Now CPR doesn't w/w j because it's a thunk, so+  that means that the enclosing function can't w/w either,+  which is a lose.  Here's the example that happened in practice:+          kgmod :: Int -> Int -> Int+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0+                      then 78+                      else 5++* Let-no-escape.  We want a join point to turn into a let-no-escape+  so that it is implemented as a jump, and one of the conditions+  for LNE is that it's not updatable.  In CoreToStg, see+  Note [What is a non-escaping let]++* Floating.  Since a join point will be entered once, no sharing is+  gained by floating out, but something might be lost by doing+  so because it might be allocated.++I have seen a case alternative like this:+        True -> \v -> ...+It's a bit silly to add the realWorld dummy arg in this case, making+        $j = \s v -> ...+           True -> $j s+(the \v alone is enough to make CPR happy) but I think it's rare++There's a slight infelicity here: we pass the overall+case_bndr to all the join points if it's used in *any* RHS,+because we don't know its usage in each RHS separately++++************************************************************************+*                                                                      *+                    Unfoldings+*                                                                      *+************************************************************************+-}++simplLetUnfolding :: SimplEnv+                  -> BindContext+                  -> InId+                  -> OutExpr -> OutType -> ArityType+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf+  | isStableUnfolding unf+  = simplStableUnfolding env bind_cxt id rhs_ty arity unf++  | freshly_born_join_point id+  = -- This is a tricky one!+    -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth]+    return noUnfolding++  | isExitJoinId id+  = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify+    return noUnfolding++  | otherwise+  = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs++  where+    is_join_point = isJoinId id+    freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id)+      -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627++-------------------+mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource+               -> InId -> Bool    -- True <=> this is a join point+               -> OutExpr -> SimplM Unfolding+mkLetUnfolding env top_lvl src id is_join new_rhs+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming is_join new_rhs Nothing)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to+            --             expose the unfolding then indeed we *have* an unfolding+            --             to expose.  (We could instead use the RHS, but currently+            --             we don't.)  The simple thing is always to have one.+  where+    -- !opts: otherwise, we end up retaining all the SimpleEnv+    !uf_opts = seUnfoldingOpts env++    -- Might as well force this, profiles indicate up to+    -- 0.5MB of thunks just from this site.+    !is_top_lvl   = isTopLevel top_lvl+    -- See Note [Force bottoming field]+    !is_bottoming = isDeadEndId id++-------------------+simplStableUnfolding :: SimplEnv -> BindContext+                     -> InId+                     -> OutType+                     -> ArityType      -- Used to eta expand, but only for non-join-points+                     -> Unfolding+                     ->SimplM Unfolding+-- Note [Setting the new unfolding]+simplStableUnfolding env bind_cxt id rhs_ty id_arity unf+  = case unf of+      NoUnfolding   -> return unf+      BootUnfolding -> return unf+      OtherCon {}   -> return unf++      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }+        -> do { (env', bndrs') <- simplBinders unf_env bndrs+              ; args' <- mapM (simplExpr env') args+              ; return (mkDFunUnfolding bndrs' con args') }++      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }+        | isStableSource src+        -> do { expr' <- case bind_cxt of+                  BC_Join _ cont    -> -- Binder is a join point+                                       -- See Note [Rules and unfolding for join points]+                                       simplJoinRhs unf_env id expr cont+                  BC_Let _ is_rec -> -- Binder is not a join point+                                     do { let cont = mkRhsStop rhs_ty is_rec topDmd+                                           -- mkRhsStop: switch off eta-expansion at the top level+                                        ; expr' <- simplExprC unf_env expr cont+                                        ; return (eta_expand expr') }+              ; case guide of+                  UnfWhen { ug_boring_ok = boring_ok }+                     -- Happens for INLINE things+                     -- Really important to force new_boring_ok since otherwise+                     --   `ug_boring_ok` is a thunk chain of+                     --   inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ...+                     -- See #20134+                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+                            guide' = guide { ug_boring_ok = new_boring_ok }+                        -- Refresh the boring-ok flag, in case expr'+                        -- has got small. This happens, notably in the inlinings+                        -- for dfuns for single-method classes; see+                        -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.+                        -- A test case is #4138+                        -- But retain a previous boring_ok of True; e.g. see+                        -- the way it is set in calcUnfoldingGuidanceWithArity+                        in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding env top_lvl src id False expr' }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    -- Forcing this can save about 0.5MB of max residency and the result+    -- is small and easy to compute so might as well force it.+    top_lvl     = bindContextLevel bind_cxt+    !is_top_lvl = isTopLevel top_lvl+    act        = idInlineActivation id+    unf_env    = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils++    -- See Note [Eta-expand stable unfoldings]+    -- Use the arity from the main Id (in id_arity), rather than computing it from rhs+    -- Not used for join points+    eta_expand expr | seEtaExpand env+                    , exprArity expr < arityTypeArity id_arity+                    , wantEtaExpansion expr+                    = etaExpandAT (getInScope env) id_arity expr+                    | otherwise+                    = expr++{- Note [Eta-expand stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For INLINE/INLINABLE things (which get stable unfoldings) there's a danger+of getting+   f :: Int -> Int -> Int -> Blah+   [ Arity = 3                 -- Good arity+   , Unf=Stable (\xy. blah)    -- Less good arity, only 2+   f = \pqr. e++This can happen because f's RHS is optimised more vigorously than+its stable unfolding.  Now suppose we have a call+   g = f x+Because f has arity=3, g will have arity=2.  But if we inline f (using+its stable unfolding) g's arity will reduce to 1, because <blah>+hasn't been optimised yet.  This happened in the 'parsec' library,+for Text.Pasec.Char.string.++Generally, if we know that 'f' has arity N, it seems sensible to+eta-expand the stable unfolding to arity N too. Simple and consistent.++Wrinkles++* See Historical-note [Eta-expansion in stable unfoldings] in+  GHC.Core.Opt.Simplify.Utils++* Don't eta-expand a trivial expr, else each pass will eta-reduce it,+  and then eta-expand again. See Note [Which RHSs do we eta-expand?]+  in GHC.Core.Opt.Simplify.Utils.++* Don't eta-expand join points; see Note [Do not eta-expand join points]+  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point+  case (bind_cxt = BC_Join {}) doesn't use eta_expand.++Note [Force bottoming field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to force bottoming, or the new unfolding holds+on to the old unfolding (which is part of the id).++Note [Setting the new unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we+  should do nothing at all, but simplifying gently might get rid of+  more crap.++* If not, we make an unfolding from the new RHS.  But *only* for+  non-loop-breakers. Making loop breakers not have an unfolding at all+  means that we can avoid tests in exprIsConApp, for example.  This is+  important: if exprIsConApp says 'yes' for a recursive thing, then we+  can get into an infinite loop++If there's a stable unfolding on a loop breaker (which happens for+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the+user did say 'INLINE'.  May need to revisit this choice.++************************************************************************+*                                                                      *+                    Rules+*                                                                      *+************************************************************************++Note [Rules in a letrec]+~~~~~~~~~~~~~~~~~~~~~~~~+After creating fresh binders for the binders of a letrec, we+substitute the RULES and add them back onto the binders; this is done+*before* processing any of the RHSs.  This is important.  Manuel found+cases where he really, really wanted a RULE for a recursive function+to apply in that function's own right-hand side.++See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr+             -> BindContext+             -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id bind_cxt+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]+-- Simplify local rules for imported Ids+simplImpRules env rules+  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)++simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]+           -> BindContext -> SimplM [CoreRule]+simplRules env mb_new_id rules bind_cxt+  = mapM simpl_rule rules+  where+    simpl_rule rule@(BuiltinRule {})+      = return rule++    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args+                          , ru_fn = fn_name, ru_rhs = rhs+                          , ru_act = act })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]+                                BC_Let {}      -> mkBoringStop rhs_ty+                                BC_Join _ cont -> assertPpr join_ok bad_join_msg cont+                 lhs_env = updMode updModeForRules env'+                 rhs_env = updMode (updModeForStableUnfoldings act) env'+                           -- See Note [Simplifying the RHS of a RULE]+                 -- Force this to avoid retaining reference to old Id+                 !fn_name' = case mb_new_id of+                              Just id -> idName id+                              Nothing -> fn_name++                 -- join_ok is an assertion check that the join-arity of the+                 -- binder matches that of the rule, so that pushing the+                 -- continuation into the RHS makes sense+                 join_ok = case mb_new_id of+                             Just id | JoinPoint join_arity <- idJoinPointHood id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap idJoinPointHood mb_new_id) ]             ; args' <- mapM (simplExpr lhs_env) args            ; rhs'  <- simplExprC rhs_env rhs rhs_cont
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -219,7 +219,6 @@              join_arity = length bndrs              details    = JoinId join_arity Nothing              id_info    = vanillaIdInfo `setArityInfo` arity---                                        `setOccInfo` strongLoopBreaker         ; return (mkLocalVar details name ManyTy join_id_ty id_info) }
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -13,7 +13,7 @@          -- Inlining,         preInlineUnconditionally, postInlineUnconditionally,-        activeUnfolding, activeRule,+        activeRule,         getUnfoldingInRuleMatch,         updModeForStableUnfoldings, updModeForRules, @@ -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,@@ -43,17 +43,18 @@     ) where  import GHC.Prelude hiding (head, init, last, tail)+import qualified GHC.Prelude as Partial (head)  import GHC.Core import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline ) import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr 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@@ -79,11 +80,11 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Monad    ( when ) import Data.List        ( sortBy )-import qualified Data.List as Partial ( head )+import GHC.Types.Name.Env+import Data.Graph  {- ********************************************************************* *                                                                      *@@ -161,9 +162,12 @@     | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]-        OutCoercion             -- The coercion simplified+      { sc_co   :: OutCoercion  -- The coercion simplified                                 -- Invariant: never an identity coercion-        SimplCont+      , sc_opt  :: Bool         -- True <=> sc_co has had optCoercion applied to it+                                --      See Note [Avoid re-simplifying coercions]+                                --      in GHC.Core.Opt.Simplify.Iteration+      , sc_cont :: SimplCont }    | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]       { sc_dup     :: DupFlag   -- See Note [DupFlag invariants]@@ -190,10 +194,11 @@   | StrictBind          -- (StrictBind x b K)[e] = let x = e in K[b]                         --       or, equivalently,  = K[ (\x.b) e ]       { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]-      , sc_bndr  :: InId       , sc_from  :: FromWhat+      , sc_bndr  :: InId       , sc_body  :: InExpr-      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_env   :: StaticEnv      -- Static env for both sc_bndr (stable unfolding thereof)+                                   -- and sc_body.  Also see Note [StaticEnv invariant]       , sc_cont  :: SimplCont }    | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]@@ -213,7 +218,7 @@  type StaticEnv = SimplEnv       -- Just the static part is relevant -data FromWhat = FromLet | FromBeta OutType+data FromWhat = FromLet | FromBeta Levity  -- See Note [DupFlag invariants] data DupFlag = NoDup       -- Unsimplified, might be big@@ -271,21 +276,23 @@     = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty     where       pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd]-  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont-  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont+  ppr (CastIt { sc_co = co, sc_cont = cont })+    = (text "CastIt" <+> pprOptCo co) $$ ppr cont+  ppr (TickIt t cont)+    = (text "TickIt" <+> ppr t) $$ ppr cont   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 })     = (text "StrictBind" <+> ppr b) $$ ppr cont   ppr (StrictArg { sc_fun = ai, sc_cont = cont })     = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont-  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_cont = cont })     = (text "Select" <+> ppr dup <+> ppr bndr) $$-       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont+      whenPprDebug (nest 2 $ ppr alts) $$ ppr cont   {- Note [The hole type in ApplyToTy]@@ -316,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 @@ -334,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@@ -348,61 +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- 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@@ -411,8 +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 c cont +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@@ -422,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- {- ************************************************************************ *                                                                      *@@ -468,7 +434,7 @@ ------------------- contIsRhs :: SimplCont -> Maybe RecFlag contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec-contIsRhs (CastIt _ k)                = contIsRhs k   -- For f = e |> co, treat e as Rhs context+contIsRhs (CastIt { sc_cont = k })    = contIsRhs k   -- For f = e |> co, treat e as Rhs context contIsRhs _                           = Nothing  -------------------@@ -482,7 +448,7 @@ contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto... contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...-contIsDupable (CastIt _ k)                      = contIsDupable k+contIsDupable (CastIt { sc_cont = k })          = contIsDupable k contIsDupable _                                 = False  -------------------@@ -491,13 +457,13 @@ contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k -- This one doesn't look right.  A value application is not trivial -- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k-contIsTrivial (CastIt _ k)                                      = contIsTrivial k+contIsTrivial (CastIt { sc_cont = k })                          = contIsTrivial k contIsTrivial _                                                 = False  ------------------- contResultType :: SimplCont -> OutType contResultType (Stop ty _ _)                = ty-contResultType (CastIt _ k)                 = contResultType k+contResultType (CastIt { sc_cont = k })     = contResultType k contResultType (StrictBind { sc_cont = k }) = contResultType k contResultType (StrictArg { sc_cont = k })  = contResultType k contResultType (Select { sc_cont = k })     = contResultType k@@ -508,7 +474,7 @@ contHoleType :: SimplCont -> OutType contHoleType (Stop ty _ _)                    = ty contHoleType (TickIt _ k)                     = contHoleType k-contHoleType (CastIt co _)                    = coercionLKind co+contHoleType (CastIt { sc_co = co })          = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })   = perhapsSubstTy dup se (idType b) contHoleType (StrictArg  { sc_fun_ty = ty })  = funArgTy ty@@ -528,7 +494,8 @@ -- case-of-case transformation. contHoleScaling :: SimplCont -> Mult contHoleScaling (Stop _ _ _) = OneTy-contHoleScaling (CastIt _ k) = contHoleScaling k+contHoleScaling (CastIt { sc_cont = k })+  = contHoleScaling k contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })   = idMult id `mkMultMul` contHoleScaling k contHoleScaling (Select { sc_bndr = id, sc_cont = k })@@ -547,14 +514,14 @@ -- and other values; skipping over casts. countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont-countArgs (CastIt _ cont)                 = countArgs cont+countArgs (CastIt     { sc_cont = cont }) = countArgs cont countArgs _                               = 0  countValArgs :: SimplCont -> Int -- Count value arguments only countValArgs (ApplyToTy  { sc_cont = cont }) = countValArgs cont countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont-countValArgs (CastIt _ cont)                 = countValArgs cont+countValArgs (CastIt     { sc_cont = cont }) = countValArgs cont countValArgs _                               = 0  -------------------@@ -574,13 +541,41 @@     go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })                                         = go (is_interesting arg se : args) k     go args (ApplyToTy { sc_cont = k }) = go args k-    go args (CastIt _ k)                = go args k+    go args (CastIt { sc_cont = k })    = go args k     go args k                           = (False, reverse args, k)      is_interesting arg se = interestingArg se arg                    -- 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@@ -593,10 +588,10 @@ -- about what to do then and no call sites so far seem to care. contEvalContext :: SimplCont -> SubDemand contEvalContext k = case k of-  (Stop _ _ sd)              -> sd-  (TickIt _ k)               -> contEvalContext k-  (CastIt _ k)               -> contEvalContext k-  ApplyToTy{sc_cont=k}       -> contEvalContext k+  Stop _ _ sd              -> sd+  TickIt _ k               -> contEvalContext k+  CastIt   { sc_cont = k } -> contEvalContext k+  ApplyToTy{ sc_cont = k } -> contEvalContext k     --  ApplyToVal{sc_cont=k}      -> mkCalledOnceDmd $ contEvalContext k     -- Not 100% sure that's correct, . Here's an example:     --   f (e x) and f :: <SC(S,C(1,L))>@@ -612,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@@ -687,7 +679,7 @@       | Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info       , dmd : rest_dmds <- dmds       , let dmd'-             | Just Unlifted <- typeLevity_maybe arg_ty+             | definitelyUnliftedType arg_ty              = strictifyDmd dmd              | otherwise              -- Something that's not definitely unlifted.@@ -792,45 +784,87 @@           True  -> Just x           False -> Just (x-1) -Now consider these cases:+Now consider these variants of+   case (f x) of ... -1. case f x of b{-dead-} { DEFAULT -> blah[no b] }-     Inlining (f x) will allow us to avoid ever allocating (Just x),-     since the case binder `b` is dead.  We will end up with a+1. [Dead case binder]: inline f+      case f x of b{-dead-} { DEFAULT -> blah[no b] }+   Inlining (f x) will allow us to avoid ever allocating (Just x),+   since the case binder `b` is dead.  We will end up with a      join point for blah, thus          join j = blah in          case v of { True -> j; False -> j }-     which will turn into (case v of DEFAULT -> blah-     All good--2. case f x of b { DEFAULT -> blah[b] }-     Inlining (f x) will still mean we allocate (Just x). We'd get:-         join j b = blah[b]-         case v of { True -> j (Just x); False -> j (Just (x-1)) }-     No new optimisations are revealed. Nothing is gained.-     (This is the situation in T22317.)--2a. case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] }-      Instead of DEFAULT we have a single constructor alternative-      with all dead binders.  This is just a variant of (2); no-      gain from inlining (f x)+   which will turn into (case v of DEFAULT -> blah)+   All good -3. case f x of b { Just y -> blah[y,b] }-     Inlining (f x) will mean we still allocate (Just x),-     but we also get to bind `y` without fetching it out of the Just, thus+2. [Live case binder, live alt binders]: inline f+       case f x of b { Just y -> blah[y,b] }+   Inlining (f x) will mean we still allocate (Just x),+   but we also get to bind `y` without fetching it out of the Just, thus          join j y b = blah[y,b]          case v of { True -> j x (Just x)                    ; False -> let y = x-1 in j y (Just y) }    Inlining (f x) has a small benefit, perhaps.    (To T14955 it makes a surprisingly large difference of ~30% to inline here.) +3. [Live case binder, dead alt binders]: maybe don't inline f+      case f x of b { DEFAULT -> blah[b] }+   Inlining (f x) will still mean we allocate (Just x). We'd get:+         join j b = blah[b]+         case v of { True -> j (Just x); False -> j (Just (x-1)) }+   No new optimisations are revealed. Nothing is gained.+   (This is the situation in T22317.) -Conclusion: if the case expression-  * Has a non-dead case-binder-  * Has one alternative+   A variant is when we have a data constructor with dead binders:+       case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] }+   Instead of DEFAULT we have a single constructor alternative+   with all dead binders.  Again, no gain from inlining (f x)++4. [Live case binder, dead alt binders]: small f+   Suppose f is CPR'd, so it looks like+       f x = case $wf x of (# a #) -> Just a+   Then even in case (3) we want to inline:+      case f x of b { DEFAULT -> blah[b] }+   -->+      case $wf x of (# a #) ->+      let b = Just a in blah[b]+   This is very good; we now know a lot about `b` (instead of nothing)+   and `blah` might benefit.  Similarly if `f` has a join point+      f x = join $j y = Just y in ...+   Again the case (f x) is now consuming a constructor (Just y).++   This is very like the situation described in Note [RHS of lets]+   in GHC.Core.Opt.Simplify.Inline; (case e of b -> blah) is just+   like a strict `let`.++Conclusion: in interestingCallCtxt, a case-expression (i.e. Select continuation)+usually gives a CaseCtxt (cases 1,2); but when (cases 3,4):+  * It has a non-dead case-binder+  * It has one alternative   * All the binders in the alternative are dead-then the `case` is just a strict let-binding, and the scrutinee is-BoringCtxt (don't inline).  Otherwise CaseCtxt.+then the `case` is just a strict let-binding, so use RhsCtxt NonRecursive.+This RhsCtxt gives a small incentive for small functions to inline.+That incentive is what is needed in case (4).++Wrinkle (SB1).  The 'small incentive' is implemented by `calc_some_benefit` in+GHC.Core.Opt.Simplify.Inline.tryUnfolding.  We restrict the incentive just to+funtions that have unfolding guidance of `UnfWhen`, which particularly includes+wrappers created by CPR, exactly case (4) above.  Without this limitation I+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.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+issue of confluence-of-the-simplifier.  Suppose we have+    f x = case x of r -> ...+and the Simplifier sees+    f (integerSigNum a b)+Because `f` scrutines `x`, the unfolding guidance for f gives a discount+for `x`; and that discount makes interestingCallContext for the context+`f <>` return DiscArgCtxt, which again gives that incentive.  We don't want+the incentive to disappear when we inline `f`! -}  lazyArgContext :: ArgInfo -> CallCtxt@@ -865,7 +899,7 @@       | not (seCaseCase env)         = BoringCtxt -- See Note [No case of case is boring]       | [Alt _ bs _] <- alts       , all isDeadBinder bs-      , not (isDeadBinder case_bndr) = BoringCtxt -- See Note [Seq is boring]+      , not (isDeadBinder case_bndr) = RhsCtxt NonRecursive -- See Note [Seq is boring]       | otherwise                    = CaseCtxt  @@ -880,7 +914,7 @@     interesting (Stop _ cci _)               = cci     interesting (TickIt _ k)                 = interesting k     interesting (ApplyToTy { sc_cont = k })  = interesting k-    interesting (CastIt _ k)                 = interesting k+    interesting (CastIt { sc_cont = k })     = interesting k         -- If this call is the arg of a strict function, the context         -- is a bit interesting.  If we inline here, we may get useful         -- evaluation information to avoid repeated evals: e.g.@@ -920,7 +954,7 @@   where     go (ApplyToVal { sc_cont = cont }) = go cont     go (ApplyToTy  { sc_cont = cont }) = go cont-    go (CastIt _ cont)                 = go cont+    go (CastIt { sc_cont = cont })     = go cont     go (StrictArg { sc_fun = fun })    = ai_encl fun     go (Stop _ RuleArgCtxt _)          = True     go (TickIt _ c)                    = go c@@ -991,17 +1025,41 @@                                  env' = env `addNewInScopeIds` bindersOf b      go_var n v-       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that-                                        --    data constructors here-       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding-       | n > 0             = NonTrivArg -- Saturated or unknown call-       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding-                                        -- See Note [Conlike is interesting]-       | otherwise         = TrivArg    -- n==0, no useful unfolding-       where-         conlike_unfolding = isConLikeUnfolding (idUnfolding v)+       | isConLikeId v = ValueArg   -- Experimenting with 'conlike' rather that+                                    --    data constructors here+                                    -- DFuns are con-like; see Note [Conlike is interesting]+       | idArity v > n = ValueArg   -- Catches (eg) primops with arity but no unfolding+       | n > 0         = NonTrivArg -- Saturated or unknown call+       | otherwise  -- n==0, no value arguments; look for an interesting unfolding+       = case idUnfolding v of+           OtherCon [] -> NonTrivArg   -- It's evaluated, but that's all we know+           OtherCon _  -> ValueArg     -- Evaluated and we know it isn't these constructors+              -- See Note [OtherCon and interestingArg]+           DFunUnfolding {} -> ValueArg   -- We konw that idArity=0+           CoreUnfolding{ uf_cache = cache }+             | uf_is_conlike cache -> ValueArg    -- Includes constructor applications+             | uf_is_value cache   -> NonTrivArg  -- Things like partial applications+             | otherwise           -> TrivArg+           BootUnfolding           -> TrivArg+           NoUnfolding             -> TrivArg -{-+{- Note [OtherCon and interestingArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+interstingArg returns+   (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.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.++Reason for (b): we want to inline integerCompare here+  integerLt# :: Integer -> Integer -> Bool#+  integerLt# (IS x) (IS y)                  = x <# y+  integerLt# x y | LT <- integerCompare x y = 1#+  integerLt# _ _                            = 0#+ ************************************************************************ *                                                                      *                   SimplMode@@ -1222,19 +1280,6 @@ continuation. -} -activeUnfolding :: SimplMode -> Id -> Bool-activeUnfolding mode id-  | isCompulsoryUnfolding (realIdUnfolding id)-  = True   -- Even sm_inline can't override compulsory unfoldings-  | otherwise-  = isActive (sm_phase mode) (idInlineActivation id)-  && sm_inline mode-      -- `or` isStableUnfolding (realIdUnfolding id)-      -- Inline things when-      --  (a) they are active-      --  (b) sm_inline says so, except that for stable unfoldings-      --                         (ie pragmas) we inline anyway- getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv -- When matching in RULE, we want to "look through" an unfolding -- (to see a constructor) if *rules* are on, even if *inlinings*@@ -1451,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.@@ -1470,6 +1519,18 @@     -- simplifications).  Until phase zero we take no special notice of     -- top level things, but then we become more leery about inlining     -- them.+    --+    -- What exactly to check in `early_phase` above is the subject of #17910.+    --+    -- !10088 introduced an additional Simplifier iteration in LargeRecord+    -- because we first FloatOut `case unsafeEqualityProof of ... -> I# 2#`+    -- (a non-trivial value) which we immediately inline back in.+    -- Ideally, we'd never have inlined it because the binding turns out to+    -- be expandable; unfortunately we need an iteration of the Simplifier to+    -- attach the proper unfolding and can't check isExpandableUnfolding right+    -- here.+    -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look+    -- at the non-existent unfolding for the `I# 2#` which is also floated out.)  {- ************************************************************************@@ -1513,15 +1574,14 @@  postInlineUnconditionally     :: SimplEnv -> BindContext-    -> OutId            -- The binder (*not* a CoVar), including its unfolding-    -> OccInfo          -- From the InId+    -> InId -> OutId    -- The binder (*not* a CoVar), including its unfolding     -> OutExpr     -> Bool -- Precondition: rhs satisfies the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, --         for unlifted, side-effect-ful bindings-postInlineUnconditionally env bind_cxt bndr occ_info rhs+postInlineUnconditionally env bind_cxt old_bndr bndr rhs   | not active                  = False   | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline                                         -- because it might be referred to "earlier"@@ -1529,40 +1589,33 @@   | isTopLevel (bindContextLevel bind_cxt)                                 = False -- Note [Top level and postInlineUnconditionally]   | exprIsTrivial rhs           = True-  | BC_Join {} <- bind_cxt              -- See point (1) of Note [Duplicating join points]-  , not (phase == FinalPhase)   = False -- in Simplify.hs+  | BC_Join {} <- bind_cxt      = False -- See point (1) of Note [Duplicating join points]+                                        --     in GHC.Core.Opt.Simplify.Iteration   | otherwise   = case occ_info of       OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }         -- See Note [Inline small things to avoid creating a thunk] -        -> n_br < 100  -- See Note [Suppress exponential blowup]+        | n_br >= 100 -> False  -- See #23627 -           && smallEnoughToInline uf_opts unfolding     -- Small enough to dup-                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true-                        ---                        -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1-                        -- Reason: doing so risks exponential behaviour.  We simplify a big-                        --         expression, inline it, and simplify it again.  But if the-                        --         very same thing happens in the big expression, we get-                        --         exponential cost!-                        -- PRINCIPLE: when we've already simplified an expression once,-                        -- make sure that we only inline it if it's reasonably small.+        | n_br == 1, NotInsideLam <- in_lam  -- One syntactic occurrence+        -> True                              -- See Note [Post-inline for single-use things] -           && (in_lam == NotInsideLam ||-                        -- Outside a lambda, we want to be reasonably aggressive-                        -- about inlining into multiple branches of case-                        -- e.g. let x = <non-value>-                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }-                        -- Inlining can be a big win if C3 is the hot-spot, even if-                        -- the uses in C1, C2 are not 'interesting'-                        -- An example that gets worse if you add int_cxt here is 'clausify'+--        | is_unlifted                        -- Unlifted binding, hence ok-for-spec+--        -> True                              -- hence cheap to inline probably just a primop+--                                             -- Not a big deal either way+-- No, this is wrong.  {v = p +# q; x = K v}.+-- Don't inline v; it'll just get floated out again. Stupid. -                (isCheapUnfolding unfolding && int_cxt == IsInteresting))-                        -- isCheap => acceptable work duplication; in_lam may be true-                        -- int_cxt to prevent us inlining inside a lambda without some-                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally+        | is_demanded+        -> False                            -- No allocation (it'll be a case expression in the end)+                                            -- so inlining duplicates code but nothing more +        | otherwise+        -> work_ok in_lam int_cxt && smallEnoughToInline uf_opts unfolding+              -- Multiple syntactic occurences; but lazy, and small enough to dup+              -- ToDo: consider discount on smallEnoughToInline if int_cxt is true+       IAmDead -> True   -- This happens; for example, the case_bndr during case of                         -- known constructor:  case (a,b) of x { (p,q) -> ... }                         -- Here x isn't mentioned in the RHS, so we don't want to@@ -1570,23 +1623,29 @@        _ -> False --- Here's an example that we don't handle well:---      let f = if b then Left (\x.BIG) else Right (\y.BIG)---      in \y. ....case f of {...} ....--- Here f is used just once, and duplicating the case work is fine (exprIsCheap).--- But---  - We can't preInlineUnconditionally because that would invalidate---    the occ info for b.---  - We can't postInlineUnconditionally because the RHS is big, and---    that risks exponential behaviour---  - We can't call-site inline, because the rhs is big--- Alas!-   where-    unfolding = idUnfolding bndr-    uf_opts   = seUnfoldingOpts env-    phase     = sePhase env-    active    = isActive phase (idInlineActivation bndr)+    work_ok NotInsideLam _              = True+    work_ok IsInsideLam  IsInteresting  = isCheapUnfolding unfolding+    work_ok IsInsideLam  NotInteresting = False+      -- NotInsideLam: outside a lambda, we want to be reasonably aggressive+      -- about inlining into multiple branches of case+      -- e.g. let x = <non-value>+      --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }+      -- Inlining can be a big win if C3 is the hot-spot, even if+      -- the uses in C1, C2 are not 'interesting'+      -- An example that gets worse if you add int_cxt here is 'clausify'++      -- InsideLam: check for acceptable work duplication, using isCheapUnfoldign+      -- int_cxt to prevent us inlining inside a lambda without some+      -- good reason.  See the notes on int_cxt in preInlineUnconditionally++--    is_unlifted = isUnliftedType (idType bndr)+    is_demanded = isStrUsedDmd (idDemandInfo bndr)+    occ_info    = idOccInfo old_bndr+    unfolding   = idUnfolding bndr+    uf_opts     = seUnfoldingOpts env+    phase       = sePhase env+    active      = isActive phase (idInlineActivation bndr)         -- See Note [pre/postInlineUnconditionally in gentle mode]  {- Note [Inline small things to avoid creating a thunk]@@ -1607,38 +1666,52 @@ to allocate more.  An egregious example is test perf/compiler/T14697, where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more. -Note [Suppress exponential blowup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #13253, and several related tickets, we got an exponential blowup-in code size from postInlineUnconditionally.  The trouble comes when-we have-  let j1a = case f y     of { True -> p;   False -> q }-      j1b = case f y     of { True -> q;   False -> p }-      j2a = case f (y+1) of { True -> j1a; False -> j1b }-      j2b = case f (y+1) of { True -> j1b; False -> j1a }-      ...-  in case f (y+10) of { True -> j10a; False -> j10b }+Note [Post-inline for single-use things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have -when there are many branches. In pass 1, postInlineUnconditionally-inlines j10a and j10b (they are both small).  Now we have two calls-to j9a and two to j9b.  In pass 2, postInlineUnconditionally inlines-all four of these calls, leaving four calls to j8a and j8b. Etc.-Yikes!  This is exponential!+   let x = rhs in ...x... -A possible plan: stop doing postInlineUnconditionally-for some fixed, smallish number of branches, say 4. But that turned-out to be bad: see Note [Inline small things to avoid creating a thunk].-And, as it happened, the problem with #13253 was solved in a-different way (Note [Duplicating StrictArg] in Simplify).+and `x` is used exactly once, and not inside a lambda, then we will usually+preInlineUnconditinally. But we can still get this situation in+postInlineUnconditionally: -So I just set an arbitrary, high limit of 100, to stop any-totally exponential behaviour.+  case K rhs of K x -> ...x.... -This still leaves the nasty possibility that /ordinary/ inlining (not-postInlineUnconditionally) might inline these join points, each of-which is individually quiet small.  I'm still not sure what to do-about this (e.g. see #15488).+Here we'll use `simplAuxBind` to bind `x` to (the already-simplified) `rhs`;+and `x` is used exactly once.  It's beneficial to inline right away; otherwise+we risk creating +   let x = rhs in ...x...++which will take another iteration of the Simplifier to eliminate.  We do this in+two places++1. In the full `postInlineUnconditionally` look for the special case+   of "one occurrence, not under a lambda", and inline unconditionally then.++   This is a bit risky: see Note [Avoiding simplifying repeatedly] in+   Simplify.Iteration.  But in practice it seems to be a small win.++2. `simplAuxBind` does a kind of poor-man's `postInlineUnconditionally`.  It+   does not need to account for many of the cases (e.g. top level) that the+   full `postInlineUnconditionally` does.  Moreover, we don't have an+   OutId, which `postInlineUnconditionally` needs.  I got a slight improvement+   in compiler performance when I added this test.++Here's an example that we don't currently handle well:+     let f = if b then Left (\x.BIG) else Right (\y.BIG)+     in \y. ....case f of {...} ....+Here f is used just once, and duplicating the case work is fine (exprIsCheap).+But+ - We can't preInlineUnconditionally because that would invalidate+   the occ info for b.+ - We can't postInlineUnconditionally because the RHS is big, and+   that risks exponential behaviour+ - We can't call-site inline, because the rhs is big+Alas!++ Note [Top level and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't do postInlineUnconditionally for top-level things (even for@@ -1858,11 +1931,12 @@                 -> SimplM (ArityType, OutExpr) -- See Note [Eta-expanding at let bindings] tryEtaExpandRhs env bind_cxt bndr rhs-  | do_eta_expand           -- If the current manifest arity isn't enough-                            --    (never true for join points)-  , seEtaExpand env         -- and eta-expansion is on-  , wantEtaExpansion rhs-  = -- Do eta-expansion.+  | seEtaExpand env         -- If Eta-expansion is on+  , wantEtaExpansion rhs    -- and we'd like to eta-expand e+  , do_eta_expand           -- and e's manifest arity is lower than+                            --     what it could be+                            --     (never true for join points)+  =                         -- Do eta-expansion.     assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $        -- assert: this never happens for join points; see GHC.Core.Opt.Arity        --         Note [Do not eta-expand join points]@@ -2093,6 +2167,27 @@       which showed that it's harder to do polymorphic specialisation well       if there are dictionaries abstracted over unnecessary type variables.       See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise++(AB5) We do dependency analysis on recursive groups prior to determining+      which variables to abstract over.+      This is useful, because ANFisation in prepareBinding may float out+      values out of a complex recursive binding, e.g.,+          letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...+        ==> { prepareBinding }+          letrec { foo = "blah"#+                   bar = [42]+                   xs = g @a foo bar xs } in+          ...+      and we don't want to abstract foo and bar over @a.++      (Why is it OK to float the unlifted `foo` there?+      See Note [Core top-level string literals] in GHC.Core;+      it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)++      It is also necessary to do dependency analysis, because+      otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the+      top-level, and that triggers a CoreLint error because `foo` is *not*+      manifestly a literal string. -}  abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats@@ -2100,15 +2195,27 @@ abstractFloats uf_opts top_lvl main_tvs floats body   = assert (notNull body_floats) $     assert (isNilOL (sfJoinFloats floats)) $-    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats+    do  { let sccs = concatMap to_sccs body_floats+        ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs         ; return (float_binds, GHC.Core.Subst.substExpr subst body) }   where     is_top_lvl  = isTopLevel top_lvl     body_floats = letFloatBinds (sfLetFloats floats)     empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) -    abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)-    abstract subst (NonRec id rhs)+    -- See wrinkle (AB5) in Note [Which type variables to abstract over]+    -- for why we need to re-do dependency analysis+    to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]+    to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it+    to_sccs (Rec prs)     = sccs+      where+        (ids,rhss) = unzip prs+        sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])+                       (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)+                       (zip3 ids rhss (map exprFreeVars rhss))++    abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)+    abstract subst (AcyclicSCC (id, rhs, _empty_var_set))       = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id            ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'                  !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app@@ -2119,7 +2226,7 @@         -- tvs_here: see Note [Which type variables to abstract over]         tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') -    abstract subst (Rec prs)+    abstract subst (CyclicSCC trpls)       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids            ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'@@ -2127,20 +2234,23 @@                               , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]            ; return (subst', Rec poly_pairs) }       where-        (ids,rhss) = unzip prs-+        (ids,rhss,_fvss) = unzip3 trpls          -- tvs_here: see Note [Which type variables to abstract over]-        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)+        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)          -- See wrinkle (AB4) in Note [Which type variables to abstract over]-        get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs-        get_rec_rhs_tvs rhs   = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)+        get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs+        get_rec_rhs_tvs rhs_fvs        = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs+                                  -- nonDet is safe because of wrinkle (AB3)          get_tvs :: Var -> VarSet -> VarSet         get_tvs var free_tvs            | isTyVar var      -- CoVars have been substituted away            = extendVarSet free_tvs var+           | isCoVar var  -- CoVars can be free in the RHS, but they are never let-bound;+           = free_tvs     -- Do not call lookupIdSubst_maybe, though (#23426)+                          --    because it has a non-CoVar precondition            | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var            = -- 'var' is like 'x' in (AB4)              exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs@@ -2178,7 +2288,7 @@       = (poly_id `setIdUnfolding` unf, poly_rhs)       where         poly_rhs = mkLams tvs_here rhs-        unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs Nothing+        unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False False poly_rhs Nothing          -- We want the unfolding.  Consider         --      let@@ -2274,7 +2384,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an /OutId/.  This is vital, because `refineDefaultAlt` uses `tys` to build-a new /InAlt/.  If you pass an OutId, we'll end up appling the+a new /InAlt/.  If you pass an OutId, we'll end up applying the substitution twice: disaster (#23012).  However this does mean that filling in the default alt might be@@ -2309,7 +2419,25 @@                     Var v -> otherCons (idUnfolding v)                     _     -> [] +{- Note [Merging nested cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic case-merge stuff is described in Note [Merge Nested Cases] in GHC.Core.Utils +We do it here in `prepareAlts` (on InAlts) rather than after (on OutAlts) for two reasons:++* It "belongs" here with `filterAlts`, `refineDefaultAlt` and `combineIdenticalAlts`.++* In test perf/compiler/T22428 I found that I was getting extra Simplifer iterations:+    1. Create a join point+    2. That join point gets inlined at all call sites, so it is now dead.+    3. Case-merge happened, but left behind some trivial bindings (see `mergeCaseAlts`)+    4. Get rid of the trivial bindings+  The first two seem reasonable.  It's imaginable that we could do better on+  (3), by making case-merge join-point-aware, but it's not trivial.  But the+  fourth is just stupid.  Rather than always do an extra iteration, it's better+  to do the transformation on the input-end of teh Simplifier.+-}+ {- ************************************************************************ *                                                                      *@@ -2319,28 +2447,9 @@  mkCase tries these things -* Note [Merge Nested Cases] * Note [Eliminate Identity Case] * Note [Scrutinee Constant Folding] -Note [Merge Nested Cases]-~~~~~~~~~~~~~~~~~~~~~~~~~-       case e of b {             ==>   case e of b {-         p1 -> rhs1                      p1 -> rhs1-         ...                             ...-         pm -> rhsm                      pm -> rhsm-         _  -> case b of b' {            pn -> let b'=b in rhsn-                     pn -> rhsn          ...-                     ...                 po -> let b'=b in rhso-                     po -> rhso          _  -> let b'=b in rhsd-                     _  -> rhsd-       }--which merges two cases in one case when -- the default alternative of-the outer case scrutinises the same variable as the outer case. This-transformation is called Case Merging.  It avoids that the same-variable is scrutinised multiple times.- Note [Eliminate Identity Case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~         case e of               ===> e@@ -2432,7 +2541,6 @@   see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold  - Note [Example of case-merging and caseRules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The case-transformation rules are quite powerful. Here's a@@ -2448,9 +2556,9 @@  In Core after a bit of simplification we get: -    f x = case dataToTag# x of a# { _DEFAULT ->+    f x = case dataToTagLarge# x of a# { _DEFAULT ->           case a# of-            _DEFAULT -> case dataToTag# x of b# { _DEFAULT ->+            _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT ->                         case b# of                            _DEFAULT -> ...                            1# -> "two"@@ -2462,8 +2570,8 @@ The case-merge transformation Note [Merge Nested Cases] does this (affecting both pairs of cases): -    f x = case dataToTag# x of a# {-             _DEFAULT -> case dataToTag# x of b# {+    f x = case dataToTagLarge# x of a# {+             _DEFAULT -> case dataToTagLarge# x of b# {                           _DEFAULT -> ...                           1# -> "two"                          }@@ -2471,22 +2579,22 @@           }  Now Note [caseRules for dataToTag] does its work, again-on both dataToTag# cases:+on both dataToTagLarge# cases:      f x = case x of x1 {-             _DEFAULT -> case dataToTag# x1 of a# { _DEFAULT ->+             _DEFAULT -> case dataToTagLarge# x1 of a# { _DEFAULT ->                          case x of x2 {-                           _DEFAULT -> case dataToTag# x2 of b# { _DEFAULT -> ... }+                           _DEFAULT -> case dataToTagLarge# x2 of b# { _DEFAULT -> ... }                            B -> "two"                          }}              A -> "one"           }  -The new dataToTag# calls come from the "reconstruct scrutinee" part of+The new dataToTagLarge# calls come from the "reconstruct scrutinee" part of caseRules (note that a# and b# were not dead in the original program before all this merging).  However, since a# and b# /are/ in fact dead-in the resulting program, we are left with redundant dataToTag# calls.+in the resulting program, we are left with redundant dataToTagLarge# calls. But they are easily eliminated by doing caseRules again, in the next Simplifier iteration, this time noticing that a# and b# are dead.  Hence the "dead-binder" sub-case of Wrinkle 1 of Note@@ -2518,48 +2626,28 @@  -------------------------------------------------- --      1. Merge Nested Cases+--         See Note [Merge Nested Cases]+--             Note [Example of case-merging and caseRules]+--             Note [Cascading case merge] -------------------------------------------------- -mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)+mkCase mode scrut outer_bndr alts_ty alts   | sm_case_merge mode-  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)-       <- stripTicksTop tickishFloatable deflt_rhs-  , inner_scrut_var == outer_bndr+  , Just (joins, alts') <- mergeCaseAlts outer_bndr alts   = do  { tick (CaseMerge outer_bndr)--        ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)-                                            (Alt con args (wrap_rhs rhs))-                -- Simplifier's no-shadowing invariant should ensure-                -- that outer_bndr is not shadowed by the inner patterns-              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs-                -- The let is OK even for unboxed binders,--              wrapped_alts | isDeadBinder inner_bndr = inner_alts-                           | otherwise               = map wrap_alt inner_alts--              merged_alts = mergeAlts outer_alts wrapped_alts-                -- NB: mergeAlts gives priority to the left-                --      case x of-                --        A -> e1-                --        DEFAULT -> case x of-                --                      A -> e2-                --                      B -> e3-                -- When we merge, we must ensure that e1 takes-                -- precedence over e2 as the value for A!--        ; fmap (mkTicks ticks) $-          mkCase1 mode scrut outer_bndr alts_ty merged_alts-        }-        -- Warning: don't call mkCase recursively!+        ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts'+        ; return (mkLets joins case_expr) }+        -- mkCase1: don't call mkCase recursively!         -- Firstly, there's no point, because inner alts have already had         -- mkCase applied to them, so they won't have a case in their default         -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr         -- in munge_rhs may put a case into the DEFAULT branch!--mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts+  | otherwise+  = mkCase1 mode scrut outer_bndr alts_ty alts  -------------------------------------------------- --      2. Eliminate Identity Case+--         See Note [Eliminate Identity Case] --------------------------------------------------  mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts')      -- Identity case@@ -2603,8 +2691,10 @@  mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts + -------------------------------------------------- --      2. Scrutinee Constant Folding+--         See Note [Scrutinee Constant Folding] --------------------------------------------------  mkCase2 mode scrut bndr alts_ty alts@@ -2714,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]@@ -2723,64 +2814,4 @@ Note that dead-ness is maintained by the simplifier, so that it is accurate after simplification as well as before. --Note [Cascading case merge]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Case merging should cascade in one sweep, because it-happens bottom-up--      case e of a {-        DEFAULT -> case a of b-                      DEFAULT -> case b of c {-                                     DEFAULT -> e-                                     A -> ea-                      B -> eb-        C -> ec-==>-      case e of a {-        DEFAULT -> case a of b-                      DEFAULT -> let c = b in e-                      A -> let c = b in ea-                      B -> eb-        C -> ec-==>-      case e of a {-        DEFAULT -> let b = a in let c = b in e-        A -> let b = a in let c = b in ea-        B -> let b = a in eb-        C -> ec---However here's a tricky case that we still don't catch, and I don't-see how to catch it in one pass:--  case x of c1 { I# a1 ->-  case a1 of c2 ->-    0 -> ...-    DEFAULT -> case x of c3 { I# a2 ->-               case a2 of ...--After occurrence analysis (and its binder-swap) we get this--  case x of c1 { I# a1 ->-  let x = c1 in         -- Binder-swap addition-  case a1 of c2 ->-    0 -> ...-    DEFAULT -> case x of c3 { I# a2 ->-               case a2 of ...--When we simplify the inner case x, we'll see that-x=c1=I# a1.  So we'll bind a2 to a1, and get--  case x of c1 { I# a1 ->-  case a1 of c2 ->-    0 -> ...-    DEFAULT -> case a1 of ...--This is correct, but we can't do a case merge in this sweep-because c2 /= a1.  Reason: the binding c1=I# a1 went inwards-without getting changed to c1=I# c2.--I don't think this is worth fixing, even if I knew how. It'll-all come out in the next pass anyway. -}
compiler/GHC/Core/Opt/Stats.hs view
@@ -179,6 +179,13 @@   transformations for the same reason as PreInlineUnconditionally,   so it's probably not innocuous anyway. +  One annoying variant is this.  CaseMerge introduces auxiliary bindings+     let b = b' in ...+  This takes another full run of the simplifier to elimiante.  But if+  the PostInlineUnconditionally, replacing b with b', is the only thing+  that happens in a Simplifier run, that probably really is innocuous.+  Perhaps an opportunity here.+ KnownBranch, BetaReduction:   May drop chunks of code, and thereby enable PreInlineUnconditionally   for some let-binding which now occurs once
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
@@ -44,7 +44,6 @@ import GHC.Core.TyCo.Ppr import GHC.Core.Coercion import GHC.Types.Basic-import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.SrcLoc ( pprUserRealSpan )@@ -140,8 +139,8 @@     pp_val_bdr = pprPrefixOcc val_bdr      pp_bind = case bndrIsJoin_maybe val_bdr of-                Nothing -> pp_normal_bind-                Just ar -> pp_join_bind ar+                NotJoinPoint -> pp_normal_bind+                JoinPoint ar -> pp_join_bind ar      pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr) @@ -159,9 +158,9 @@                   -- So refer to printing  j = e       = pp_normal_bind       where-        (bndrs, body) = collectBinders expr-        lhs_bndrs = take join_arity bndrs-        rhs       = mkLams (drop join_arity bndrs) body+        (bndrs, body)     = collectBinders expr+        (lhs_bndrs, rest) = splitAt join_arity bndrs+        rhs               = mkLams rest body  pprParendExpr expr = ppr_expr parens expr pprCoreExpr   expr = ppr_expr noParens expr@@ -240,7 +239,13 @@         _ -> parens (hang (pprParendExpr fun) 2 pp_args)     } -ppr_expr add_par (Case expr var ty [Alt con args rhs])+ppr_expr add_par (Case expr _ ty []) -- Empty Case+  = add_par $ sep [text "case"+                      <+> pprCoreExpr expr+                      <+> whenPprDebug (text "return" <+> ppr ty),+                    text "of {}"]++ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case   = sdocOption sdocPrintCaseAsLet $ \case       True -> add_par $  -- See Note [Print case as let]                sep [ sep [ text "let! {"@@ -264,7 +269,7 @@   where     ppr_bndr = pprBndr CaseBind -ppr_expr add_par (Case expr var ty alts)+ppr_expr add_par (Case expr var ty alts) -- Multi alt Case   = add_par $     sep [sep [text "case"                 <+> pprCoreExpr expr@@ -306,12 +311,12 @@          pprCoreExpr expr]   where     keyword (NonRec b _)-     | isJust (bndrIsJoin_maybe b) = text "join"-     | otherwise                   = text "let"+     | isJoinPoint (bndrIsJoin_maybe b) = text "join"+     | otherwise                        = text "let"     keyword (Rec pairs)      | ((b,_):_) <- pairs-     , isJust (bndrIsJoin_maybe b) = text "joinrec"-     | otherwise                   = text "letrec"+     , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"+     | otherwise                        = text "letrec"  ppr_expr add_par (Tick tickish expr)   = sdocOption sdocSuppressTicks $ \case@@ -382,13 +387,13 @@   pprBndr = pprCoreBinder   pprInfixOcc  = pprInfixName  . varName   pprPrefixOcc = pprPrefixName . varName-  bndrIsJoin_maybe = isJoinId_maybe+  bndrIsJoin_maybe = idJoinPointHood  instance Outputable b => OutputableBndr (TaggedBndr b) where   pprBndr _    b = ppr b   -- Simple   pprInfixOcc  b = ppr b   pprPrefixOcc b = ppr b-  bndrIsJoin_maybe (TB b _) = isJoinId_maybe b+  bndrIsJoin_maybe (TB b _) = idJoinPointHood b  pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc pprOcc Infix  = pprInfixOcc@@ -689,9 +694,10 @@             ppr modl, comma,             ppr ix,             text ">"]-  ppr (Breakpoint _ext ix vars) =+  ppr (Breakpoint _ext bid vars) =       hcat [text "break<",-            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,51 +8,117 @@  module GHC.Core.Predicate (   Pred(..), classifyPredType,-  isPredTy, isEvVarType,+  isPredTy, isSimplePredTy,    -- Equality predicates   EqRel(..), eqRelRole,-  isEqPrimPred, isEqPred,+  isEqPred, isReprEqPred, isEqClassPred, isCoVarType,   getEqPredTys, getEqPredTys_maybe, getEqPredRole,-  predTypeEqRel,-  mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-  mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,+  predTypeEqRel, pprPredType,+  mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole,    -- Class predicates   mkClassPred, isDictTy, typeDeterminesValue,-  isClassPred, isEqPredClass, isCTupleClass,+  isClassPred, isEqualityClass, isCTupleClass, isUnaryClass,   getClassPredTys, getClassPredTys_maybe,   classMethodTy, classMethodInstTy,    -- Implicit parameters-  isIPLikePred, hasIPSuperClasses, 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 -import Control.Monad ( guard ) +{- *********************************************************************+*                                                                      *+*                   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@@ -60,7 +126,7 @@   -- | A typeclass predicate.   = ClassPred Class [Type] -  -- | A type equality predicate.+  -- | A type equality predicate, (t1 ~#N t2) or (t1 ~#R t2)   | EqPred EqRel Type Type    -- | An irreducible predicate.@@ -68,51 +134,144 @@    -- | A quantified predicate.   ---  -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+  -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve   | ForAllPred [TyVar] [PredType] PredType    -- NB: There is no TuplePred case   --     Tuple predicates like (Eq a, Ord b) are just treated   --     as ClassPred, as if we had a tuple class with two superclasses-  --        class (c1, c2) => (%,%) c1 c2+  --        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)@@ -154,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 ---------------------------------@@ -171,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@@ -189,66 +383,26 @@       _ -> Nothing  getEqPredRole :: PredType -> Role+-- Precondition: the PredType is (s ~#N t) or (s ~#R t) getEqPredRole ty = eqRelRole (predTypeEqRel ty) --- | Get the equality relation relevant for a pred type.+-- | Get the equality relation relevant for a pred type+-- Returns NomEq for dictionary predicates, etc predTypeEqRel :: PredType -> EqRel predTypeEqRel ty-  | Just (tc, _) <- splitTyConApp_maybe ty-  , tc `hasKey` eqReprPrimTyConKey-  = ReprEq-  | otherwise-  = NomEq--{--------------------------------------------Predicates on PredType---------------------------------------------}--{--Note [Evidence for quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The superclass mechanism in GHC.Tc.Solver.Canonical.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.Canonical.--}--isEvVarType :: Type -> Bool--- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)---         (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)--- 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--isEqPredClass :: Class -> Bool--- True of (~) and (~~)-isEqPredClass cls =  cls `hasKey` eqTyConKey-                  || cls `hasKey` heqTyConKey--isClassPred, isEqPred, isEqPrimPred :: PredType -> Bool-isClassPred ty = case tyConAppTyCon_maybe ty of-    Just tyCon | isClassTyCon tyCon -> True-    _                               -> False--isEqPred ty  -- True of (a ~ b) and (a ~~ b)-             -- ToDo: should we check saturation?-  | Just tc <- tyConAppTyCon_maybe ty-  , Just cls <- tyConClass_maybe tc-  = isEqPredClass cls-  | otherwise-  = False--isEqPrimPred ty = isCoVarType ty-  -- True of (a ~# b) (a ~R# b)+  | 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  {- ********************************************************************* *                                                                      *@@ -256,6 +410,8 @@ *                                                                      * ********************************************************************* -} +-- --------------------- Nomal implicit-parameter predicates ---------------+ isIPTyCon :: TyCon -> Bool isIPTyCon tc = tc `hasKey` ipClassKey   -- Class and its corresponding TyCon have the same Unique@@ -263,39 +419,49 @@ isIPClass :: Class -> Bool isIPClass cls = cls `hasKey` ipClassKey -isIPLikePred :: Type -> Bool--- See Note [Local implicit parameters]-isIPLikePred = is_ip_like_pred initIPRecTc+-- | Decomposes a predicate if it is an implicit parameter. Does not look in+-- superclasses. See also [Local implicit parameters].+isIPPred_maybe :: Class -> [Type] -> Maybe (Type, Type)+isIPPred_maybe cls tys+  | isIPClass cls+  , [t1,t2] <- tys+  = Just (t1,t2)+  | 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) -is_ip_like_pred :: RecTcChecker -> Type -> Bool-is_ip_like_pred rec_clss ty-  | Just (tc, tys) <- splitTyConApp_maybe ty-  , Just rec_clss' <- if isTupleTyCon tc  -- Tuples never cause recursion-                      then Just rec_clss-                      else checkRecTc rec_clss tc-  , Just cls       <- tyConClass_maybe tc-  = isIPClass cls || has_ip_super_classes rec_clss' cls tys+-- --------------------- ExceptionContext predicates -------------------------- +-- | Is a 'PredType' an @ExceptionContext@ implicit parameter?+--+-- If so, return the name of the parameter.+isExceptionContextPred :: Class -> [Type] -> Maybe FastString+isExceptionContextPred cls tys+  | [ty1, ty2] <- tys+  , isIPClass cls+  , isExceptionContextTy ty2+  = isStrLitTy ty1   | otherwise-  = False -- Includes things like (D []) where D is-          -- a Constraint-ranged family; #7785--hasIPSuperClasses :: Class -> [Type] -> Bool--- See Note [Local implicit parameters]-hasIPSuperClasses = has_ip_super_classes initIPRecTc--has_ip_super_classes :: RecTcChecker -> Class -> [Type] -> Bool-has_ip_super_classes rec_clss cls tys-  = any ip_ish (classSCSelIds cls)-  where-    -- Check that the type of a superclass determines its value-    -- sc_sel_id :: forall a b. C a b -> <superclass type>-    ip_ish sc_sel_id = is_ip_like_pred rec_clss $-                       classMethodInstTy sc_sel_id tys+  = Nothing -initIPRecTc :: RecTcChecker-initIPRecTc = setRecTcMaxBound 1 initRecTc+-- | Is a type an 'ExceptionContext'?+isExceptionContextTy :: Type -> Bool+isExceptionContextTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` exceptionContextTyConKey+  | otherwise+  = False  -- --------------------- CallStack predicates --------------------------------- @@ -329,19 +495,57 @@   | otherwise   = False +-- --------------------- couldBeIPLike and mightMentionIP  --------------------------+--                 See Note [Local implicit parameters] --- | Decomposes a predicate if it is an implicit parameter. Does not look in--- superclasses. See also [Local implicit parameters].-isIPPred_maybe :: Type -> Maybe (FastString, Type)-isIPPred_maybe ty =-  do (tc,[t1,t2]) <- splitTyConApp_maybe ty-     guard (isIPTyCon tc)-     x <- isStrLitTy t1-     return (x,t2)+couldBeIPLike :: Type -> Bool+-- Is `pred`, or any of its superclasses, an implicit parameter?+-- See Note [Local implicit parameters]+couldBeIPLike pred+  = might_mention_ip1 initIPRecTc (const True) (const True) pred +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]+mightMentionIP = might_mention_ip initIPRecTc++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 [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)+       | sc_sel_id <- classSCSelIds cls ]+++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+  = 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++initIPRecTc :: RecTcChecker+initIPRecTc = setRecTcMaxBound 1 initRecTc+ {- Note [Local implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function isIPLikePred tells if this predicate, or any of its+See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in+GHC.Tc.Solver.Dict.++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@@ -349,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@@ -390,21 +594,219 @@   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.  -}+I'm going to treat these as problems for another day. They are all exotic. +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,+  (2) to check that a predicate does not contain any HasCallStack or+      HasExceptionContext constraints.++In both of these cases, we want to be sure, so we should be conservative:++  For (1), the predicate might contain an implicit parameter IP Str a, where+  Str is a type family such as:++    type family MyStr where MyStr = "abc"++  To safeguard against this (niche) situation, instead of doing a simple+  type equality check, we use 'typesAreApart'. This allows us to recognise+  that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'.++  For (2), we similarly might have++    type family MyCallStack where MyCallStack = CallStack++  Again, here we use 'typesAreApart'. This allows us to see that++    (?foo :: MyCallStack)++  is indeed a CallStack constraint, hidden under a type family.+-}+ {- ********************************************************************* *                                                                      *               Evidence variables *                                                                      * ********************************************************************* -} -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/Reduction.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}  module GHC.Core.Reduction   (@@ -361,8 +358,8 @@   (Reduction arg_co arg_ty)   (Reduction res_co res_ty)     = mkReduction-        (mkFunCo1 r af w_co arg_co res_co)-        (mkFunTy    af w_ty arg_ty res_ty)+        (mkFunCo r af w_co arg_co res_co)+        (mkFunTy   af w_ty arg_ty res_ty) {-# INLINE mkFunRedn #-}  -- | Create a 'Reduction' associated to a Π type,@@ -376,7 +373,7 @@              -> Reduction mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)   = mkReduction-      (mkForAllCo tv1 h co)+      (mkForAllCo tv1 vis vis h co)       (mkForAllTy (Bndr tv2 vis) ty)   where     tv2 = setTyVarKind tv1 ki'@@ -389,7 +386,7 @@ mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction mkHomoForAllRedn bndrs (Reduction co ty)   = mkReduction-      (mkHomoForAllCos (binderVars bndrs) co)+      (mkHomoForAllCos bndrs co)       (mkForAllTys bndrs ty) {-# INLINE mkHomoForAllRedn #-}
compiler/GHC/Core/RoughMap.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-}- -- | 'RoughMap' is an approximate finite map data structure keyed on -- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's -- (e.g. an instance head).
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,+        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 @@ -41,14 +42,14 @@ import GHC.Unit.Module.ModGuts( ModGuts(..) ) import GHC.Unit.Module.Deps( Dependencies(..) ) -import GHC.Driver.Session( DynFlags )+import GHC.Driver.DynFlags( DynFlags ) import GHC.Driver.Ppr( showSDoc )  import GHC.Core         -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe )-import GHC.Core.FVs       ( exprFreeVars, exprsFreeVars, bindFreeVars-                          , rulesFreeVarsDSet, exprsOrphNames )+import GHC.Core.FVs       ( exprFreeVars, bindFreeVars+                          , rulesFreeVarsDSet, orphNamesOfExprs ) import GHC.Core.Utils     ( exprType, mkTick, mkTicks                           , stripTicksTopT, stripTicksTopE                           , isJoinBind, mkCastMCo )@@ -62,7 +63,8 @@ import GHC.Core.Tidy     ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.Make     ( mkCoreLams )+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr )  import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types    ( anyTypeOfKind )@@ -83,7 +85,9 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag+import GHC.Data.List.SetOps( hasNoDups ) +import GHC.Utils.FV( filterFV, fvVarSet ) import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic@@ -204,7 +208,7 @@         -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv         -- A rule is an orphan only if none of the variables         -- mentioned on its left-hand side are locally defined-    lhs_names = extendNameSet (exprsOrphNames args) fn+    lhs_names = extendNameSet (orphNamesOfExprs args) fn          -- Since rules get eventually attached to one of the free names         -- from the definition when compiling the ABI hash, we should make@@ -218,9 +222,9 @@            -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- Make a specialisation rule, for Specialise or SpecConstr mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs-  = case isJoinId_maybe fn of-      Just join_arity -> etaExpandToJoinPointRule join_arity rule-      Nothing         -> rule+  = case idJoinPointHood fn of+      JoinPoint join_arity -> etaExpandToJoinPointRule join_arity rule+      NotJoinPoint         -> rule   where     rule = mkRule this_mod is_auto is_local                   rule_name@@ -441,23 +445,39 @@ getRules :: RuleEnv -> Id -> [CoreRule] -- Given a RuleEnv and an Id, find the visible rules for that Id -- See Note [Where rules are found]-getRules (RuleEnv { re_local_rules   = local_rules-                  , re_home_rules    = home_rules-                  , re_eps_rules     = eps_rules+--+-- This function is quite heavily used, so it's worth trying to make it efficient+getRules (RuleEnv { re_local_rules   = local_rule_base+                  , re_home_rules    = home_rule_base+                  , re_eps_rules     = eps_rule_base                   , re_visible_orphs = orphs }) fn    | Just {} <- isDataConId_maybe fn   -- Short cut for data constructor workers   = []                                -- and wrappers, which never have any rules -  | otherwise-  = idCoreRules fn          ++-    get local_rules         ++-    find_visible home_rules ++-    find_visible eps_rules+  | Just export_flag <- isLocalId_maybe fn+  = -- LocalIds can't have rules in the local_rule_base (used for imported fns)+    -- nor external packages; but there can (just) be rules in another module+    -- in the home package, if it is exported+    case export_flag of+      NotExported -> idCoreRules fn+      Exported -> case get home_rule_base of+          []           -> idCoreRules fn+          home_rules   -> drop_orphs home_rules ++ idCoreRules fn +  | otherwise+  = -- This case expression is a fast path, to avoid calling the+    -- recursive (++) in the common case where there are no rules at all+    case (get local_rule_base, get home_rule_base, get eps_rule_base) of+      ([], [], [])                         -> idCoreRules fn+      (local_rules, home_rules, eps_rules) -> local_rules           +++                                              drop_orphs home_rules +++                                              drop_orphs eps_rules  +++                                              idCoreRules fn   where     fn_name = idName fn-    find_visible rb = filter (ruleIsVisible orphs) (get rb)+    drop_orphs [] = []  -- Fast path; avoid invoking recursive filter+    drop_orphs xs = filter (ruleIsVisible orphs) xs     get rb = lookupNameEnv rb fn_name `orElse` []  ruleIsVisible :: ModuleSet -> CoreRule -> Bool@@ -465,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:@@ -519,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@@ -549,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] )@@ -563,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)))@@ -579,17 +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-                              , ru_name = rule_name2, ru_rhs = rhs2 })-  = isJust (matchN in_scope_env-                   rule_name2 bndrs2 args2 args1 rhs2)+-- 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@@ -598,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:@@ -643,7 +676,8 @@ -}  -------------------------------------matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)+matchRule :: HasDebugCallStack+          => RuleOpts -> InScopeEnv -> (Activation -> Bool)           -> Id -> [CoreExpr] -> [Maybe Name]           -> CoreRule -> Maybe CoreExpr @@ -688,7 +722,8 @@   ----------------------------------------matchN  :: InScopeEnv+matchN  :: HasDebugCallStack+        => InScopeEnv         -> RuleName -> [Var] -> [CoreExpr]         -> [CoreExpr] -> CoreExpr           -- ^ Target; can have more elements than the template         -> Maybe CoreExpr@@ -702,15 +737,24 @@ -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs+matchN ise _rule_name tmpl_vars tmpl_es target_es rhs+  = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es+       ; return (bind_wrapper $+                 mkLams tmpl_vars rhs `mkApps` matched_es) }++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         ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)                                           (mkEmptySubst in_scope) $                                 tmpl_vars `zip` tmpl_vars1-              bind_wrapper = rs_binds rule_subst++        ; let bind_wrapper = rs_binds rule_subst                              -- Floated bindings; see Note [Matching lets]-       ; return (bind_wrapper $-                 mkLams tmpl_vars rhs `mkApps` matched_es) }++        ; return (bind_wrapper, matched_es) }   where     (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars                   -- See Note [Cloning the template binders]@@ -721,7 +765,7 @@                    , rv_unf   = id_unf }      lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr)-                   -- Need to return a RuleSubst solely for the benefit of mk_fake_ty+                   -- Need to return a RuleSubst solely for the benefit of fake_ty     lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })                 tcv_subst (tmpl_var, tmpl_var1)         | isId tmpl_var1@@ -750,13 +794,13 @@     unbound tmpl_var        = pprPanic "Template variable unbound in rewrite rule" $          vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)-              , text "Rule" <+> pprRuleName rule_name               , text "Rule bndrs:" <+> ppr tmpl_vars               , text "LHS args:" <+> ppr tmpl_es               , text "Actual args:" <+> ppr target_es ]  -----------------------match_exprs :: RuleMatchEnv -> RuleSubst+match_exprs :: HasDebugCallStack+            => RuleMatchEnv -> RuleSubst             -> [CoreExpr]       -- Templates             -> [CoreExpr]       -- Targets             -> Maybe RuleSubst@@ -796,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 :: *).@@ -892,8 +936,13 @@ -- * The BindWrapper in a RuleSubst are the bindings floated out --   from nested matches; see the Let case of match, below ---data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the-                    , rs_id_subst :: IdSubstEnv   --   template variables+data RuleSubst = RS { -- Substitution; applied only to the template, not the target+                      -- Domain is the template variables+                      -- Range never includes template variables+                      rs_tv_subst :: TvSubstEnv+                    , rs_id_subst :: IdSubstEnv++                      -- Floated bindings                     , rs_binds    :: BindWrapper  -- Floated bindings                     , rs_bndrs    :: [Var]        -- Variables bound by floated lets                     }@@ -937,49 +986,83 @@ but the Simplifer pushes the casts in an application to to the right, if it can, so this doesn't really arise. -Note [Coercion arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~-What if we have (f co) in the template, where the 'co' is a coercion-argument to f?  Right now we have nothing in place to ensure that a-coercion /argument/ in the template is a variable.  We really should,-perhaps by abstracting over that variable.--C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.--For now, though, we simply behave badly, by failing in match_co.-We really should never rely on matching the structure of a coercion-(which is just a proof).- Note [Casts in the template] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the definition+This Note concerns `matchTemplateCast`.  Consider the definition   f x = e, and SpecConstr on call pattern   f ((e1,e2) |> co) -We'll make a RULE+The danger is that We'll make a RULE    RULE forall a,b,g.  f ((a,b)|> g) = $sf a b g    $sf a b g = e[ ((a,b)|> g) / x ] -So here is the invariant:+This requires the rule-matcher to bind the coercion variable `g`.+That is Very Deeply Suspicious: -  In the template, in a cast (e |> co),-  the cast `co` is always a /variable/.+* It would be unreasonable to match on a structured coercion in a pattern,+  such as    RULE   forall g.  f (x |> Sym g) = ...+  because the strucure of a coercion is arbitrary and may change -- it's their+  /type/ that matters. -Matching should bind that variable to an actual coercion, so that we-can use it in $sf.  So a Cast on the LHS (the template) calls-match_co, which succeeds when the template cast is a variable -- which-it always is.  That is why match_co has so few cases.+* We considered insisting that in a template, in a cast (e |> co), the the cast+  `co` is always a /variable/ cv.  That looks a bit more plausible, but #23209+  (and related tickets) shows that it's very fragile.  For example suppose `e`+  is a variable `f`, and the simplifier has an unconditional substitution+     [f :-> g |> co2]+  Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more! +In short, it is Very Deeply Suspicious for a rule to quantify over a coercion+variable.  And SpecConstr no longer does so: see Note [SpecConstr and casts] in+SpecConstr.++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++(CT2) Annoyingly, we still want support one case in which the RULE quantifies+  over a coercion variable: the dreaded map/coerce RULE.+  See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.++  Since that can happen, matchTemplateCast laboriously checks whether the+  coercion mentions a template coercion variable; and if so does the Very Deeply+  Suspicious `match_co` instead.  It works fine for map/coerce, where the+  coercion is always a variable and will (robustly) remain so.+ See also * Note [Coercion arguments] * Note [Matching coercion variables] in GHC.Core.Unify. * Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils:   sm_cast_swizzle is switched off in the template of a RULE++Note [Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~+What if we have (f (Coercion co)) in the template, where the 'co' is a coercion+argument to f?  Right now we have nothing in place to ensure that a+coercion /argument/ in the template is a variable.  We really should,+perhaps by abstracting over that variable.++C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.++For now, though, we simply behave badly, by failing in match_co.+We really should never rely on matching the structure of a coercion+(which is just a proof). -}  -----------------------match :: RuleMatchEnv+match :: HasDebugCallStack+      => RuleMatchEnv       -> RuleSubst              -- Substitution applies to template only       -> CoreExpr               -- Template       -> CoreExpr               -- Target@@ -1037,14 +1120,7 @@     -- This is important: see Note [Cancel reflexive casts]  match renv subst (Cast e1 co1) e2 mco-  = -- See Note [Casts in the template]-    do { let co2 = case mco of-                     MRefl   -> mkRepReflCo (exprType e2)-                     MCo co2 -> co2-       ; subst1 <- match_co renv subst co1 co2-         -- If match_co succeeds, then (exprType e1) = (exprType e2)-         -- Hence the MRefl in the next line-       ; match renv subst1 e1 e2 MRefl }+  = matchTemplateCast renv subst e1 co1 e2 mco  ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco@@ -1070,6 +1146,165 @@         -- because of the not-inRnEnvR  ------------------------ Applications ---------------------+-- See Note [Matching higher order patterns]+match renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env })+      subst  e1@App{} e2+      MRefl               -- Like the App case we insist on Refl here+                          -- See Note [Casts in the target]+  | (Var f, args) <- collectArgs e1+  , let f' = rnOccL rn_env f   -- See similar rnOccL in match_var+  , f' `elemVarSet` tmpls                     -- (HOP1)+  , Just vs2 <- traverse arg_as_lcl_var args  -- (HOP2), (HOP3)+  , hasNoDups vs2                             -- (HOP4)+  , not can_decompose_app_instead+  = match_tmpl_var renv subst f' (mkCoreLams vs2 e2)+    -- match_tmpl_var checks (HOP5) and (HOP6)+  where+    arg_as_lcl_var :: CoreExpr -> Maybe Var+    arg_as_lcl_var (Var v)+      | Just v' <- rnOccL_maybe rn_env v+      , not (v' `elemVarSet` tmpls)  -- rnEnvL contains the template variables+      = Just (to_target v')          -- to_target: see (W1)+                                     --   in Note [Matching higher order patterns]+    arg_as_lcl_var _ = Nothing++    can_decompose_app_instead -- Template (e1 v), target (e2 v), and v # fvs(e2)+      = case (e1, e2) of      -- See (W2) in Note [Matching higher order patterns]+           (App _ (Var v1), App f2 (Var v2))+             -> rnOccL rn_env v1 == rnOccR rn_env v2+                && not (v2 `elemVarSet` exprFreeVars f2)+           _ -> False++    ----------------+    -- to_target: see (W1) in Note [Matching higher order patterns]+    to_target :: Var -> Var   -- From canonical variable back to target-expr variable+    to_target v = lookupVarEnv rev_envR v `orElse` v++    rev_envR :: VarEnv Var   -- Inverts rnEnvR: from canonical variable+                             -- back to target-expr variable+    rev_envR = nonDetStrictFoldVarEnv_Directly add_one emptyVarEnv (rnEnvR rn_env)+    add_one uniq var env = extendVarEnv env var (var `setVarUnique` uniq)++{- Note [Matching higher order patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Higher order patterns provide a limited form of higher order matching.+See GHC Proposal #555+  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0555-template-patterns.rst+and #22465 for more details and related work.++Consider the potential match:++   Template: forall f. foo (\x -> f x)+   Target:             foo (\x -> x*2 + x)++The expression `x*2 + x` in the target is not literally an application of a+function to the variable `x`, so the simple application rule does not apply.+However, we can match them modulo beta equivalence with the substitution:++   [f :-> \x -> x*2 + x]++The general problem of higher order matching is tricky to implement, but+the subproblem which we call /higher order pattern matching/ is sufficient+for the given example and much easier to implement.++Design:++We start with terminology.++* /Template variables/. The forall'd variables are called the template+  variables. In the example match above, `f` is a template variable.++* /Local binders/. The local binders of a rule are the variables bound+  inside the template. In the example match above, `x` is a local binder.+  Note that local binders can be term variables and type variables.++A /higher order pattern/ (HOP) is a sub-expression of the template,+of form (f x y z) where:++* (HOP1) f is a template variable+* (HOP2) x, y, z are local binders (like y in rule "wombat" above; see definitions).+* (HOP3) The arguments x, y, z are term variables+* (HOP4) The arguments x, y, z are distinct (no duplicates)++Matching of higher order patterns (HOP-matching). A higher order pattern (f x y z)+(in the template) matches any target expression e provided:++* (HOP5) The target has the same type as the template+* (HOP6) No local binder is free in e, other than x, y, z.++If these two condition hold, the higher order pattern (f x y z) matches+the target expression e, yielding the substitution [f :-> \x y z. e].+Notice that this substitution is type preserving, and the RHS+of the substitution has no free local binders.++HOP matching is small enough to be done in-line in the `match` function.+Two wrinkles:++(W1) Consider the potential match:+        Template:    forall f. foo (\x -> f x)+        Target:                foo (\y -> (y, y))+     During matching we make `x` the canonical variable for the lambdas+     and then we see:+        Template:    f x       rnEnvL = []+        Target:      (y, y)    rnEnvR = [y :-> x]+     We could bind [f :-> \x. (x,x)], by applying rnEnvR substitution to the target+     expression.  But that is tiresome (a) because it involves a traversal, and+     (b) because rnEnvR is a VarEnv Var, and we don't have a substitution function+     for that.++     So instead, we invert rnEnvR, and apply it to the binders, to get+     [f :-> \y. (y,y)].  This is done by `to_target` in the HOP-matching case.+     It takes a little bit of thinking to be sure this will work right in the case+     of shadowing.  E.g.  Template (\x y. f x y)   Target  (\p p. p*p)+     Here rnEnvR will be just [p :-> y], so after inversion we'll get+          [f :-> \x p. p*p]+     but that is fine.++(W2) This wrinkle concerns the overlap between the new HOP rule and the existing+     decompose-application rule.  See 3.1 of GHC Proposal #555 for a discussion.++     Consider potential match:+        Template: forall f.   foo (\x y. Just (f y x))+        Target:               foo (\p q. Just (h (1+q) p)))+     During matching we will encounter:+        Template:    f x y+        Target:      h (1+q) p    rnEnvR = [p:->x, q:->y]+     The rnEnvR renaming `[p:->x, q:->y]` is done by the matcher (today) on the fly,+     to make the bound variables of the template and target "line up".+     But now we can:+     * Either use the new HOP rule to succeed with+          [f :-> \x y. h (1+x) y]+     * Or use the existing decompose-application rule to match+          (f x) against (h (1+q)) and `y` against `p`.+       This will succeed with+          [f :-> \y. h (1+y)]++     Note that the result of the HOP rule will always be eta-equivalent to+     the result of the decompose-application rule.  But the proposal specifies+     that we should use the decompose-application rule because it involves+     less eta-expansion.++     But take care:+        Template: forall f.   foo (\x y. Just (f y x))+        Target:               foo (\p q. Just (h (p+q) p)))+     Then during matching we will encounter:+        Template:    f x y+        Target:      h (p+q) p      rnEnvR = [p:->x, q:->y]+     Now, we cannot use the decompose-application rule, because p is free in+     (h (p+q)). So, we can only use the new HOP rule.++(W3) You might wonder if a HOP can have /type/ arguments, thus (in Core)+        RULE forall h.+             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 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+     has only term-variable arguments.+-}+ -- Note the match on MRefl!  We fail if there is a cast in the target --     (e1 e2) ~ (d1 d2) |> co -- See Note [Cancel reflexive casts]: in the Cast equations for 'match'@@ -1108,7 +1343,7 @@         in_scope_env = ISE in_scope (rv_unf renv)         -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily         -- a superset of the free vars of e2; it is only guaranteed a superset of-        -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe+        -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe         -- wants an in-scope set that includes all the free vars of its argument.         -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630)   , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2@@ -1267,6 +1502,41 @@ -}  -------------+matchTemplateCast+    :: RuleMatchEnv -> RuleSubst+    -> CoreExpr -> Coercion+    -> CoreExpr -> MCoercion+    -> Maybe RuleSubst+matchTemplateCast renv subst e1 co1 e2 mco+  | isEmptyVarSet $ fvVarSet $+    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] 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+       ; subst1 <- match_co renv subst co1 co2+         -- If match_co succeeds, then (exprType e1) = (exprType e2)+         -- Hence the MRefl in the next line+       ; match renv subst1 e1 e2 MRefl }+  where+    substed_co = substCo current_subst co1++    current_subst :: Subst+    current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv))+                               (rs_tv_subst subst)+                               emptyCvSubstEnv+       -- emptyCvSubstEnv: ugh!+       -- If there were any CoVar substitutions they would be in+       -- rs_id_subst; but we don't expect there to be any; see+       -- Note [Casts in the template]+ match_co :: RuleMatchEnv          -> RuleSubst          -> Coercion@@ -1329,7 +1599,8 @@     not_captured fv = not (inRnEnvR rn_env fv)  -------------------------------------------match_var :: RuleMatchEnv+match_var :: HasDebugCallStack+          => RuleMatchEnv           -> RuleSubst           -> Var        -- Template           -> CoreExpr   -- Target@@ -1365,7 +1636,8 @@         -- template x, so we must rename first!  -------------------------------------------match_tmpl_var :: RuleMatchEnv+match_tmpl_var :: HasDebugCallStack+               => RuleMatchEnv                -> RuleSubst                -> Var                -- Template                -> CoreExpr           -- Target@@ -1378,7 +1650,7 @@   -- if the right side of the env is empty.   | anyInRnEnvR rn_env (exprFreeVars e2)   = Nothing     -- Skolem-escape failure-                -- e.g. match forall a. (\x-> a x) against (\y. y y)+                -- e.g. match forall a. (\x -> a) against (\y -> y)    | Just e1' <- lookupVarEnv id_subst v1'   = if eqCoreExpr e1' e2'@@ -1398,6 +1670,7 @@          -- because no free var of e2' is in the rnEnvR of the envt  ------------------------------------------+ match_ty :: RuleMatchEnv          -> RuleSubst          -> Type                -- Template@@ -1409,12 +1682,13 @@ --      newtype T = MkT Int -- We only want to replace (f T) with f', not (f Int). -match_ty renv subst ty1 ty2-  = do  { tv_subst'-            <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2+match_ty (RV { rv_tmpls = tmpls, rv_lcl = rn_env })+         subst@(RS { rs_tv_subst = tv_subst })+         ty1 ty2+  = do  { tv_subst' <- Unify.ruleMatchTyKiX tmpls rn_env tv_subst ty1 ty2+               -- NB: ruleMatchTyKiX applis tv_subst to ty1 only+               --     and of course only binds 'tmpls'         ; return (subst { rs_tv_subst = tv_subst' }) }-  where-    tv_subst = rs_tv_subst subst  {- Note [Matching variable types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1637,41 +1911,59 @@           vcat [ p $$ line | p <- bagToList results ]          ]   where+    line = text (replicate 20 '-')     env = RuleCheckEnv { rc_is_active = isActive phase                        , rc_id_unf    = idUnfolding     -- Not quite right                                                         -- Should use activeUnfolding                        , rc_pattern   = rule_pat                        , rc_rules     = rules                        , rc_ropts     = ropts-                       }-    results = unionManyBags (map (ruleCheckBind env) binds)-    line = text (replicate 20 '-')+                       , rc_in_scope  = emptyInScopeSet } -data RuleCheckEnv = RuleCheckEnv {-    rc_is_active :: Activation -> Bool,-    rc_id_unf  :: IdUnfoldingFun,-    rc_pattern :: String,-    rc_rules :: Id -> [CoreRule],-    rc_ropts :: RuleOpts-}+    results = go env binds -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc+    go _   []           = emptyBag+    go env (bind:binds) = let (env', ds) = ruleCheckBind env bind+                          in ds `unionBags` go env' binds++data RuleCheckEnv = RuleCheckEnv+    { rc_is_active :: Activation -> Bool+    , rc_id_unf    :: IdUnfoldingFun+    , rc_pattern   :: String+    , rc_rules     :: Id -> [CoreRule]+    , rc_ropts     :: RuleOpts+    , rc_in_scope  :: InScopeSet }++extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv+extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v+  = env { rc_in_scope = in_scope `extendInScopeSet` v }++extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv+extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs+  = env { rc_in_scope = in_scope `extendInScopeSetList` vs }++ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc)    -- The Bag returned has one SDoc for each call site found-ruleCheckBind env (NonRec _ r) = ruleCheck env r-ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]+ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r)+ruleCheckBind env (Rec prs)    = (env', unionManyBags (map (ruleCheck env') rhss))+                               where+                                 (bs, rhss) = unzip prs+                                 env' = env `extendInScopeListRC` bs  ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc-ruleCheck _   (Var _)       = emptyBag-ruleCheck _   (Lit _)       = emptyBag-ruleCheck _   (Type _)      = emptyBag-ruleCheck _   (Coercion _)  = emptyBag-ruleCheck env (App f a)     = ruleCheckApp env (App f a) []-ruleCheck env (Tick _ e)  = ruleCheck env e-ruleCheck env (Cast e _)    = ruleCheck env e-ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e-ruleCheck env (Lam _ e)     = ruleCheck env e-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`-                                unionManyBags [ruleCheck env r | Alt _ _ r <- as]+ruleCheck _   (Var _)         = emptyBag+ruleCheck _   (Lit _)         = emptyBag+ruleCheck _   (Type _)        = emptyBag+ruleCheck _   (Coercion _)    = emptyBag+ruleCheck env (App f a)       = ruleCheckApp env (App f a) []+ruleCheck env (Tick _ e)      = ruleCheck env e+ruleCheck env (Cast e _)      = ruleCheck env e+ruleCheck env (Let bd e)      = let (env', ds) = ruleCheckBind env bd+                                in  ds `unionBags` ruleCheck env' e+ruleCheck env (Lam b e)       = ruleCheck (env `extendInScopeRC` b) e+ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags`+                                unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r+                                              | Alt _ bs r <- as]  ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)@@ -1695,8 +1987,9 @@     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),           vcat (map check_rule rules)]   where-    n_args = length args-    i_args = args `zip` [1::Int ..]+    in_scope = rc_in_scope env+    n_args   = length args+    i_args   = args `zip` [1::Int ..]     rough_args = map roughTopName args      check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule@@ -1726,10 +2019,8 @@           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,                               not (isJust (match_fn rule_arg arg))] -          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars           match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl                 where-                  in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)                   renv = RV { rv_lcl   = mkRnEnv2 in_scope                             , rv_tmpls = mkVarSet rule_bndrs                             , rv_fltR  = mkEmptySubst in_scope
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,@@ -29,28 +29,32 @@ import GHC.Core.Unfold.Make import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )+import GHC.Core.DataCon+import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )+import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList+                            , isInScope, substTyVarBndr, cloneTyVarBndr )+import GHC.Core.Predicate( isCoVarType )+import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )+ import GHC.Types.Literal import GHC.Types.Id import GHC.Types.Id.Info  ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) import GHC.Types.Var      ( isNonCoVarId ) import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Core.DataCon import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) import GHC.Types.Tickish-import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )-import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList-                            , isInScope, substTyVarBndr, cloneTyVarBndr )-import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )+import GHC.Types.Basic+ import GHC.Builtin.Types import GHC.Builtin.Names-import GHC.Types.Basic+ import GHC.Unit.Module ( Module ) import GHC.Utils.Encoding import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc+ import GHC.Data.Maybe       ( orElse ) import GHC.Data.Graph.UnVar import Data.List (mapAccumL)@@ -85,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@@ -92,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.@@ -100,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@@ -131,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@@ -215,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 })@@ -229,19 +260,20 @@     (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}  ----------------simple_opt_clo :: InScopeSet+simple_opt_clo :: HasDebugCallStack+               => InScopeSet                -> SimpleClo                -> OutExpr simple_opt_clo in_scope (e_env, e)   = simple_opt_expr (soeSetInScope in_scope e_env) e -simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr+simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr   = go expr   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      ---------------@@ -263,7 +295,6 @@      go lam@(Lam {})     = go_lam env [] lam     go (Case e b ty as)-       -- See Note [Getting the map/coerce RULE to work]       | isDeadBinder b       , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e'         -- We don't need to be concerned about floats when looking for coerce.@@ -273,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@@ -335,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@@ -399,7 +432,8 @@ simple_app env e as   = finish_app env (simple_opt_expr env e) as -finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr+finish_app :: HasDebugCallStack+           => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -- See Note [Eliminate casts in function position] finish_app env (Cast (Lam x e) co) as@(_:_)   | not (isTyVar x) && not (isCoVar x)@@ -448,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>@@ -474,9 +508,9 @@     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 | Just join_arity <- isJoinId_maybe in_bndr+    out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr             = simple_join_rhs join_arity             | otherwise             = simple_opt_clo in_scope clo@@ -490,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]@@ -497,14 +532,27 @@        | otherwise                = True          -- Unconditionally safe to inline-    safe_to_inline :: OccInfo -> Bool-    safe_to_inline IAmALoopBreaker{}                  = False-    safe_to_inline IAmDead                            = True-    safe_to_inline OneOcc{ occ_in_lam = NotInsideLam-                         , occ_n_br = 1 }             = True-    safe_to_inline OneOcc{}                           = False-    safe_to_inline ManyOccs{}                         = False+safe_to_inline :: OccInfo -> Bool+safe_to_inline IAmALoopBreaker{}                  = False+safe_to_inline IAmDead                            = True+safe_to_inline OneOcc{ occ_in_lam = NotInsideLam+                     , occ_n_br = 1 }             = True+safe_to_inline OneOcc{}                           = False+safe_to_inline ManyOccs{}                         = False +do_beta_by_substitution :: Id -> CoreExpr -> Bool+-- True <=> you can inline (bndr = rhs) by substitution+-- See Note [Exploit occ-info in exprIsConApp_maybe]+do_beta_by_substitution bndr rhs+  = exprIsTrivial rhs                   -- Can duplicate+    || safe_to_inline (idOccInfo bndr)  -- Occurs at most once++do_case_elim :: CoreExpr -> Id -> [Id] -> Bool+do_case_elim scrut case_bndr alt_bndrs+  =  exprIsHNF scrut+  && safe_to_inline (idOccInfo case_bndr)+  && all isDeadBinder alt_bndrs+ ------------------- simple_out_bind :: TopLevelFlag                 -> SimpleOptEnv@@ -528,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@@ -547,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@@ -759,6 +809,7 @@    unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc                                     (isTopLevel top_level)                                     False -- may be bottom or not+                                    False -- Not a join point                                     new_rhs Nothing  wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr@@ -813,35 +864,39 @@  This matches literal uses of `map coerce` in code, but that's not what we want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)-too. Some of this is addressed by compulsorily unfolding coerce on the LHS,-yielding+too.  Achieving all this is surprisingly tricky: -  forall a b (dict :: Coercible * a b).-    map @a @b (\(x :: a) -> case dict of-      MkCoercible (co :: a ~R# b) -> x |> co) = ...+(MC1) We must compulsorily unfold MkAge to a cast.+      See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -Getting better. But this isn't exactly what gets produced. This is because-Coercible essentially has ~R# as a superclass, and superclasses get eagerly-extracted during solving. So we get this:+(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) = ... -  forall a b (dict :: Coercible * a b).-    case Coercible_SCSel @* @a @b dict of-      _ [Dead] -> map @a @b (\(x :: a) -> case dict of-                               MkCoercible (co :: a ~R# b) -> x |> co) = ...+  Getting better. But this isn't exactly what gets produced. This is because+  Coercible essentially has ~R# as a superclass, and superclasses get eagerly+  extracted during solving. So we get this: -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 (see also Note [Desugaring coerce as cast] in-Desugar)+    forall a b (dict :: Coercible * a b).+      case Coercible_SCSel @* @a @b dict of+        _ [Dead] -> map @a @b (\(x :: a) -> case dict of+                                 MkCoercible (co :: a ~R# b) -> x |> co) = ... -  forall a b (co :: a ~R# b).-    let dict = MkCoercible @* @a @b co in-    case Coercible_SCSel @* @a @b dict of-      _ [Dead] -> map @a @b (\(x :: a) -> case dict of-         MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...+  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 -Now, we need simpleOptExpr to fix this up. It does so by taking three-separate actions:+    forall a b (co :: a ~R# b).+      let dict = MkCoercible @* @a @b co in+      case Coercible_SCSel @* @a @b dict of+        _ [Dead] -> map @a @b (\(x :: a) -> case dict of+           MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...++  See Note [Desugaring coerce as cast] in GHC.HsToCore++(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three+  separate actions:   1. Inline certain non-recursive bindings. The choice whether to inline      is made in simple_bind_pair. Note the rather specific check for      MkCoercible in there.@@ -853,6 +908,10 @@      just packed and inline them. This is also done in simple_opt_expr's      `go` function. +(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+  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. @@ -1078,6 +1137,45 @@  See test T16254, which checks the behavior of newtypes. +Note [Exploit occ-info in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#23159) we have a simple data constructor wrapper like this (this one+might have come from a data family instance):+   $WK x y = K x y |> co+Now suppose the simplifier sees+   case ($WK e1 e2) |> co2 of+      K p q ->  case q of ...++`exprIsConApp_maybe` expands the wrapper on the fly+(see Note [beta-reduction in exprIsConApp_maybe]). It effectively expands+that ($WK e1 e2) to+   let x = e1; y = e2 in K x y |> co++So the Simplifier might end up producing this:+   let x = e1; y = e2+   in case x of ...++But suppose `q` was used just once in the body of the `K p q` alternative; we+don't want to wait a whole Simplifier iteration to inline that `x`.  (e1 might+be another constructor for example.)  This would happen if `exprIsConApp_maybe`+we created a let for every (non-trivial) argument.  So let's not do that when+the binder is used just once!++Instead, take advantage of the occurrence-info on `x` and `y` in the unfolding+of `$WK`.  Since in `$WK` both `x` and `y` occur once, we want to effectively+expand `($WK e1 e2)` to `(K e1 e2 |> co)`.  Hence in+`do_beta_by_substitution` we say "yes" if++  (a) the RHS is trivial (so we can duplicate it);+      see call to `exprIsTrivial`+or+  (b) the binder occurs at most once (so there is no worry about duplication);+      see call to `safe_to_inline`.++To see this in action, look at testsuite/tests/perf/compiler/T15703.  The+initial Simlifier run takes 5 iterations without (b), but only 3 when we add+(b).+ Note [Don't float join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprIsConApp_maybe should succeed on@@ -1158,7 +1256,7 @@ This Note exists solely to document the problem. -} -data ConCont = CC [CoreExpr] Coercion+data ConCont = CC [CoreExpr] MCoercion                   -- Substitution already applied  -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument@@ -1180,7 +1278,7 @@                    => InScopeEnv -> CoreExpr                    -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) exprIsConApp_maybe ise@(ISE in_scope id_unf) expr-  = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))+  = go (Left in_scope) [] expr (CC [] MRefl)   where     go :: Either InScopeSet Subst              -- Left in-scope  means "empty substitution"@@ -1193,14 +1291,12 @@     go subst floats (Tick t expr) cont        | not (tickishIsCode t) = go subst floats expr cont -    go subst floats (Cast expr co1) (CC args co2)+    go subst floats (Cast expr co1) (CC args m_co2)        | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args             -- See Note [Push coercions in exprIsConApp_maybe]-       = case m_co1' of-           MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2))-           MRefl    -> go subst floats expr (CC args' co2)+       = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2)) -    go subst floats (App fun arg) (CC args co)+    go subst floats (App fun arg) (CC args mco)        | let arg_type = exprType arg        , not (isTypeArg arg) && needsCaseBinding arg_type arg        -- An unlifted argument that’s not ok for speculation must not simply be@@ -1219,21 +1315,18 @@        --       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) co)+       , (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) co)+       = go subst floats fun (CC (subst_expr subst arg : args) mco) -    go subst floats (Lam bndr body) (CC (arg:args) co)-       | exprIsTrivial arg          -- Don't duplicate stuff!-       = go (extend subst bndr arg) floats body (CC args co)+    go subst floats (Lam bndr body) (CC (arg:args) mco)+       | do_beta_by_substitution bndr arg+       = go (extend subst bndr arg) floats body (CC args mco)        | otherwise        = let (subst', bndr') = subst_bndr subst bndr              float           = FloatLet (NonRec bndr' arg)-         in go subst' (float:floats) body (CC args co)+         in go subst' (float:floats) body (CC args mco)      go subst floats (Let (NonRec bndr rhs) expr) cont        | not (isJoinId bndr)@@ -1244,33 +1337,38 @@          in go subst' (float:floats) expr cont      go subst floats (Case scrut b _ [Alt con vars expr]) cont+       | do_case_elim scrut' b vars  -- See Note [Case elim in exprIsConApp_maybe]+       = go (extend subst b scrut') floats expr cont+       | otherwise        = let-          scrut'           = subst_expr subst scrut           (subst', b')     = subst_bndr subst b           (subst'', vars') = subst_bndrs subst' vars           float            = FloatCase scrut' b' con vars'          in            go subst'' (float:floats) expr cont+       where+          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 -    go (Left in_scope) floats (Var fun) cont@(CC args co)+    go (Left in_scope) floats (Var fun) cont@(CC args mco)          | Just con <- isDataConWorkId_maybe fun         , count isValArg args == idArity fun-        = succeedWith in_scope floats $-          pushCoDataCon con args co+        , (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]@@ -1283,7 +1381,7 @@               -- simplOptExpr initialises the in-scope set with exprFreeVars,               -- but that doesn't account for DFun unfoldings         = succeedWith in_scope floats $-          pushCoDataCon con (map (substExpr subst) dfun_args) co+          pushCoDataCon con (map (substExpr subst) dfun_args) mco          -- Look through unfoldings, but only arity-zero one;         -- if arity > 0 we are effectively inlining a function call,@@ -1301,7 +1399,7 @@         , [arg]              <- args         , Just (LitString str) <- exprIsLiteral_maybe ise arg         = succeedWith in_scope floats $-          dealWithStringLiteral fun str co+          dealWithStringLiteral fun str mco         where           unfolding = id_unf fun           extend_in_scope unf_fvs@@ -1325,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)@@ -1349,17 +1447,49 @@     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 -> Coercion+dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion                       -> Maybe (DataCon, [Type], [CoreExpr])  -- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS -- turns those into [] automatically, but just in case something else in GHC -- generates a string literal directly.-dealWithStringLiteral fun str co =+dealWithStringLiteral fun str mco =   case utf8UnconsByteString str of-    Nothing -> pushCoDataCon nilDataCon [Type charTy] co+    Nothing -> pushCoDataCon nilDataCon [Type charTy] mco     Just (char, charTail) ->       let char_expr = mkConApp charDataCon [mkCharLit char]           -- In singleton strings, just add [] instead of unpackCstring# ""#.@@ -1368,9 +1498,30 @@                    else App (Var fun)                             (Lit (LitString charTail)) -      in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co+      in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco  {-+Note [Case elim in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   data K a = MkK !a++   $WMkK x = case x of y -> K y   -- Wrapper for MkK++   ...case $WMkK v of K w -> <rhs>++We call `exprIsConApp_maybe` on ($WMkK v); we inline the wrapper+and beta-reduce, so we get to+   exprIsConApp_maybe (case v of y -> K y)++So we may float the case, and end up with+   case v of y -> <rhs>[y/w]++But if `v` is already evaluated, the next run of the Simplifier will+eliminate the case, and we may then make more progress with <rhs>.+Better to do it in one iteration.  Hence the `do_case_elim`+check in `exprIsConApp_maybe`.+ Note [Unfolding DFuns] ~~~~~~~~~~~~~~~~~~~~~~ DFuns look like
compiler/GHC/Core/Stats.hs view
@@ -98,7 +98,7 @@ coStats co = zeroCS { cs_co = coercionSize co }  coreBindsSize :: [CoreBind] -> Int--- We use coreBindStats for user printout+-- We use coreBindsStats for user printout -- but this one is a quick and dirty basis for -- the simplifier's tick limit coreBindsSize bs = sum (map bindSize bs)
compiler/GHC/Core/Subst.hs view
@@ -19,18 +19,19 @@         substTickish, substDVarSet, substIdInfo,          -- ** Operations on substitutions-        emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst,+        emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,         extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,         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 @@ -61,7 +62,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL)@@ -163,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@@ -239,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/:@@ -371,7 +372,7 @@  substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $-    (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_env tvs cvs, new_id)+    (Subst new_in_scope new_env tvs cvs, new_id)   where     id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary     id2 | no_type_change = id1@@ -385,14 +386,16 @@         -- new_id has the right IdInfo         -- The lazy-set is because we're in a loop here, with         -- rec_subst, when dealing with a mutually-recursive group-    new_id = maybeModifyIdInfo mb_new_info id2+    !new_id = maybeModifyIdInfo mb_new_info id2     mb_new_info = substIdInfo rec_subst id2 (idInfo id2)         -- NB: unfolding info may be zapped          -- Extend the substitution if the unique has changed         -- See the notes with substTyVarBndr for the delVarEnv-    new_env | no_change = delVarEnv env old_id-            | otherwise = extendVarEnv env old_id (Var new_id)+    !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id+        -- Forcing new_in_scope improves T9675 by 1.7%+    !new_env | no_change = delVarEnv env old_id+             | otherwise = extendVarEnv env old_id (Var new_id)      no_change = id1 == old_id         -- See Note [Extending the IdSubstEnv]@@ -423,6 +426,11 @@ 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@@ -430,12 +438,14 @@  -- | Clone a mutually recursive group of 'Id's cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])-cloneRecIdBndrs subst us ids-  = (subst', ids')-  where-    (subst', ids') = mapAccumL (clone_id subst') subst-                               (ids `zip` uniqsFromSupply us)+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@@ -444,13 +454,15 @@             -> (Subst, Id)              -- Transformed pair  clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)-  = (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)+  = (Subst new_in_scope new_idvs tvs new_cvs, new_id)   where     id1     = setVarUnique old_id uniq     id2     = substIdType subst id1-    new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2-    (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))-                        | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)+    !new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2+    !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id+        -- Forcing new_in_scope improves T9675 by 1.7%+    (!new_idvs, !new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))+                          | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)  {- ************************************************************************@@ -479,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'.@@ -587,14 +599,16 @@      = 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)-   = Breakpoint ext n (map do_one ids)+substTickish subst (Breakpoint ext bid ids)+   = Breakpoint ext bid (mapMaybe do_one ids)  where-    do_one = getIdFromTrivialExpr . lookupIdSubst subst+    do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst+ substTickish _subst other = other  {- Note [Substitute lazily]@@ -649,6 +663,13 @@ for an Id in a breakpoint.  We ensure this by never storing an Id with an unlifted type in a Breakpoint - see GHC.HsToCore.Ticks.mkTickish. Breakpoints can't handle free variables with unlifted types anyway.++These measures are only reliable with unoptimized code.+Since we can now enable optimizations for GHCi with+@-fno-unoptimized-core-for-interpreter -O@, nontrivial expressions can be+substituted, e.g. by specializations.+Therefore we resort to discarding free variables from breakpoints when this+situation occurs. -}  {-
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)@@ -132,7 +133,7 @@                -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs-  | is_wkr_like || isJust mb_join_id+  | is_wkr_like || isJoinPoint mb_join_id   , valid_unlifted_worker val_args   = -- pprTrace "computeCbvInfo"     --   (text "fun" <+> ppr fun_id $$@@ -147,14 +148,14 @@    | otherwise = fun_id   where-    mb_join_id  = isJoinId_maybe fun_id+    mb_join_id  = idJoinPointHood fun_id     is_wkr_like = isWorkerLikeId fun_id      val_args = filter isId lam_bndrs     -- When computing CbvMarks, we limit the arity of join points to     -- the JoinArity, because that's the arity we are going to use     -- when calling it. There may be more lambdas than that on the RHS.-    lam_bndrs | Just join_arity <- mb_join_id+    lam_bndrs | JoinPoint join_arity <- mb_join_id               = fst $ collectNBinders join_arity rhs               | otherwise               = fst $ collectBinders rhs@@ -234,8 +235,8 @@  ------------  Tickish  -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish-tidyTickish env (Breakpoint ext ix ids)-  = Breakpoint ext ix (map (tidyVarOcc env) ids)+tidyTickish env (Breakpoint ext bid ids)+  = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _   other_tickish       = other_tickish  ------------  Rules  --------------@@ -430,7 +431,7 @@ Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we-must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.+must preserve this info in inlinings. See Note [oneShot magic] in GHC.Types.Id.Make.  This applies to lambda binders only, hence it is stored in IfaceLamBndr. -}
compiler/GHC/Core/TyCo/Compare.hs view
@@ -7,14 +7,17 @@ -- | Type equality and comparison module GHC.Core.TyCo.Compare ( -    -- * Type comparison-    eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX,-    nonDetCmpTypesX, nonDetCmpTc,+    -- * Type equality+    eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes,     eqVarBndrs, -    pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,-    tcEqTyConApps,+    pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,+    tcEqTyConApps, tcEqTyConAppArgs,+    mayLookIdentical, +    -- * Type comparison+    nonDetCmpType,+    -- * Visiblity comparision    eqForAllVis, cmpForAllVis @@ -22,15 +25,18 @@  import GHC.Prelude -import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe )+import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe+                    , isLevityTy, isRuntimeRepTy, isMultiplicityTy )  import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCon+import GHC.Core.Multiplicity( MultiplicityFlag(..) )  import GHC.Types.Var import GHC.Types.Unique import GHC.Types.Var.Env+import GHC.Types.Var.Set  import GHC.Utils.Outputable import GHC.Utils.Misc@@ -50,7 +56,11 @@  {- ********************************************************************* *                                                                      *-            Type equality+                       Type equality++     We don't use (==) from class Eq, partly so that we know where+     type equality is called, and partly because there are multiple+     variants. *                                                                      * ********************************************************************* -} @@ -70,15 +80,134 @@ * See Historical Note [Typechecker equality vs definitional equality]   below +Note [Casts and coercions in type comparision]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As (EQTYPE) in Note [Non-trivial definitional equality] says, our+general plan, implemented by `fullEq`, is:+ (1) ignore both casts and coercions when comparing types,+ (2) instead, compare the /kinds/ of the two types,+     as well as the types themselves++If possible we want to avoid step (2), comparing the kinds; doing so involves+calling `typeKind` and doing another comparision.++When can we avoid doing so?  Answer: we can certainly avoid doing so if the+types we are comparing have no casts or coercions.  But we can do better.+Consider+    eqType (TyConApp T [s1, ..., sn]) (TyConApp T [t1, .., tn])+We are going to call (eqType s1 t1), (eqType s2 t2) etc.++The kinds of `s1` and `t1` must be equal, because these TyConApps are well-kinded,+and both TyConApps are headed by the same T. So the first recursive call to `eqType`+certainly doesn't need to check kinds. If that call returns False, we stop. Otherwise,+we know that `s1` and `t1` are themselves equal (not just their kinds). This+makes the kinds of `s2` and `t2` to be equal, because those kinds come from the+kind of T instantiated with `s1` and `t1` -- which are the same. Thus we do not+need to check the kinds of `s2` and `t2`. By induction, we don't need to check+the kinds of *any* of the types in a TyConApp, and we also do not need to check+the kinds of the TyConApps themselves.++Conclusion:++* casts and coercions under a TyConApp don't matter -- even including type synonyms++* In step (2), use `hasCasts` to tell if there are any casts to worry about. It+  does not look very deep, because TyConApps and FunTys are so common, and it+  doesn't allocate.  The only recursive cases are AppTy and ForAllTy.++Alternative implementation.  Instead of `hasCasts`, we could make the+generic_eq_type function return+  data EqResult = NotEq | EqWithNoCasts | EqWithCasts+Practically free; but stylistically I prefer useing `hasCasts`:+  * `generic_eq_type` can just uses familiar booleans+  * There is a lot more branching with the three-value variant.+  * It separates concerns.  No need to think about cast-tracking when doing the+    equality comparison.+  * Indeed sometimes we omit the kind check unconditionally, so tracking it is just wasted+    work.+I did try both; there was no perceptible perf difference so I chose `hasCasts` version.++Note [Equality on AppTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+In our cast-ignoring equality, we want to say that the following two+are equal:++  (Maybe |> co) (Int |> co')   ~?       Maybe Int++But the left is an AppTy while the right is a TyConApp. The solution is+to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and+then continue. Easy to do, but also easy to forget to do.++Note [Comparing type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of testing equality between two 'Type's of the form++  TyConApp tc tys1  =  TyConApp tc tys2++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. We'd+prefer to compare `tys1 = tys2`.  When is that sound?  Precisely when the+synonym is not /forgetful/; that is, all its type variables appear in its+RHS -- see `GHC.Core.TyCon.isForgetfulSynTyCon`.++Of course, if we find that the TyCons are *not* equal then we still need to+perform the expansion as their RHSs may still be equal.++This works fine for /equality/, but not for /comparison/.  Consider+   type S a b = (b, a)+Now consider+   S Int Bool `compare` S Char Char+The ordering may depend on whether we expand the synonym or not, and we+don't want the result to depend on that. So for comparison we stick to+/nullary/ synonyms only, which is still useful.++We perform this optimisation in a number of places:++ * GHC.Core.TyCo.Compare.eqType      (works for non-nullary synonyms)+ * GHC.Core.Map.TYpe.eqDeBruijnType  (works for non-nullary synonyms)+ * GHC.Core.Types.nonDetCmpType      (nullary only)++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.++Currently-missed opportunity (#25009):+* In the case of forgetful synonyms, we could still compare the args, pairwise,+  and then compare the RHS's with a suitably extended RnEnv2.  That would avoid+  comparing the same arg repeatedly.  e.g.+      type S a b = (a,a)+  Compare   S <big> y ~ S <big> y+  If we expand, we end up compare <big> with itself twice.++  But since forgetful synonyms are rare, we have not tried this.+ Note [Type comparisons using object pointer comparisons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Quite often we substitute the type from a definition site into-occurances without a change. This means for code like:+occurrences without a change. This means for code like:     \x -> (x,x,x) The type of every `x` will often be represented by a single object in the heap. We can take advantage of this by shortcutting the equality check if two types are represented by the same pointer under the hood. In some cases this reduces compiler allocations by ~2%.++See Note [Pointer comparison operations] in GHC.Builtin.primops.txt.pp++Note [Respecting multiplicity when comparing types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, we respect multiplicities (i.e. the linear part of the type+system) when comparing types.  Doing so is of course crucial during typechecking.++But for reasons described in Note [Linting linearity] in GHC.Core.Lint, it is hard+to ensure that Core is always type-correct when it comes to linearity.  So+* `eqTypeIgnoringMultiplicity` provides a way to compare types that /ignores/ multiplicities+* We use this multiplicity-blind comparison very occasionally, notably+    - in Core Lint: see Note [Linting linearity] in GHC.Core.Lint+    - in rule matching: see Note [Rewrite rules ignore multiplicities in FunTy]+      in GHC.Core.Unify -}  @@ -86,151 +215,249 @@ tcEqKind = tcEqType  tcEqType :: HasDebugCallStack => Type -> Type -> Bool--- ^ tcEqType implements typechecker equality--- It behaves just like eqType, but is implemented--- differently (for now)-tcEqType ty1 ty2-  =  tcEqTypeNoSyns ki1 ki2-  && tcEqTypeNoSyns ty1 ty2-  where-    ki1 = typeKind ty1-    ki2 = typeKind ty2+tcEqType = eqType  -- | Just like 'tcEqType', but will return True for types of different kinds -- as long as their non-coercion structure is identical. tcEqTypeNoKindCheck :: Type -> Type -> Bool-tcEqTypeNoKindCheck ty1 ty2-  = tcEqTypeNoSyns ty1 ty2+tcEqTypeNoKindCheck = eqTypeNoKindCheck  -- | Check whether two TyConApps are the same; if the number of arguments -- are different, just checks the common prefix of arguments. 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 -{--Note [Specialising tc_eq_type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The type equality predicates in Type are hit pretty hard during typechecking.-Consequently we take pains to ensure that these paths are compiled to-efficient, minimally-allocating code.+-- | Type equality on lists of types, looking through type synonyms+eqTypes :: [Type] -> [Type] -> Bool+eqTypes []       []       = True+eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2+eqTypes _        _        = False -To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into-its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating-some dynamic branches, this allows the simplifier to eliminate the closure-allocations that would otherwise be necessary to capture the two boolean "mode"-flags. This reduces allocations by a good fraction of a percent when compiling-Cabal.+eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2+-- Check that the var lists are the same length+-- and have matching kinds; if so, extend the RnEnv2+-- Returns Nothing if they don't match+eqVarBndrs env [] []+ = Just env+eqVarBndrs env (tv1:tvs1) (tv2:tvs2)+ | eqTypeX env (varType tv1) (varType tv2)+ = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2+eqVarBndrs _ _ _= Nothing -See #19226.--}+initRnEnv :: Type -> Type -> RnEnv2+initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $+                  tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb --- | Type equality comparing both visible and invisible arguments and expanding--- type synonyms.-tcEqTypeNoSyns :: Type -> Type -> Bool-tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb+eqTypeNoKindCheck :: Type -> Type -> Bool+eqTypeNoKindCheck ty1 ty2 = eq_type_expand_respect ty1 ty2 --- | Like 'tcEqType', but returns True if the /visible/ part of the types--- are equal, even if they are really unequal (in the invisible bits)-tcEqTypeVis :: Type -> Type -> Bool-tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2+-- | Type equality comparing both visible and invisible arguments,+-- expanding synonyms and respecting multiplicities.+eqType :: HasCallStack => Type -> Type -> Bool+eqType ta tb = fullEq eq_type_expand_respect ta tb +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.+eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool+eqTypeX env ta tb = fullEq (eq_type_expand_respect_x env) ta tb++eqTypeIgnoringMultiplicity :: Type -> Type -> Bool+-- See Note [Respecting multiplicity when comparing types]+eqTypeIgnoringMultiplicity ta tb = fullEq eq_type_expand_ignore ta tb+ -- | Like 'pickyEqTypeVis', but returns a Bool for convenience pickyEqType :: Type -> Type -> Bool -- Check when two types _look_ the same, _including_ synonyms. -- So (pickyEqType String [Char]) returns False -- This ignores kinds and coercions, because this is used only for printing.-pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2+pickyEqType ta tb = eq_type_keep_respect ta tb --- | Real worker for 'tcEqType'. No kind check!-tc_eq_type :: Bool          -- ^ True <=> do not expand type synonyms-           -> Bool          -- ^ True <=> compare visible args only-           -> Type -> Type-           -> Bool--- Flags False, False is the usual setting for tc_eq_type+{- Note [Specialising type equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type equality predicates in Type are hit pretty hard by GHC.  Consequently+we take pains to ensure that these paths are compiled to efficient,+minimally-allocating code.  Plan:++* The main workhorse is `inline_generic_eq_type_x`.  It is /non-recursive/+  and is marked INLINE.++* `inline_generic_eq_type_x` has various parameters that control what it does:+  * syn_flag::SynFlag            whether type synonyms are expanded or kept.+  * mult_flag::MultiplicityFlag  whether multiplicities are ignored or respected+  * mb_env::Maybe RnEnv2         an optional RnEnv2.++* `inline_generic_eq_type_x` has a handful of call sites, namely the ones+  in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc.  It inlines+  at all these sites, specialising to the data values passed for the+  control parameters.++* All /other/ calls to `inline_generic_eq_type_x` go via+     generic_eq_type_x = inline_generic_eq_type_x+     {-# NOINLNE generic_eq_type_x #-}+  The idea is that all calls to `generic_eq_type_x` are specialised by the+  RULES, so this NOINLINE version is seldom, if ever, actually called.++* For each of specialised copy of `inline_generic_eq_type_x, there is a+  corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args)+  into the appropriate specialied version.++See #19226.+-}++-- | This flag controls whether we expand synonyms during comparison+data SynFlag = ExpandSynonyms | KeepSynonyms++eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect+  :: Type -> Type -> Bool+eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x+   :: RnEnv2 -> Type -> Type -> Bool++eq_type_expand_respect       = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing+eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)+eq_type_expand_ignore        = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities  Nothing+eq_type_expand_ignore_x env  = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities  (Just env)+eq_type_keep_respect         = inline_generic_eq_type_x KeepSynonyms   RespectMultiplicities Nothing+eq_type_keep_respect_x env   = inline_generic_eq_type_x KeepSynonyms   RespectMultiplicities (Just env)++{-# RULES+"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing+             = eq_type_expand_respect+"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)+             = eq_type_expand_respect_x env+"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing+             = eq_type_expand_ignore+"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)+             = eq_type_expand_ignore_x env+"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing+             = eq_type_keep_respect+"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)+             = eq_type_keep_respect_x env+ #-}++-- ---------------------------------------------------------------+-- | Real worker for 'eqType'. No kind check!+-- Inline it at the (handful of local) call sites+-- The "generic" bit refers to the flag paramerisation+-- See Note [Specialising type equality].+generic_eq_type_x, inline_generic_eq_type_x+  :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> Bool++{-# NOINLINE generic_eq_type_x #-}+generic_eq_type_x = inline_generic_eq_type_x -- See Note [Computing equality on types] in Type-tc_eq_type keep_syns vis_only orig_ty1 orig_ty2-  = go orig_env orig_ty1 orig_ty2-  where-    go :: RnEnv2 -> Type -> Type -> Bool-    -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.-    go _   (TyConApp tc1 []) (TyConApp tc2 [])-      | tc1 == tc2-      = True -    go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2-    go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2'+{-# INLINE inline_generic_eq_type_x #-}+-- This non-recursive function can inline at its (few) call sites.  The+-- recursion goes via generic_eq_type_x, which is the loop-breaker.+inline_generic_eq_type_x syn_flag mult_flag mb_env+  = \ t1 t2 -> t1 `seq` t2 `seq`+    let go = generic_eq_type_x syn_flag mult_flag mb_env+             -- Abbreviation for recursive calls -    go env (TyVarTy tv1) (TyVarTy tv2)-      = rnOccL env tv1 == rnOccR env tv2+        gos []       []       = True+        gos (t1:ts1) (t2:ts2) = go t1 t2 && gos ts1 ts2+        gos _ _               = False -    go _   (LitTy lit1) (LitTy lit2)-      = lit1 == lit2+    in case (t1,t2) of+      _ | 1# <- reallyUnsafePtrEquality# t1 t2 -> True+      -- See Note [Type comparisons using object pointer comparisons] -    go env (ForAllTy (Bndr tv1 vis1) ty1)-           (ForAllTy (Bndr tv2 vis2) ty2)-      =  vis1 `eqForAllVis` vis2-      && (vis_only || go env (varType tv1) (varType tv2))-      && go (rnBndr2 env tv1 tv2) ty1 ty2+      (TyConApp tc1 tys1, TyConApp tc2 tys2)+        | tc1 == tc2, not (isForgetfulSynTyCon tc1)   -- See Note [Comparing type synonyms]+        -> gos tys1 tys2 +      _ | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 -> go t1' t2+        | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 -> go t1 t2'++      (TyConApp tc1 ts1, TyConApp tc2 ts2)+        | tc1 == tc2 -> gos ts1 ts2+        | otherwise  -> False++      (TyVarTy tv1, TyVarTy tv2)+        -> case mb_env of+              Nothing  -> tv1 == tv2+              Just env -> rnOccL env tv1 == rnOccR env tv2++      (LitTy lit1,    LitTy lit2)    -> lit1 == lit2+      (CastTy t1' _,   _)            -> go t1' t2 -- Ignore casts+      (_,             CastTy t2' _)  -> go t1 t2' -- Ignore casts+      (CoercionTy {}, CoercionTy {}) -> True      -- Ignore coercions+     -- Make sure we handle all FunTy cases since falling through to the     -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked     -- kind variable, which causes things to blow up.     -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check     -- kinds here-    go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)-      = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2-      where-        kinds_eq | vis_only  = True-                 | otherwise = go env (typeKind arg1) (typeKind arg2) &&-                               go env (typeKind res1) (typeKind res2)+      (FunTy _ w1 arg1 res1, FunTy _ w2 arg2 res2)+        ->   fullEq go arg1 arg2+          && fullEq go res1 res2+          && (case mult_flag of+                  RespectMultiplicities -> go w1 w2+                  IgnoreMultiplicities  -> True)        -- See Note [Equality on AppTys] in GHC.Core.Type-    go env (AppTy s1 t1)        ty2-      | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2-      = go env s1 s2 && go env t1 t2-    go env ty1                  (AppTy s2 t2)-      | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1-      = go env s1 s2 && go env t1 t2+      (AppTy s1 t1', _)+        | Just (s2, t2') <- tcSplitAppTyNoView_maybe t2+        -> go s1 s2 && go t1' t2'+      (_,  AppTy s2 t2')+        | Just (s1, t1') <- tcSplitAppTyNoView_maybe t1+        -> go s1 s2 && go t1' t2' -    go env (TyConApp tc1 ts1)   (TyConApp tc2 ts2)-      = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2+      (ForAllTy (Bndr tv1 vis1) body1, ForAllTy (Bndr tv2 vis2) body2)+        -> case mb_env of+              Nothing -> generic_eq_type_x syn_flag mult_flag+                            (Just (initRnEnv t1 t2)) t1 t2+              Just env+                | vis1 `eqForAllVis` vis2         -- See Note [ForAllTy and type equality]+                -> go (varType tv1) (varType tv2)  -- Always do kind-check+                   && generic_eq_type_x syn_flag mult_flag+                             (Just (rnBndr2 env tv1 tv2)) body1 body2+                | otherwise+                -> False -    go env (CastTy t1 _)   t2              = go env t1 t2-    go env t1              (CastTy t2 _)   = go env t1 t2-    go _   (CoercionTy {}) (CoercionTy {}) = True+      _ -> False -    go _ _ _ = False+fullEq :: (Type -> Type -> Bool) -> Type -> Type -> Bool+-- Do "full equality" including the kind check+-- See Note [Casts and coercions in type comparision]+{-# INLINE fullEq #-}+fullEq eq ty1 ty2+  = case eq ty1 ty2 of+          False    -> False+          True | hasCasts ty1 || hasCasts ty2+               -> eq (typeKind ty1) (typeKind ty2)+               | otherwise+               -> True -    gos _   _         []       []      = True-    gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2)-                                      && gos env igs ts1 ts2-    gos _ _ _ _ = False+hasCasts :: Type -> Bool+-- Fast, does not look deep, does not allocate+hasCasts (CastTy {})     = True+hasCasts (CoercionTy {}) = True+hasCasts (AppTy t1 t2)   = hasCasts t1 || hasCasts t2+hasCasts (ForAllTy _ ty) = hasCasts ty+hasCasts _               = False   -- TyVarTy, TyConApp, FunTy, LitTy -    tc_vis :: TyCon -> [Bool]  -- True for the fields we should ignore-    tc_vis tc | vis_only  = inviss ++ repeat False    -- Ignore invisibles-              | otherwise = repeat False              -- Ignore nothing-       -- The repeat False is necessary because tycons-       -- can legitimately be oversaturated-      where-        bndrs = tyConBinders tc-        inviss  = map isInvisibleTyConBinder bndrs -    orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]--{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type].-+{- *********************************************************************+*                                                                      *+                Comparing ForAllTyFlags+*                                                                      *+********************************************************************* -}  -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function -- equates 'Specified' and 'Inferred'. Used for printing. eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool -- See Note [ForAllTy and type equality]--- If you change this, see IMPORTANT NOTE in the above Note eqForAllVis Required      Required      = True eqForAllVis (Invisible _) (Invisible _) = True eqForAllVis _             _             = False@@ -240,7 +467,6 @@ -- equates 'Specified' and 'Inferred'. Used for printing. cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering -- See Note [ForAllTy and type equality]--- If you change this, see IMPORTANT NOTE in the above Note cmpForAllVis Required      Required       = EQ cmpForAllVis Required      (Invisible {}) = LT cmpForAllVis (Invisible _) Required       = GT@@ -251,13 +477,59 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we compare (ForAllTy (Bndr tv1 vis1) ty1)          and    (ForAllTy (Bndr tv2 vis2) ty2)-what should we do about `vis1` vs `vis2`.+what should we do about `vis1` vs `vis2`? -First, we always compare with `eqForAllVis` and `cmpForAllVis`.-But what decision do we make?+We had a long debate about this: see #22762 and GHC Proposal 558.+Here is the conclusion. -Should GHC type-check the following program (adapted from #15740)?+* In Haskell, we really do want (forall a. ty) and (forall a -> ty) to be+  distinct types, not interchangeable.  The latter requires a type argument,+  but the former does not.  See GHC Proposal 558. +* We /really/ do not want the typechecker and Core to have different notions of+  equality.  That is, we don't want `tcEqType` and `eqType` to differ.  Why not?+  Not so much because of code duplication but because it is virtually impossible+  to cleave the two apart. Here is one particularly awkward code path:+     The type checker calls `substTy`, which calls `mkAppTy`,+     which calls `mkCastTy`, which calls `isReflexiveCo`, which calls `eqType`.++* Moreover the resolution of the TYPE vs CONSTRAINT story was to make the+  typechecker and Core have a single notion of equality.++* So in GHC:+  - `tcEqType` and `eqType` implement the same equality+  - (forall a. ty) and (forall a -> ty) are distinct types in both Core and typechecker+  - That is, both `eqType` and `tcEqType` distinguish them.++* But /at representational role/ we can relate the types. That is,+    (forall a. ty) ~R (forall a -> ty)+  After all, since types are erased, they are represented the same way.+  See Note [ForAllCo] and the typing rule for ForAllCo given there++* What about (forall a. ty) and (forall {a}. ty)?  See Note [Comparing visibility].++Note [Comparing visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are sure that we want to distinguish (forall a. ty) and (forall a -> ty); see+Note [ForAllTy and type equality].  But we have /three/ settings for the ForAllTyFlag:+  * Specified: forall a. ty+  * Inferred:  forall {a}. ty+  * Required:  forall a -> ty++We could (and perhaps should) distinguish all three. But for now we distinguish+Required from Specified/Inferred, and ignore the distinction between Specified+and Inferred.++The answer doesn't matter too much, provided we are consistent. And we are consistent+because we always compare ForAllTyFlags with+  * `eqForAllVis`+  * `cmpForAllVis`.+(You can only really check this by inspecting all pattern matches on ForAllTyFlags.)+So if we change the decision, we just need to change those functions.++Why don't we distinguish all three? Should GHC type-check the following program+(adapted from #15740)?+   {-# LANGUAGE PolyKinds, ... #-}   data D a   type family F :: forall k. k -> Type@@ -303,15 +575,11 @@   |                   | forall k -> <...> | Yes    |   -------------------------------------------------- -IMPORTANT NOTE: if we want to change this decision, ForAllCo will need to carry-visiblity (by taking a ForAllTyBinder rathre than a TyCoVar), so that-coercionLKind/RKind build forall types that match (are equal to) the desired-ones.  Otherwise we get an infinite loop in the solver via canEqCanLHSHetero. Examples: T16946, T15079.  Historical Note [Typechecker equality vs definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note describes some history, in case there are vesitges of this+This Note describes some history, in case there are vestiges of this history lying around in the code.  Summary: prior to summer 2022, GHC had have two notions of equality@@ -324,7 +592,7 @@   See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.  * Typechecker equality, as implemented by tcEqType.-  GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality.+  GHC.Tc.Solver.Equality.canonicaliseEquality also respects typechecker equality.  Typechecker equality implied definitional equality: if two types are equal according to typechecker equality, then they are also equal according to@@ -343,91 +611,13 @@ ************************************************************************ *                                                                      *                 Comparison for types-        (We don't use instances so that we know where it happens)++      Not so heavily used, less carefully optimised *                                                                      * ************************************************************************ -Note [Equality on AppTys]-~~~~~~~~~~~~~~~~~~~~~~~~~-In our cast-ignoring equality, we want to say that the following two-are equal:--  (Maybe |> co) (Int |> co')   ~?       Maybe Int--But the left is an AppTy while the right is a TyConApp. The solution is-to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and-then continue. Easy to do, but also easy to forget to do.--Note [Comparing nullary type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the task of testing equality between two 'Type's of the form--  TyConApp tc []--where @tc@ is a type synonym. A naive way to perform this comparison these-would first expand the synonym and then compare the resulting expansions.--However, this is obviously wasteful and the RHS of @tc@ may be large; it is-much better to rather compare the TyCons directly. Consequently, before-expanding type synonyms in type comparisons we first look for a nullary-TyConApp and simply compare the TyCons if we find one. Of course, if we find-that the TyCons are *not* equal then we still need to perform the expansion as-their RHSs may still be equal.--We perform this optimisation in a number of places:-- * GHC.Core.Types.eqType- * GHC.Core.Types.nonDetCmpType- * GHC.Core.Unify.unify_ty- * TcCanonical.can_eq_nc'- * TcUnify.uType--This optimisation is especially helpful for the ubiquitous GHC.Types.Type,-since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications-whenever possible. See Note [Using synonyms to compress types] in-GHC.Core.Type for details.---}--eqType :: Type -> Type -> Bool--- ^ Type equality on source types. Does not look through @newtypes@,--- 'PredType's or type families, but it does look through type synonyms.--- This first checks that the kinds of the types are equal and then--- checks whether the types are equal, ignoring casts and coercions.--- (The kind check is a recursive call, but since all kinds have type--- @Type@, there is no need to check the types of kinds.)--- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep".-eqType t1 t2 = isEqual $ nonDetCmpType t1 t2-  -- It's OK to use nonDetCmpType here and eqType is deterministic,-  -- nonDetCmpType does equality deterministically---- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.-eqTypeX :: RnEnv2 -> Type -> Type -> Bool-eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2-  -- It's OK to use nonDetCmpType here and eqTypeX is deterministic,-  -- nonDetCmpTypeX does equality deterministically---- | Type equality on lists of types, looking through type synonyms--- but not newtypes.-eqTypes :: [Type] -> [Type] -> Bool-eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2-  -- It's OK to use nonDetCmpType here and eqTypes is deterministic,-  -- nonDetCmpTypes does equality deterministically--eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2--- Check that the var lists are the same length--- and have matching kinds; if so, extend the RnEnv2--- Returns Nothing if they don't match-eqVarBndrs env [] []- = Just env-eqVarBndrs env (tv1:tvs1) (tv2:tvs2)- | eqTypeX env (varType tv1) (varType tv2)- = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2-eqVarBndrs _ _ _= Nothing- -- Now here comes the real worker -{- Note [nonDetCmpType nondeterminism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX@@ -439,6 +629,7 @@ -}  nonDetCmpType :: Type -> Type -> Ordering+{-# INLINE nonDetCmpType #-} nonDetCmpType !t1 !t2   -- See Note [Type comparisons using object pointer comparisons]   | 1# <- reallyUnsafePtrEquality# t1 t2@@ -450,13 +641,7 @@   = nonDetCmpTypeX rn_env t1 t2   where     rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))-{-# INLINE nonDetCmpType #-} -nonDetCmpTypes :: [Type] -> [Type] -> Ordering-nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2-  where-    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2)))- -- | An ordering relation between two 'Type's (known below as @t1 :: k1@ -- and @t2 :: k2@) data TypeOrdering = TLT  -- ^ @t1 < t2@@@ -470,6 +655,7 @@ nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse     -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep     -- See Note [Computing equality on types]+    -- Always respects multiplicities, unlike eqType nonDetCmpTypeX env orig_t1 orig_t2 =     case go env orig_t1 orig_t2 of       -- If there are casts then we also need to do a comparison of@@ -503,10 +689,11 @@     -- Returns both the resulting ordering relation between     -- the two types and whether either contains a cast.     go :: RnEnv2 -> Type -> Type -> TypeOrdering-    -- See Note [Comparing nullary type synonyms].+     go _   (TyConApp tc1 []) (TyConApp tc2 [])       | tc1 == tc2-      = TEQ+      = TEQ    -- See Note [Comparing type synonyms]+     go env t1 t2       | Just t1' <- coreView t1 = go env t1' t2       | Just t2' <- coreView t2 = go env t1 t2'@@ -514,7 +701,7 @@     go env (TyVarTy tv1)       (TyVarTy tv2)       = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2     go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2)-      = liftOrdering (vis1 `cmpForAllVis` vis2)+      = liftOrdering (vis1 `cmpForAllVis` vis2)   -- See Note [ForAllTy and type equality]         `thenCmpTy` go env (varType tv1) (varType tv2)         `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 @@ -562,13 +749,6 @@     gos _   _          []         = TGT     gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 ---------------nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering-nonDetCmpTypesX _   []        []        = EQ-nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<>-                                          nonDetCmpTypesX env tys1 tys2-nonDetCmpTypesX _   []        _         = LT-nonDetCmpTypesX _   _         []        = GT  ------------- -- | Compare two 'TyCon's.@@ -581,4 +761,93 @@     u2  = tyConUnique tc2  +{- *********************************************************************+*                                                                      *+                  mayLookIdentical+*                                                                      *+********************************************************************* -}++mayLookIdentical :: Type -> Type -> Bool+-- | Returns True if the /visible/ part of the types+-- might look equal, even if they are really unequal (in the invisible bits)+--+-- This function is very similar to tc_eq_type but it is much more+-- heuristic.  Notably, it is always safe to return True, even with types+-- that might (in truth) be unequal  -- this affects error messages only+-- (Originally this test was done by eqType with an extra flag, but the result+--  was hard to understand.)+mayLookIdentical orig_ty1 orig_ty2+  = go orig_env orig_ty1 orig_ty2+  where+    orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]++    go :: RnEnv2 -> Type -> Type -> Bool++    go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)+      | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms]+      = gos env (tyConBinders tc1) ts1 ts2++    go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2+    go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)   (TyVarTy tv2)   = rnOccL env tv1 == rnOccR env tv2+    go _   (LitTy lit1)    (LitTy lit2)    = lit1 == lit2+    go env (CastTy t1 _)   t2              = go env t1 t2+    go env t1              (CastTy t2 _)   = go env t1 t2+    go _   (CoercionTy {}) (CoercionTy {}) = True++    go env (ForAllTy (Bndr tv1 vis1) ty1)+           (ForAllTy (Bndr tv2 vis2) ty2)+      =  vis1 `eqForAllVis` vis2  -- See Note [ForAllTy and type equality]+      && go (rnBndr2 env tv1 tv2) ty1 ty2+         -- Visible stuff only: ignore kinds of binders++    -- If we have (forall (r::RunTimeRep). ty1  ~   blah) then respond+    -- with True.  Reason: the type pretty-printer defaults RuntimeRep+    -- foralls (see Ghc.Iface.Type.hideNonStandardTypes).  That can make,+    -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the+    -- same as a very different type (#24553).  By responding True, we+    -- tell GHC (see calls of mayLookIdentical) to display without defaulting.+    -- See Note [Showing invisible bits of types in error messages]+    -- in GHC.Tc.Errors.Ppr+    go _ (ForAllTy b _) _ | isDefaultableBndr b = True+    go _ _ (ForAllTy b _) | isDefaultableBndr b = True++    go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)+      = go env arg1 arg2 && go env res1 res2 && go env w1 w2+        -- Visible stuff only: ignore agg kinds++      -- See Note [Equality on AppTys] in GHC.Core.Type+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2+      = go env s1 s2 && go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1+      = go env s1 s2 && go env t1 t2++    go env (TyConApp tc1 ts1)   (TyConApp tc2 ts2)+      = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2++    go _ _ _ = False++    gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool+    gos _   _         []       []      = True+    gos env bs (t1:ts1) (t2:ts2)+      | (invisible, bs') <- case bs of+                               []     -> (False,                    [])+                               (b:bs) -> (isInvisibleTyConBinder b, bs)+      = (invisible || go env t1 t2) && gos env bs' ts1 ts2++    gos _ _ _ _ = False+++isDefaultableBndr :: ForAllTyBinder -> Bool+-- This function should line up with the defaulting done+--   by GHC.Iface.Type.defaultIfaceTyVarsOfKind+-- See Note [Showing invisible bits of types in error messages]+--   in GHC.Tc.Errors.Ppr+isDefaultableBndr (Bndr tv vis)+  = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv)+  where+    is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki  || isMultiplicityTy ki
compiler/GHC/Core/TyCo/FVs.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE MultiWayIf #-}  module GHC.Core.TyCo.FVs   (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,@@ -19,11 +19,12 @@         tyCoVarsOfCoDSet,         tyCoFVsOfCo, tyCoFVsOfCos,         tyCoVarsOfCoList,+        coVarsOfCoDSet, coVarsOfCosDSet,          almostDevoidCoVarOfCo,          -- Injective free vars-        injectiveVarsOfType, injectiveVarsOfTypes,+        injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType,         invisibleVarsOfType, invisibleVarsOfTypes,          -- Any and No Free vars@@ -39,10 +40,6 @@         -- * Occurrence-check expansion         occCheckExpand, -        -- * Well-scoped free variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,-         -- * Closing over kinds         closeOverKindsDSet, closeOverKindsList,         closeOverKinds,@@ -53,15 +50,15 @@  import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView )+import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView ) import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind )  import GHC.Builtin.Types.Prim( funTyFlagTyCon ) -import Data.Monoid as DM ( Endo(..), Any(..) )+import Data.Monoid as DM ( Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon-import GHC.Core.Coercion.Axiom( coAxiomTyCon )+import GHC.Core.Coercion.Axiom( CoAxiomRule(..), BuiltInFamRewrite(..), coAxiomTyCon ) import GHC.Utils.FV  import GHC.Types.Var@@ -71,9 +68,10 @@ 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+ {- %************************************************************************ %*                                                                      *@@ -227,6 +225,17 @@ kind are free -- regardless of whether some local variable has the same Unique. So if we're looking at a variable occurrence at all, then all variables in its kind are free.++Note [Free vars and synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When finding free variables we generally do not expand synonyms.  So given+   type T a = Int+the type (T [b]) will return `b` as a free variable, even though expanding the+synonym would get rid of it.  Expanding synonyms might lead to types that look+ill-scoped; an alternative we have not explored.++But see `occCheckExpand` in this module for a function that does, selectively,+expand synonyms to reduce free-var occurences. -}  {- *********************************************************************@@ -289,16 +298,19 @@ ********************************************************************* -}  tyCoVarsOfType :: Type -> TyCoVarSet+-- The "deep" TyCoVars of the the type tyCoVarsOfType ty = runTyCoVars (deep_ty ty) -- Alternative: --   tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)  tyCoVarsOfTypes :: [Type] -> TyCoVarSet+-- The "deep" TyCoVars of the the type tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) -- Alternative: --   tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys)  tyCoVarsOfCo :: Coercion -> TyCoVarSet+-- The "deep" TyCoVars of the the coercion -- See Note [Free variables of types] tyCoVarsOfCo co = runTyCoVars (deep_co co) @@ -316,7 +328,7 @@ (deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet  deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)-deepTcvFolder = TyCoFolder { tcf_view = noView+deepTcvFolder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]                            , tcf_tyvar = do_tcv, tcf_covar = do_tcv                            , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }   where@@ -374,7 +386,7 @@ (shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet  shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)-shallowTcvFolder = TyCoFolder { tcf_view = noView+shallowTcvFolder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]                               , tcf_tyvar = do_tcv, tcf_covar = do_tcv                               , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }   where@@ -446,6 +458,16 @@                        -- See Note [CoercionHoles and coercion free variables]                        -- in GHC.Core.TyCo.Rep +------- Same again, but for DCoVarSet ----------+--    But this time the free vars are shallow++coVarsOfCosDSet :: [Coercion] -> DCoVarSet+coVarsOfCosDSet cos = fvDVarSetSome isCoVar (tyCoFVsOfCos cos)++coVarsOfCoDSet :: Coercion -> DCoVarSet+coVarsOfCoDSet co = fvDVarSetSome isCoVar (tyCoFVsOfCo co)++ {- ********************************************************************* *                                                                      *           Closing over kinds@@ -584,6 +606,7 @@                                emptyVarSet   -- See Note [Closing over free variable kinds]                                (v:acc_list, extendVarSet acc_set v) tyCoFVsOfType (TyConApp _ tys)   f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc+                                                    -- See Note [Free vars and synonyms] tyCoFVsOfType (LitTy {})         f bound_vars acc = emptyFV f bound_vars acc tyCoFVsOfType (AppTy fun arg)    f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc tyCoFVsOfType (FunTy _ w arg res)  f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc@@ -631,7 +654,7 @@ tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc   = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc-tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc+tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc   = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc   = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc@@ -640,10 +663,10 @@ tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc   = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc     -- See Note [CoercionHoles and coercion free variables]-tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc-tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc-  = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1-                     `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc+tyCoFVsOfCo (AxiomCo _ cs)    fv_cand in_scope acc = tyCoFVsOfCos cs  fv_cand in_scope acc+tyCoFVsOfCo (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps}) fv_cand in_scope acc+  = (tyCoFVsOfCos deps `unionFV` tyCoFVsOfType t1+                      `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc tyCoFVsOfCo (SymCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (TransCo co1 co2)   fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc tyCoFVsOfCo (SelCo _ co)        fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc@@ -651,18 +674,11 @@ tyCoFVsOfCo (InstCo co arg)     fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (KindCo co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (SubCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfCo (AxiomRuleCo _ cs)  fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc  tyCoFVsOfCoVar :: CoVar -> FV tyCoFVsOfCoVar v fv_cand in_scope acc   = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc -tyCoFVsOfProv :: UnivCoProvenance -> FV-tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc-tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc-tyCoFVsOfProv (CorePrepProv _)    fv_cand in_scope acc = emptyFV fv_cand in_scope acc- tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc@@ -672,7 +688,7 @@  -- | Given a covar and a coercion, returns True if covar is almost devoid in -- the coercion. That is, covar can only appear in Refl and GRefl.--- See last wrinkle in Note [Unused coercion variable in ForAllCo] in "GHC.Core.Coercion"+-- See (FC6) in Note [ForAllCo] in "GHC.Core.TyCo.Rep" almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool almostDevoidCoVarOfCo cv co =   almost_devoid_co_var_of_co co cv@@ -686,7 +702,7 @@ almost_devoid_co_var_of_co (AppCo co arg) cv   = almost_devoid_co_var_of_co co cv   && almost_devoid_co_var_of_co arg cv-almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv+almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv   = almost_devoid_co_var_of_co kind_co cv   && (v == cv || almost_devoid_co_var_of_co co cv) almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv@@ -695,10 +711,10 @@   && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv almost_devoid_co_var_of_co (HoleCo h)  cv = (coHoleCoVar h) /= cv-almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv-  = almost_devoid_co_var_of_cos cos cv-almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv-  = almost_devoid_co_var_of_prov p cv+almost_devoid_co_var_of_co (AxiomCo _ cs) cv+  = almost_devoid_co_var_of_cos cs cv+almost_devoid_co_var_of_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) cv+  =  almost_devoid_co_var_of_cos deps cv   && almost_devoid_co_var_of_type t1 cv   && almost_devoid_co_var_of_type t2 cv almost_devoid_co_var_of_co (SymCo co) cv@@ -717,8 +733,6 @@   = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (SubCo co) cv   = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv-  = almost_devoid_co_var_of_cos cs cv  almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool almost_devoid_co_var_of_cos [] _ = True@@ -726,14 +740,6 @@   = almost_devoid_co_var_of_co co cv   && almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool-almost_devoid_co_var_of_prov (PhantomProv co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (ProofIrrelProv co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (PluginProv _)   _ = True-almost_devoid_co_var_of_prov (CorePrepProv _) _ = True- almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True almost_devoid_co_var_of_type (TyConApp _ tys) cv@@ -806,6 +812,28 @@ *                                                                      * ********************************************************************* -} +isInjectiveInType :: TyVar -> Type -> Bool+-- True <=> tv /definitely/ appears injectively in ty+-- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty)+-- Ignore occurrence in coercions, and even in injective positions of+-- type families.+isInjectiveInType tv ty+  = go ty+  where+    go ty | Just ty' <- rewriterView ty = go ty'+    go (TyVarTy tv')                    = tv' == tv+    go (AppTy f a)                      = go f || go a+    go (FunTy _ w ty1 ty2)              = go w || go ty1 || go ty2+    go (TyConApp tc tys)                = go_tc tc tys+    go (ForAllTy (Bndr tv' _) ty)       = go (tyVarKind tv')+                                          || (tv /= tv' && go ty)+    go LitTy{}                          = False+    go (CastTy ty _)                    = go ty+    go CoercionTy{}                     = False++    go_tc tc tys | isTypeFamilyTyCon tc = False+                 | otherwise            = any go tys+ -- | Returns the free variables of a 'Type' that are in injective positions. -- Specifically, it finds the free variables while: --@@ -836,25 +864,30 @@                     -> Type -> FV injectiveVarsOfType look_under_tfs = go   where-    go ty                  | Just ty' <- coreView ty-                           = go ty'-    go (TyVarTy v)         = unitFV v `unionFV` go (tyVarKind v)-    go (AppTy f a)         = go f `unionFV` go a-    go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2-    go (TyConApp tc tys)   =-      case tyConInjectivityInfo tc of-        Injective inj-          |  look_under_tfs || not (isTypeFamilyTyCon tc)-          -> mapUnionFV go $-             filterByList (inj ++ repeat True) tys+    go ty | Just ty' <- rewriterView ty = go ty'+    go (TyVarTy v)                      = unitFV v `unionFV` go (tyVarKind v)+    go (AppTy f a)                      = go f `unionFV` go a+    go (FunTy _ w ty1 ty2)              = go w `unionFV` go ty1 `unionFV` go ty2+    go (TyConApp tc tys)                = go_tc tc tys+    go (ForAllTy (Bndr tv _) ty)        = go (tyVarKind tv) `unionFV` delFV tv (go ty)+    go LitTy{}                          = emptyFV+    go (CastTy ty _)                    = go ty+    go CoercionTy{}                     = emptyFV++    go_tc tc tys+      | isTypeFamilyTyCon tc+      = if | look_under_tfs+           , Injective flags <- tyConInjectivityInfo tc+           -> mapUnionFV go $+              filterByList (flags ++ repeat True) tys                          -- Oversaturated arguments to a tycon are                          -- always injective, hence the repeat True-        _ -> emptyFV-    go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty)-    go LitTy{}                   = emptyFV-    go (CastTy ty _)             = go ty-    go CoercionTy{}              = emptyFV+           | otherwise   -- No injectivity info for this type family+           -> emptyFV +      | otherwise        -- Data type, injective in all positions+      = mapUnionFV go tys+ -- | Returns the free variables of a 'Type' that are in injective positions. -- Specifically, it finds the free variables while: --@@ -916,7 +949,9 @@  {-# INLINE afvFolder #-}   -- so that specialization to (const True) works afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any-afvFolder check_fv = TyCoFolder { tcf_view = noView+-- 'afvFolder' is short for "any-free-var folder", good for checking+-- if any free var of a type satisfies a predicate `check_fv`+afvFolder check_fv = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]                                 , tcf_tyvar = do_tcv, tcf_covar = do_tcv                                 , tcf_hole = do_hole, tcf_tycobinder = do_bndr }   where@@ -949,107 +984,6 @@   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- {- ************************************************************************ *                                                                      *@@ -1058,6 +992,21 @@ ************************************************************************ -} +{- Note [tyConsOfType]+~~~~~~~~~~~~~~~~~~~~~~+It is slightly odd to find the TyCons of a type.  Especially since, via a type+family reduction or axiom, a type that doesn't mention T might start to mention T.++This function is used in only three places:+* In GHC.Tc.Validity.validDerivPred, when identifying "exotic" predicates.+* In GHC.Tc.Errors.Ppr.pprTcSolverReportMsg, when trying to print a helpful+  error about overlapping instances+* In utils/dump-decls/Main.hs, an ill-documented module.++None seem critical. Currently tyConsOfType looks inside coercions, but perhaps+it doesn't even need to do that.+-}+ -- | All type constructors occurring in the type; looking through type --   synonyms, but not newtypes. --  When it finds a Class, it returns the class TyCon.@@ -1082,11 +1031,13 @@      go_co (GRefl _ ty mco)        = go ty `unionUniqSets` go_mco mco      go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args      go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg-     go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co+     go_co (ForAllCo { fco_kind = kind_co, fco_body = co })+                                   = go_co kind_co `unionUniqSets` go_co co      go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })                                    = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r-     go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args-     go_co (UnivCo p _ t1 t2)      = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2+     go_co (AxiomCo ax args)       = go_ax ax `unionUniqSets` go_cos args+     go_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos })+                                   = go t1 `unionUniqSets` go t2 `unionUniqSets` go_cos cos      go_co (CoVarCo {})            = emptyUniqSet      go_co (HoleCo {})             = emptyUniqSet      go_co (SymCo co)              = go_co co@@ -1096,23 +1047,19 @@      go_co (InstCo co arg)         = go_co co `unionUniqSets` go_co arg      go_co (KindCo co)             = go_co co      go_co (SubCo co)              = go_co co-     go_co (AxiomRuleCo _ cs)      = go_cos cs       go_mco MRefl    = emptyUniqSet      go_mco (MCo co) = go_co co -     go_prov (PhantomProv co)    = go_co co-     go_prov (ProofIrrelProv co) = go_co co-     go_prov (PluginProv _)      = emptyUniqSet-     go_prov (CorePrepProv _)    = emptyUniqSet-        -- this last case can happen from the tyConsOfType used from-        -- checkTauTvUpdate-      go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos       go_tc tc = unitUniqSet tc-     go_ax ax = go_tc $ coAxiomTyCon ax +     go_ax (UnbranchedAxiom ax) = go_tc $ coAxiomTyCon ax+     go_ax (BranchedAxiom ax _) = go_tc $ coAxiomTyCon ax+     go_ax (BuiltInFamRew  bif) = go_tc $ bifrw_fam_tc bif+     go_ax (BuiltInFamInj {})   = emptyUniqSet  -- A free-floating axiom+ tyConsOfTypes :: [Type] -> UniqSet TyCon tyConsOfTypes tys = foldr (unionUniqSets . tyConsOfType) emptyUniqSet tys @@ -1266,14 +1213,32 @@     go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co                                              ; arg' <- go_co cxt arg                                              ; return (AppCo co' arg') }-    go_co cxt@(as, env) (ForAllCo tv kind_co body_co)+    go_co cxt (SymCo co)                = do { co' <- go_co cxt co+                                             ; return (SymCo co') }+    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1+                                             ; co2' <- go_co cxt co2+                                             ; return (TransCo co1' co2') }+    go_co cxt (SelCo n co)              = do { co' <- go_co cxt co+                                             ; return (SelCo n co') }+    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co+                                             ; return (LRCo lr co') }+    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co+                                             ; arg' <- go_co cxt arg+                                             ; return (InstCo co' arg') }+    go_co cxt (KindCo co)               = do { co' <- go_co cxt co+                                             ; return (KindCo co') }+    go_co cxt (SubCo co)                = do { co' <- go_co cxt co+                                             ; return (SubCo co') }++    go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co })       = do { kind_co' <- go_co cxt kind_co            ; let tv' = setVarType tv $                        coercionLKind kind_co'                  env' = extendVarEnv env tv tv'                  as'  = as `delVarSet` tv            ; body' <- go_co (as', env') body_co-           ; return (ForAllCo tv' kind_co' body') }+           ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) }+     go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 })       = do { co1' <- go_co cxt co1            ; co2' <- go_co cxt co2@@ -1289,34 +1254,11 @@       | bad_var_occ as (ch_co_var h)    = Nothing       | otherwise                       = return co -    go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args-                                             ; return (AxiomInstCo ax ind args') }-    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p-                                             ; ty1' <- go cxt ty1-                                             ; ty2' <- go cxt ty2-                                             ; return (UnivCo p' r ty1' ty2') }-    go_co cxt (SymCo co)                = do { co' <- go_co cxt co-                                             ; return (SymCo co') }-    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1-                                             ; co2' <- go_co cxt co2-                                             ; return (TransCo co1' co2') }-    go_co cxt (SelCo n co)              = do { co' <- go_co cxt co-                                             ; return (SelCo n co') }-    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co-                                             ; return (LRCo lr co') }-    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co-                                             ; arg' <- go_co cxt arg-                                             ; return (InstCo co' arg') }-    go_co cxt (KindCo co)               = do { co' <- go_co cxt co-                                             ; return (KindCo co') }-    go_co cxt (SubCo co)                = do { co' <- go_co cxt co-                                             ; return (SubCo co') }-    go_co cxt (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co cxt) cs-                                             ; return (AxiomRuleCo ax cs') }--    -------------------    go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co-    go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co-    go_prov _   p@(PluginProv _)    = return p-    go_prov _   p@(CorePrepProv _)  = return p+    go_co cxt (AxiomCo ax cs)           = do { cs' <- mapM (go_co cxt) cs+                                             ; return (AxiomCo ax cs') }+    go_co cxt co@(UnivCo { uco_lty = ty1, uco_rty = ty2, uco_deps = cos })+      = do { ty1' <- go cxt ty1+           ; ty2' <- go cxt ty2+           ; cos' <- mapM (go_co cxt) cos+           ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = cos' }) }
compiler/GHC/Core/TyCo/FVs.hs-boot view
@@ -1,6 +1,8 @@ module GHC.Core.TyCo.FVs where  import GHC.Prelude ( Bool )+import GHC.Types.Var.Set( TyCoVarSet ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )  noFreeVarsOfType :: Type -> Bool+tyCoVarsOfType   :: Type -> TyCoVarSet
compiler/GHC/Core/TyCo/Ppr.hs view
@@ -14,7 +14,7 @@         pprTyVar, pprTyVars,         pprThetaArrowTy, pprClassPred,         pprKind, pprParendKind, pprTyLit,-        pprDataCons, pprWithExplicitKindsWhen,+        pprDataCons, pprWithInvisibleBitsWhen,         pprWithTYPE, pprSourceTyCon,  @@ -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@@ -93,6 +96,13 @@     -- NB: debug-style is used for -dppr-debug     --     dump-style  is used for -ddump-tc-trace etc +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType+tidyToIfaceTypeStyX env ty sty+  | userStyle sty = tidyToIfaceTypeX env ty+  | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty+     -- in latter case, don't tidy, as we'll be printing uniques.++ pprTyLit :: TyLit -> SDoc pprTyLit = pprIfaceTyLit . toIfaceTyLit @@ -100,12 +110,6 @@ pprKind       = pprType pprParendKind = pprParendType -tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType-tidyToIfaceTypeStyX env ty sty-  | userStyle sty = tidyToIfaceTypeX env ty-  | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty-     -- in latter case, don't tidy, as we'll be printing uniques.- tidyToIfaceType :: Type -> IfaceType tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv @@ -117,9 +121,12 @@ -- leave them as IfaceFreeTyVar.  This is super-important -- for debug printing. tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty)+  -- NB: if the type has /already/ been tidied (for example by the typechecker)+  --     the tidy step here is a no-op.  See Note [Tidying is idempotent]+  --     in GHC.Core.TyCo.Tidy   where     env'      = tidyFreeTyCoVars env free_tcvs-    free_tcvs = tyCoVarsOfTypeWellScoped ty+    free_tcvs = tyCoVarsOfTypeList ty  ------------ pprCo, pprParendCo :: Coercion -> SDoc@@ -317,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))@@ -330,13 +337,14 @@     -- TODO: toIfaceTcArgs seems rather wasteful here  --------------------- | Display all kind information (with @-fprint-explicit-kinds@) when the--- provided 'Bool' argument is 'True'.--- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".-pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc-pprWithExplicitKindsWhen b+-- | Display all foralls, runtime-reps, and kind information+-- when provided 'Bool' argument is 'True'.  See GHC.Tc.Errors.Ppr+-- Note [Showing invisible bits of types in error messages]+pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc+pprWithInvisibleBitsWhen b   = updSDocContext $ \ctx ->-      if b then ctx { sdocPrintExplicitKinds = True }+      if b then ctx { sdocPrintExplicitKinds   = True+                    , sdocPrintExplicitRuntimeReps = True }            else ctx  -- | This variant preserves any use of TYPE in a type, effectively
compiler/GHC/Core/TyCo/Rep.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE DeriveDataTypeable #-}  {-# OPTIONS_HADDOCK not-home #-}@@ -48,7 +47,7 @@         mkFunTy, mkNakedFunTy,         mkVisFunTy, mkScaledFunTys,         mkInvisFunTy, mkInvisFunTys,-        tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys,+        tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys,         mkForAllTy, mkForAllTys, mkInvisForAllTys,         mkPiTy, mkPiTys,         mkVisFunTyMany, mkVisFunTysMany,@@ -61,7 +60,7 @@         TyCoFolder(..), foldTyCo, noView,          -- * Sizes-        typeSize, coercionSize, provSize,+        typeSize, typesSize, coercionSize,          -- * Multiplicities         Scaled(..), scaledMult, scaledThing, mapScaledType, Mult@@ -71,12 +70,14 @@  import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) import {-# SOURCE #-} GHC.Builtin.Types+import {-# SOURCE #-} GHC.Core.TyCo.FVs( tyCoVarsOfType ) -- Use in assertions import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint )     -- Transitively pulls in a LOT of stuff, better to break the loop  -- friends: import GHC.Types.Var+import GHC.Types.Var.Set( elemVarSet ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -152,13 +153,15 @@                         --    for example unsaturated type synonyms                         --    can appear as the right hand side of a type synonym. -  | ForAllTy+  | ForAllTy  -- See Note [ForAllTy]         {-# UNPACK #-} !ForAllTyBinder-        Type            -- ^ A Π type.-             -- Note [When we quantify over a coercion variable]-             -- INVARIANT: If the binder is a coercion variable, it must-             -- be mentioned in the Type. See-             -- Note [Unused coercion variable in ForAllTy]+           -- ForAllTyBinder: see GHC.Types.Var+           --    Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]+        Type+           -- INVARIANT: If the binder is a coercion variable, it must+           --            be mentioned in the Type.+           --            See Note [Unused coercion variable in ForAllTy]+           -- See Note [Why ForAllTy can quantify over a coercion variable]    | FunTy      -- ^ FUN m t1 t2   Very common, so an important special case                 -- See Note [Function types]@@ -258,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 Constrain), 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -325,113 +290,6 @@ be careful not to let any variables escape -- thus the last premise of the rule above. -Note [Constraints in kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do we allow a type constructor to have a kind like-   S :: Eq a => a -> Type--No, we do not.  Doing so would mean would need a TyConApp like-   S @k @(d :: Eq k) (ty :: k)- and we have no way to build, or decompose, evidence like- (d :: Eq k) at the type level.--But we admit one exception: equality.  We /do/ allow, say,-   MkT :: (a ~ b) => a -> b -> Type a b--Why?  Because we can, without much difficulty.  Moreover-we can promote a GADT data constructor (see TyCon-Note [Promoted data constructors]), like-  data GT a b where-    MkGT : a -> a -> GT a a-so programmers might reasonably expect to be able to-promote MkT as well.--How does this work?--* In GHC.Tc.Validity.checkConstraintsOK we reject kinds that-  have constraints other than (a~b) and (a~~b).--* In Inst.tcInstInvisibleTyBinder we instantiate a call-  of MkT by emitting-     [W] co :: alpha ~# beta-  and producing the elaborated term-     MkT @alpha @beta (Eq# alpha beta co)-  We don't generate a boxed "Wanted"; we generate only a-  regular old /unboxed/ primitive-equality Wanted, and build-  the box on the spot.--* How can we get such a MkT?  By promoting a GADT-style data-  constructor, written with an explicit equality constraint.-     data T a b where-       MkT :: (a~b) => a -> b -> T a b-  See DataCon.mkPromotedDataCon-  and Note [Promoted data constructors] in GHC.Core.TyCon--* We support both homogeneous (~) and heterogeneous (~~)-  equality.  (See Note [The equality types story]-  in GHC.Builtin.Types.Prim for a primer on these equality types.)--* How do we prevent a MkT having an illegal constraint like-  Eq a?  We check for this at use-sites; see GHC.Tc.Gen.HsType.tcTyVar,-  specifically dc_theta_illegal_constraint.--* Notice that nothing special happens if-    K :: (a ~# b) => blah-  because (a ~# b) is not a predicate type, and is never-  implicitly instantiated. (Mind you, it's not clear how you-  could creates a type constructor with such a kind.) See-  Note [Types for coercions, predicates, and evidence]--* The existence of promoted MkT with an equality-constraint-  argument is the (only) reason that the AnonTCB constructor-  of TyConBndrVis carries an FunTyFlag.-  For example, when we promote the data constructor-     MkT :: forall a b. (a~b) => a -> b -> T a b-  we get a PromotedDataCon with tyConBinders-      Bndr (a :: Type)  (NamedTCB Inferred)-      Bndr (b :: Type)  (NamedTCB Inferred)-      Bndr (_ :: a ~ b) (AnonTCB FTF_C_T)-      Bndr (_ :: a)     (AnonTCB FTF_T_T))-      Bndr (_ :: b)     (AnonTCB FTF_T_T))--* One might reasonably wonder who *unpacks* these boxes once they are-  made. After all, there is no type-level `case` construct. The-  surprising answer is that no one ever does. Instead, if a GADT-  constructor is used on the left-hand side of a type family equation,-  that occurrence forces GHC to unify the types in question. For-  example:--  data G a where-    MkG :: G Bool--  type family F (x :: G a) :: a where-    F MkG = False--  When checking the LHS `F MkG`, GHC sees the MkG constructor and then must-  unify F's implicit parameter `a` with Bool. This succeeds, making the equation--    F Bool (MkG @Bool <Bool>) = False--  Note that we never need unpack the coercion. This is because type-  family equations are *not* parametric in their kind variables. That-  is, we could have just said--  type family H (x :: G a) :: a where-    H _ = False--  The presence of False on the RHS also forces `a` to become Bool,-  giving us--    H Bool _ = False--  The fact that any of this works stems from the lack of phase-  separation between types and kinds (unlike the very present phase-  separation between terms and types).--  Once we have the ability to pattern-match on types below top-level,-  this will no longer cut it, but it seems fine for now.-- Note [Arguments to type constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Because of kind polymorphism, in addition to type application we now@@ -456,15 +314,25 @@  Note [Non-trivial definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Is Int |> <*> the same as Int? YES! In order to reduce headaches,-we decide that any reflexive casts in types are just ignored.-(Indeed they must be. See Note [Respecting definitional equality].)-More generally, the `eqType` function, which defines Core's type equality-relation, ignores casts and coercion arguments, as long as the-two types have the same kind. This allows us to be a little sloppier-in keeping track of coercions, which is a good thing. It also means-that eqType does not depend on eqCoercion, which is also a good thing.+Is ((IO |> co1) Int |> co2) equal to (IO Int)?+Assume+   co1 :: (Type->Type) ~ (Type->Wombat)+   co2 :: Wombat ~ Type+Well, yes.  The casts are just getting in the way.+See also Note [Respecting definitional equality]. +So we do this:++(EQTYPE)+  The `eqType` function, which defines Core's type equality relation,+  - /ignores/ casts, and+  - /ignores/ coercion arguments+  - /provided/ two types have the same kind++This allows us to be a little sloppier in keeping track of coercions, which is a+good thing. It also means that eqType does not depend on eqCoercion, which is+also a good thing.+ Why is this sensible? That is, why is something different than α-equivalence appropriate for the implementation of eqType? @@ -559,7 +427,7 @@  Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done-in mkCastTy. This is (EQ1) below.+in mkCastTy. This is (EQ2) below.  Unfortunately, that's not the end of the story. Consider comparing   (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)@@ -582,7 +450,7 @@  In order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).-This is (EQ2) below.+This is (EQ3) below.  One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. The kind of the body is the same as the kind of the ForAllTy. Accordingly,@@ -595,9 +463,9 @@  In sum, in order to uphold (EQ), we need the following invariants: -  (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable-        cast is one that relates either a FunTy to a FunTy or a-        ForAllTy to a ForAllTy.+  (EQ1) No decomposable CastTy to the left of an AppTy,+        where a "decomposable cast" is one that relates+        either a FunTy to a FunTy, or a ForAllTy to a ForAllTy.   (EQ2) No reflexive casts in CastTy.   (EQ3) No nested CastTys.   (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).@@ -624,8 +492,22 @@ expand into TyConApps, we must check the kinds of the arg and the res. -Note [When we quantify over a coercion variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [ForAllTy]+~~~~~~~~~~~~~~~+A (ForAllTy (Bndr tcv vis) ty) can quantify over a TyVar or, less commonly, a CoVar.+See Note [Why ForAllTy can quantify over a coercion variable] for why we need the latter.++(FT1) Invariant: See Note [Weird typing rule for ForAllTy]++(FT2) Invariant: in (ForAllTy (Bndr tcv vis) ty),+      if tcv is a CoVar, then vis = coreTyLamForAllTyFlag.+   Visibility is not important for coercion abstractions,+   because they are not user-visible.++(FT3) Invariant: see Note [Unused coercion variable in ForAllTy]++Note [Why ForAllTy can quantify over a coercion variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely) a CoVar. We support quantifying over a CoVar here in order to support a homogeneous (~#) relation (someday -- not yet implemented). Here is@@ -648,10 +530,8 @@ make this work out.  See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2-which gives a general road map that covers this space.--Having this feature in Core does *not* mean we have it in source Haskell.-See #15710 about that.+which gives a general road map that covers this space.  Having this feature in+Core does *not* mean we have it in source Haskell.  See #15710 about that.  Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -828,22 +708,6 @@   where     af = invisArg (typeTypeOrConstraint res) -tcMkVisFunTy :: Mult -> Type -> Type -> Type--- Always TypeLike, user-specified multiplicity.--- Does not have the assert-checking in mkFunTy: used by the typechecker--- to avoid looking at the result kind, which may not be zonked-tcMkVisFunTy mult arg res-  = FunTy { ft_af = visArgTypeLike, ft_mult = mult-          , ft_arg = arg, ft_res = res }--tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type--- Always TypeLike, invisible argument--- Does not have the assert-checking in mkFunTy: used by the typechecker--- to avoid looking at the result kind, which may not be zonked-tcMkInvisFunTy res_torc arg res-  = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy-          , ft_arg = arg, ft_res = res }- mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type -- Always TypeLike, user-specified multiplicity. mkVisFunTy = mkFunTy visArgTypeLike@@ -870,19 +734,21 @@   where     af = visArg (typeTypeOrConstraint ty) -tcMkScaledFunTys :: [Scaled Type] -> Type -> Type--- All visible args--- Result type must be TypeLike--- No mkFunTy assert checking; result kind may not be zonked-tcMkScaledFunTys tys ty = foldr mk ty tys-  where-    mk (Scaled mult arg) res = tcMkVisFunTy mult arg res- --------------- -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder -- See Note [Unused coercion variable in ForAllTy] mkForAllTy :: ForAllTyBinder -> Type -> Type-mkForAllTy = ForAllTy+mkForAllTy bndr body+  = assertPpr (good_bndr bndr) (ppr bndr <+> ppr body) $+    ForAllTy bndr body+  where+    -- Check ForAllTy invariants+    good_bndr (Bndr cv vis)+      | isCoVar cv = vis == coreTyLamForAllTyFlag+                     -- See (FT2) in Note [ForAllTy]+                  && (cv `elemVarSet` tyCoVarsOfType body)+                     -- See (FT3) in Note [ForAllTy]+      | otherwise = True  -- | Wraps foralls over the type using the provided 'TyCoVar's from left to right mkForAllTys :: [ForAllTyBinder] -> Type -> Type@@ -892,11 +758,11 @@ mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) -mkPiTy :: PiTyBinder -> Type -> Type+mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type mkPiTy (Anon ty1 af) ty2  = mkScaledFunTy af ty1 ty2 mkPiTy (Named bndr) ty    = mkForAllTy bndr ty -mkPiTys :: [PiTyBinder] -> Type -> Type+mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs  -- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you@@ -907,6 +773,31 @@ mkNakedTyConTy :: TyCon -> Type mkNakedTyConTy tycon = TyConApp tycon [] +tcMkVisFunTy :: Mult -> Type -> Type -> Type+-- Always TypeLike result, user-specified multiplicity.+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkVisFunTy mult arg res+  = FunTy { ft_af = visArgTypeLike, ft_mult = mult+          , ft_arg = arg, ft_res = res }++tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type+-- Always invisible (constraint) argument, result specified by res_torc+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkInvisFunTy res_torc arg res+  = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy+          , ft_arg = arg, ft_res = res }++tcMkScaledFunTys :: [Scaled Type] -> Type -> Type+-- All visible args+-- Result type must be TypeLike+-- No mkFunTy assert checking; result kind may not be zonked+tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys++tcMkScaledFunTy :: Scaled Type -> Type -> Type+tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res+ {- %************************************************************************ %*                                                                      *@@ -956,13 +847,19 @@   | AppCo Coercion CoercionN             -- lift AppTy           -- AppCo :: e -> N -> e -  -- See Note [Forall coercions]-  | ForAllCo TyCoVar KindCoercion Coercion+  -- See Note [ForAllCo]+  | ForAllCo+      { fco_tcv  :: TyCoVar+      , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind+      , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind+                                  -- See (FC7) of Note [ForAllCo]+      , fco_kind :: KindCoercion+      , fco_body :: Coercion }          -- ForAllCo :: _ -> N -> e -> e    | FunCo  -- FunCo :: "e" -> N/P -> e -> e -> e            -- See Note [FunCo] for fco_afl, fco_afr-       { fco_role         :: Role+        { fco_role         :: Role         , fco_afl          :: FunTyFlag   -- Arrow for coercionLKind         , fco_afr          :: FunTyFlag   -- Arrow for coercionRKind         , fco_mult         :: CoercionN@@ -974,9 +871,7 @@   | CoVarCo CoVar      -- :: _ -> (N or R)                        -- result role depends on the tycon of the variable's type -    -- AxiomInstCo :: e -> _ -> ?? -> e-  | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion]-     -- See also [CoAxiom index]+  | AxiomCo CoAxiomRule [Coercion]      -- The coercion arguments always *precisely* saturate      -- arity of (that branch of) the CoAxiom. If there are      -- any left over, we use AppCo.@@ -984,13 +879,14 @@      -- The roles of the argument coercions are determined      -- by the cab_roles field of the relevant branch of the CoAxiom -  | AxiomRuleCo CoAxiomRule [Coercion]-    -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule-    -- The number coercions should match exactly the expectations-    -- of the CoAxiomRule (i.e., the rule is fully saturated).--  | UnivCo UnivCoProvenance Role Type Type-      -- :: _ -> "e" -> _ -> _ -> e+  | UnivCo  -- See Note [UnivCo]+            -- Of kind (lty ~role rty)+      { uco_prov         :: UnivCoProvenance+      , uco_role         :: Role+      , uco_lty, uco_rty :: Type+      , uco_deps         :: [Coercion]  -- Coercions on which it depends+               --   See Note [The importance of tracking UnivCo dependencies]+      }    | SymCo Coercion             -- :: e -> e   | TransCo Coercion Coercion  -- :: e -> e -> e@@ -1028,13 +924,13 @@    | SelForAll          -- Decomposes (forall a. co) -  deriving( Eq, Data.Data )+  deriving( Eq, Data.Data, Ord )  data FunSel  -- See Note [SelCo]   = SelMult  -- Multiplicity   | SelArg   -- Argument of function   | SelRes   -- Result of function-  deriving( Eq, Data.Data )+  deriving( Eq, Data.Data, Ord )  type CoercionN = Coercion       -- always nominal type CoercionR = Coercion       -- always representational@@ -1045,15 +941,25 @@   ppr = pprCo  instance Outputable CoSel where-  ppr (SelTyCon n _r) = text "Tc" <> parens (int n)-  ppr SelForAll       = text "All"-  ppr (SelFun fs)     = text "Fun" <> parens (ppr fs)+  ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r)+  ppr SelForAll      = text "All"+  ppr (SelFun fs)    = text "Fun" <> parens (ppr fs) +pprOneCharRole :: Role -> SDoc+pprOneCharRole Nominal          = char 'N'+pprOneCharRole Representational = char 'R'+pprOneCharRole Phantom          = char 'P'+ instance Outputable FunSel where   ppr SelMult = text "mult"   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@@ -1070,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'.@@ -1152,26 +1058,28 @@ 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) : 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]  * SelForAll:       co : forall (a:k1).t1 ~r0 forall (a:k2).t2       -----------------------------------      SelCo SelForAll : k1 ~N k2+      SelCo SelForAll co : k1 ~N k2    NB: SelForAll always gives a Nominal coercion. @@ -1181,17 +1089,17 @@       co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)       r = funRole r0 SelMult       -----------------------------------      SelCo (SelFun SelMult) : m1 ~r m2+      SelCo (SelFun SelMult) co : m1 ~r m2        co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)       r = funRole r0 SelArg       -----------------------------------      SelCo (SelFun SelArg) : s1 ~r s2+      SelCo (SelFun SelArg) co : s1 ~r s2        co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)       r = funRole r0 SelRes       -----------------------------------      SelCo (SelFun SelRes) : t1 ~r t2+      SelCo (SelFun SelRes) co : t1 ~r t2  Note [FunCo] ~~~~~~~~~~~~@@ -1253,57 +1161,123 @@  which can be optimized to F g. -Note [CoAxiom index]-~~~~~~~~~~~~~~~~~~~~-A CoAxiom has 1 or more branches. Each branch has contains a list-of the free type variables in that branch, the LHS type patterns,-and the RHS type for that branch. When we apply an axiom to a list-of coercions, we must choose which branch of the axiom we wish to-use, as the different branches may have different numbers of free-type variables. (The number of type patterns is always the same-among branches, but that doesn't quite concern us here.)+Note [Required foralls in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty).+It has type+   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.coreTyLamForAllTyFlag`. -The Int in the AxiomInstCo constructor is the 0-indexed number-of the chosen branch.+So how can we ever get a term of type (forall a -> e_ty)?  Answer: /only/ via a+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. -Note [Forall coercions]-~~~~~~~~~~~~~~~~~~~~~~~+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.++See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.++Note [ForAllCo]+~~~~~~~~~~~~~~~+See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.+ Constructing coercions between forall-types can be a bit tricky, because the kinds of the bound tyvars can be different.  The typing rule is: +  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+  ------------------------------------+  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]) -  kind_co : k1 ~ k2-  tv1:k1 |- co : t1 ~ t2-  --------------------------------------------------------------------  ForAllCo tv1 kind_co co : all tv1:k1. t1  ~-                            all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co])+Several things to note here -First, the TyCoVar stored in a ForAllCo is really an optimisation: this field-should be a Name, as its kind is redundant. Thinking of the field as a Name-is helpful in understanding what a ForAllCo means.-The kind of TyCoVar always matches the left-hand kind of the coercion.+(FC1) First, the TyCoVar stored in a ForAllCo is really just a convenience: this+  field should be a Name, as its kind is redundant. Thinking of the field as a+  Name is helpful in understanding what a ForAllCo means.  The kind of TyCoVar+  always matches the left-hand kind of the coercion. -The idea is that kind_co gives the two kinds of the tyvar. See how, in the-conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.+  * The idea is that kind_co gives the two kinds of the tyvar. See how, in the+    conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. -Of course, a type variable can't have different kinds at the same time. So,-we arbitrarily prefer the first kind when using tv1 in the inner coercion-co, which shows that t1 equals t2.+  * Of course, a type variable can't have different kinds at the same time.+    So, in `co` itself we use (tv1 : k1); hence the premise+          tv1:k1 |- co : t1 ~r t2 -The last wrinkle is that we need to fix the kinds in the conclusion. In-t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of-the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with-(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it-mentions the same name with different kinds, but it *is* well-kinded, noting-that `(tv1:k2) |> sym kind_co` has kind k1.+  * The last wrinkle is that we need to fix the kinds in the conclusion. In+    t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of+     the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with+     (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it+    mentions the same name with different kinds, but it *is* well-kinded, noting+     that `(tv1:k2) |> sym kind_co` has kind k1. -This all really would work storing just a Name in the ForAllCo. But we can't-add Names to, e.g., VarSets, and there generally is just an impedance mismatch-in a bunch of places. So we use tv1. When we need tv2, we can use-setTyVarKind.+  We could instead store just a Name in the ForAllCo, and it might even be+  more efficient to do so. But we can't add Names to, e.g., VarSets, and+  there generally is just an impedance mismatch in a bunch of places. So we+  use tv1. When we need tv2, we can use setTyVarKind. +(FC2) Note that the kind coercion must be Nominal; and that the role `r` of+  the final coercion is the same as that of the body coercion.++(FC3) A ForAllCo allows casting between visibilities.  For example:+         ForAllCo a Required Specified (SubCo (Refl ty))+           : (forall a -> ty) ~R (forall a. ty)+  But you can only cast between visiblities at Representational role;+  Hence the premise+      if r=N, then vis1=vis2+  in the typing rule.  See also Note [ForAllTy and type equality] in+  GHC.Core.TyCo.Compare.++(FC4) See Note [Required foralls in Core].++(FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that+  `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy]+  in GHC.Core.TyCo.Rep for the motivation.  If it does not appear free,+  use FunTy.++  However we do /not/ impose the same restriction on ForAllCo in /coercions/.+  Instead, in coercionLKind and coercionRKind, we use mkTyCoForAllTy to perform+  the check and construct a FunTy when necessary.  Why?+    * For a coercion, all that matters is its kind, So ForAllCo vs FunCo does not+       make a difference.+    * Even if cv occurs in body_co, it is possible that cv does not occur in the kind+      of body_co. Therefore the check in coercionKind is inevitable.++(FC6) Invariant: in a ForAllCo where fco_tcv is a coercion variable, `cv`,+  we insist that `cv` appears only in positions that are erased. In fact we use+  a conservative approximation of this: we require that+       (almostDevoidCoVarOfCo cv fco_body)+  holds.  This function checks that `cv` appers only within the type in a Refl+  node and under a GRefl node (including in the Coercion stored in a GRefl).+  It's possible other places are OK, too, but this is a safe approximation.++  Why all this fuss?  See Section 5.8.5.2 of Richard's thesis. The idea is that+  we cannot prove that the type system is consistent with unrestricted use of this+  cv; the consistency proof uses an untyped rewrite relation that works over types+  with all coercions and casts removed. So, we can allow the cv to appear only in+  positions that are erased.++  Sadly, with heterogeneous equality, this restriction might be able to be+  violated; Richard's thesis is unable to prove that it isn't. Specifically, the+  liftCoSubst function might create an invalid coercion. Because a violation of+  the restriction might lead to a program that "goes wrong", it is checked all+  the time, even in a production compiler and without -dcore-lint. We *have*+  proved that the problem does not occur with homogeneous equality, so this+  check can be dropped once ~# is made to be homogeneous.++(FC7) Invariant: in a ForAllCo, if fco_tcv is a CoVar, then+         fco_visL = fco_visR = coreTyLamForAllTyFlag+  c.f. (FT2) in Note [ForAllTy]+ Note [Predicate coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -1467,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;@@ -1512,17 +1490,30 @@  %************************************************************************ %*                                                                      *-                UnivCoProvenance+                UnivCo %*                                                                      * %************************************************************************ +Note [UnivCo]+~~~~~~~~~~~~~ A UnivCo is a coercion whose proof does not directly express its role and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). -The different kinds of UnivCo are described by UnivCoProvenance.  Really-each is entirely separate, but they all share the need to represent their-role and kind, which is done in the UnivCo constructor.+The different kinds of UnivCo are described by UnivCoProvenance.  Really each+is entirely separate, but they all share the need to represent these fields: +  UnivCo+      { uco_prov         :: UnivCoProvenance+      , uco_role         :: Role+      , uco_lty, uco_rty :: Type+      , uco_deps         :: [Coercion]  -- Coercions on which it depends++Here,+ * uco_role, uco_lty, uco_rty express the type of the coercion+ * uco_prov says where it came from+ * uco_deps specifies the coercions on which this proof (which is not+   explicity given) depends. See+   Note [The importance of tracking UnivCo dependencies] -}  -- | For simplicity, we have just one UnivCo that represents a coercion from@@ -1534,34 +1525,134 @@ -- that they don't tell you what types they coercion between. (That info -- is in the 'UnivCo' constructor of 'Coercion'. data UnivCoProvenance-  = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom-                             -- roled coercions--  | ProofIrrelProv KindCoercion  -- ^ From the fact that any two coercions are-                                 --   considered equivalent. See Note [ProofIrrelProv].-                                 -- Can be used in Nominal or Representational coercions+  = PhantomProv    -- ^ See Note [Phantom coercions]. Only in Phantom+                   -- roled coercions -  | PluginProv String  -- ^ From a plugin, which asserts that this coercion-                       --   is sound. The string is for the use of the plugin.+  | ProofIrrelProv -- ^ From the fact that any two coercions are+                   --   considered equivalent. See Note [ProofIrrelProv].+                   -- Can be used in Nominal or Representational coercions -  | CorePrepProv       -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-      Bool   -- True  <=> the UnivCo must be homogeneously kinded-             -- False <=> allow hetero-kinded, e.g. Int ~ Int#+  | PluginProv String+      -- ^ From a plugin, which asserts that this coercion is sound.+      --   The string and the variable set are for the use by the plugin. -  deriving Data.Data+  deriving (Eq, Ord, Data.Data)+  -- 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 (CorePrepProv _)   = text "(CorePrep)"+  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` ()++instance Binary UnivCoProvenance where+  put_ bh PhantomProv    = putByte bh 1+  put_ bh ProofIrrelProv = putByte bh 2+  put_ bh (PluginProv a) = putByte bh 3 >> put_ bh a+  get bh = do+      tag <- getByte bh+      case tag of+           1 -> return PhantomProv+           2 -> return ProofIrrelProv+           3 -> do a <- get bh+                   return $ PluginProv a+           _ -> panic ("get UnivCoProvenance " ++ show tag)+++{- Note [Phantom coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     data T a = T1 | T2+Then we have+     T s ~R T t+for any old s,t. The witness for this is (TyConAppCo T Rep co),+where (co :: s ~P t) is a phantom coercion built with PhantomProv.+The role of the UnivCo is always Phantom.  The Coercion stored is the+(nominal) kind coercion between the types+   kind(s) ~N kind (t)++Note [ProofIrrelProv]+~~~~~~~~~~~~~~~~~~~~~+A ProofIrrelProv is a coercion between coercions. For example:++  data G a where+    MkG :: G Bool++In core, we get++  G :: * -> *+  MkG :: forall (a :: *). (a ~# Bool) -> G a++Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want+a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be++  TyConAppCo Nominal MkG [co3, co4]+  where+    co3 :: co1 ~ co2+    co4 :: a1 ~ a2++Note that+  co1 :: a1 ~ Bool+  co2 :: a2 ~ Bool++Here,+  co3 = UnivCo ProofIrrelProv Nominal (CoercionTy co1) (CoercionTy co2) [co5]+  where+    co5 :: (a1 ~# Bool) ~# (a2 ~# Bool)+    co5 = TyConAppCo Nominal (~#) [<Consraint#>, <Constraint#>, co4, <Bool>]+++Note [The importance of tracking UnivCo dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is vital that `UnivCo` (a coercion that lacks a proper proof)+tracks the coercions on which it depends. To see why, consider this program:++    type S :: Nat -> Nat++    data T (a::Nat) where+      T1 :: T 0+      T2 :: ...++    f :: T a -> S (a+1) -> S 1+    f = /\a (x:T a) (y:a).+        case x of+          T1 (gco : a ~# 0) -> y |> wco++For this to typecheck we need `wco :: S (a+1) ~# S 1`, given that `gco : a ~# 0`.+To prove that we need to know that `a+1 = 1` if `a=0`, which a plugin might know.+So it solves `wco` by providing a `UnivCo (PluginProv "my-plugin") (a+1) 1 [gco]`.++    But the `uco_deps` in `PluginProv` must mention `gco`!++Why? Otherwise we might float the entire expression (y |> wco) out of the+the case alternative for `T1` which brings `gco` into scope. If this+happens then we aren't far from a segmentation fault or much worse.+See #23923 for a real-world example of this happening.++So it is /crucial/ for the `UnivCo` to mention, in `uco_deps`, the coercion+variables used by the plugin to justify the `UnivCo` that it builds.  You+should think of it like `TyConAppCo`: the `UnivCo` proof constructor is+applied to a list of coercions, just as `TyConAppCo` is++It's very convenient to record a full coercion, not just a set of free coercion+variables, because during typechecking those coercions might contain coercion+holes `HoleCo`, which get filled in later.+-}++{- **********************************************************************+%*                                                                      *+                Coercion holes+%*                                                                      *+%********************************************************************* -}+ -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole   = CoercionHole { ch_co_var  :: CoVar                        -- See Note [CoercionHoles and coercion free variables] -                 , ch_ref     :: IORef (Maybe Coercion)+                 , ch_ref :: IORef (Maybe Coercion)                  }  coHoleCoVar :: CoercionHole -> CoVar@@ -1582,19 +1673,7 @@ instance Uniquable CoercionHole where   getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv -{- Note [Phantom coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-     data T a = T1 | T2-Then we have-     T s ~R T t-for any old s,t. The witness for this is (TyConAppCo T Rep co),-where (co :: s ~P t) is a phantom coercion built with PhantomProv.-The role of the UnivCo is always Phantom.  The Coercion stored is the-(nominal) kind coercion between the types-   kind(s) ~N kind (t)--Note [Coercion holes]+{- Note [Coercion holes] ~~~~~~~~~~~~~~~~~~~~~~~~ During typechecking, constraint solving for type classes works by   - Generate an evidence Id,  d7 :: Num a@@ -1669,40 +1748,10 @@ Here co2 is a CoercionHole. But we /must/ know that it is free in co1, because that's all that stops it floating outside the implication.---Note [ProofIrrelProv]-~~~~~~~~~~~~~~~~~~~~~-A ProofIrrelProv is a coercion between coercions. For example:--  data G a where-    MkG :: G Bool--In core, we get--  G :: * -> *-  MkG :: forall (a :: *). (a ~ Bool) -> G a--Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want-a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be--  TyConAppCo Nominal MkG [co3, co4]-  where-    co3 :: co1 ~ co2-    co4 :: a1 ~ a2--Note that-  co1 :: a1 ~ Bool-  co2 :: a2 ~ Bool--Here,-  co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2)-  where-    co5 :: (a1 ~ Bool) ~ (a2 ~ Bool)-    co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>] -}  + {- ********************************************************************* *                                                                      *                 foldType  and   foldCoercion@@ -1759,7 +1808,6 @@                        | tv `elemVarSet` acc = acc                        | otherwise = acc `extendVarSet` tv - we want to end up with    fvs ty = go emptyVarSet ty emptyVarSet      where@@ -1789,6 +1837,38 @@ But, amazingly, we get good code here too. GHC is careful not to mark TyCoFolder data constructor for deep_tcf as a loop breaker, so the record selections still cancel.  And eta expansion still happens too.++Note [Use explicit recursion in foldTyCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In foldTyCo you'll see things like:+    go_tys _   []     = mempty+    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts+where we use /explicit recursion/.  You might wonder about using foldl instead:+    go_tys env = foldl (\t acc -> go_ty env t `mappend` acc) mempty+Or maybe foldl', or foldr.++But don't do that for two reasons (see #24591)++* We sometimes instantiate `a` to (Endo VarSet). Remembering+     newtype Endo a = Endo (a->a)+  after inlining `foldTyCo` bodily, the explicit recursion looks like+    go_tys _   []     = \acc -> acc+    go_tys env (t:ts) = \acc -> go_ty env t (go_tys env ts acc)+  The strictness analyser has no problem spotting that this function is+  strict in `acc`, provided `go_ty` is.++  But in the foldl form that is /much/ less obvious, and the strictness+  analyser fails utterly.  Result: lots and lots of thunks get built.  In+  !12037, Mikolaj found that GHC allocated /six times/ as much heap+  on test perf/compiler/T9198 as a result of this single problem!++* Second, while I think that using `foldr` would be fine (simple experiments in+  #24591 suggest as much), it builds a local loop (with env free) and I'm not 100%+  confident it'll be lambda lifted in the end. It seems more direct just to write+  the code we want.++  On the other hand in `go_cvs` we might hope that the `foldr` will fuse with the+  `dVarSetElems` so I have used `foldr`. -}  data TyCoFolder env a@@ -1827,12 +1907,11 @@       = let !env' = tycobinder env tv vis  -- Avoid building a thunk here         in go_ty env (varType tv) `mappend` go_ty env' inner -    -- Explicit recursion because using foldr builds a local-    -- loop (with env free) and I'm not confident it'll be-    -- lambda lifted in the end+    -- See Note [Use explicit recursion in foldTyCo]     go_tys _   []     = mempty     go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts +    -- See Note [Use explicit recursion in foldTyCo]     go_cos _   []     = mempty     go_cos env (c:cs) = go_co env c `mappend` go_cos env cs @@ -1842,13 +1921,13 @@     go_co env (TyConAppCo _ _ args)    = go_cos env args     go_co env (AppCo c1 c2)            = go_co env c1 `mappend` go_co env c2     go_co env (CoVarCo cv)             = covar env cv-    go_co env (AxiomInstCo _ _ args)   = go_cos env args+    go_co env (AxiomCo _ cos)          = go_cos env cos     go_co env (HoleCo hole)            = cohole env hole-    go_co env (UnivCo p _ t1 t2)       = go_prov env p `mappend` go_ty env t1-                                                       `mappend` go_ty env t2+    go_co env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                       = go_ty env t1 `mappend` go_ty env t2+                                         `mappend` go_cos env deps     go_co env (SymCo co)               = go_co env co     go_co env (TransCo c1 c2)          = go_co env c1 `mappend` go_co env c2-    go_co env (AxiomRuleCo _ cos)      = go_cos env cos     go_co env (SelCo _ co)             = go_co env co     go_co env (LRCo _ co)              = go_co env co     go_co env (InstCo co arg)          = go_co env co `mappend` go_co env arg@@ -1858,17 +1937,12 @@     go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })        = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2 -    go_co env (ForAllCo tv kind_co co)+    go_co env (ForAllCo tv _vis1 _vis2 kind_co co)       = go_co env kind_co `mappend` go_ty env (varType tv)                           `mappend` go_co env' co       where         env' = tycobinder env tv Inferred -    go_prov env (PhantomProv co)    = go_co env co-    go_prov env (ProofIrrelProv co) = go_co env co-    go_prov _   (PluginProv _)      = mempty-    go_prov _   (CorePrepProv _)    = mempty- -- | A view function that looks through nothing. noView :: Type -> Maybe Type noView _ = Nothing@@ -1893,28 +1967,34 @@ --     function is used only in reporting, not decision-making.  typeSize :: Type -> Int+-- The size of the syntax tree of a type.  No special treatment+-- for type synonyms or type families. typeSize (LitTy {})                 = 1 typeSize (TyVarTy {})               = 1 typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2 typeSize (FunTy _ _ t1 t2)          = typeSize t1 + typeSize t2 typeSize (ForAllTy (Bndr tv _) t)   = typeSize (varType tv) + typeSize t-typeSize (TyConApp _ ts)            = 1 + sum (map typeSize ts)+typeSize (TyConApp _ ts)            = 1 + typesSize ts typeSize (CastTy ty co)             = typeSize ty + coercionSize co typeSize (CoercionTy co)            = coercionSize co +typesSize :: [Type] -> Int+typesSize tys = foldr ((+) . typeSize) 0 tys+ coercionSize :: Coercion -> Int coercionSize (Refl ty)             = typeSize ty coercionSize (GRefl _ ty MRefl)    = typeSize ty coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (AppCo co arg)        = coercionSize co + coercionSize arg-coercionSize (ForAllCo _ h co)     = 1 + coercionSize co + coercionSize h+coercionSize (ForAllCo { fco_kind = h, fco_body = co })+                                   = 1 + coercionSize co + coercionSize h coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2                                                          + coercionSize w coercionSize (CoVarCo _)         = 1 coercionSize (HoleCo _)          = 1-coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)-coercionSize (UnivCo p _ t1 t2)  = 1 + provSize p + typeSize t1 + typeSize t2+coercionSize (AxiomCo _ cs)      = 1 + sum (map coercionSize cs)+coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 })  = 1 + typeSize t1 + typeSize t2 coercionSize (SymCo co)          = 1 + coercionSize co coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2 coercionSize (SelCo _ co)        = 1 + coercionSize co@@ -1922,13 +2002,6 @@ coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg coercionSize (KindCo co)         = 1 + coercionSize co coercionSize (SubCo co)          = 1 + coercionSize co-coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)--provSize :: UnivCoProvenance -> Int-provSize (PhantomProv co)    = 1 + coercionSize co-provSize (ProofIrrelProv co) = 1 + coercionSize co-provSize (PluginProv _)      = 1-provSize (CorePrepProv _)    = 1  {- ************************************************************************
compiler/GHC/Core/TyCo/Rep.hs-boot view
@@ -3,11 +3,13 @@  import GHC.Utils.Outputable ( Outputable ) import Data.Data  ( Data )-import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, ForAllTyFlag, FunTyFlag )+import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, FunTyFlag ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )+import Language.Haskell.Syntax.Specificity (ForAllTyFlag)  data Type data Coercion+data FunSel data CoSel data UnivCoProvenance data TyLit
compiler/GHC/Core/TyCo/Subst.hs view
@@ -5,7 +5,6 @@ -}  -{-# LANGUAGE BangPatterns #-}  -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst@@ -14,14 +13,14 @@         Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,         emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,         emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,-        mkSubst, 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,         extendCvSubst, extendCvSubstWithClone,-        extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone,+        extendTvSubst, extendTvSubstWithClone,         extendTvSubstList, extendTvSubstAndInScope,         extendTCvSubstList,         unionSubst, zipTyEnv, zipCoEnv,@@ -42,7 +41,7 @@         cloneTyVarBndr, cloneTyVarBndrs,         substVarBndr, substVarBndrs,         substTyVarBndr, substTyVarBndrs,-        substCoVarBndr,+        substCoVarBndr, substDCoVarSet,         substTyVar, substTyVars, substTyVarToTyVar,         substTyCoVars,         substTyCoBndr, substForAllCoBndr,@@ -58,12 +57,12 @@    ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo    , mkNomReflCo, mkSubCo, mkSymCo    , mkFunCo2, mkForAllCo, mkUnivCo-   , mkAxiomInstCo, mkAppCo, mkGReflCo+   , mkAxiomCo, mkAppCo, mkGReflCo    , mkInstCo, mkLRCo, mkTyConAppCo    , mkCoercionType-   , coercionKind, coercionLKind, coVarKindsTypesRole )+   , coercionLKind, coVarTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )-import {-# SOURCE #-} GHC.Core.Ppr ( )+import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr import {-# SOURCE #-} GHC.Core ( CoreExpr )  import GHC.Core.TyCo.Rep@@ -73,7 +72,6 @@ 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@@ -82,7 +80,6 @@ import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.List (mapAccumL) @@ -105,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@@ -116,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] @@ -184,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)@@ -208,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.@@ -272,9 +271,12 @@ isEmptyTCvSubst (Subst _ _ tv_env cv_env)   = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst-mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs+mkSubst :: InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst+mkSubst = Subst +mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst+mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs+ mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv @@ -296,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@@ -374,22 +376,15 @@   = assert (isTyVar tv) $     Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst-extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty-  = assert (isTyVar v )-    extendTvSubstAndInScope subst v ty-extendTvSubstBinderAndInScope subst (Anon {}) _-  = subst- extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst -- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone -- Does not look in the kind of the new variable; --   those variables should be in scope already extendTvSubstWithClone (Subst in_scope idenv tenv cenv) tv tv'   = Subst (extendInScopeSet in_scope tv')-             idenv-             (extendVarEnv tenv tv (mkTyVarTy tv'))-             cenv+          idenv+          (extendVarEnv tenv tv (mkTyVarTy tv'))+          cenv  -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': -- you must ensure that the in-scope set satisfies@@ -509,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 @@ -535,7 +530,8 @@ In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, how do we push sym into a ForAllCo? It's a little ugly. -Here is the typing rule:+Ignoring visibility, here is the typing rule+(see Note [ForAllCo] in GHC.Core.TyCo.Rep).  h : k1 ~# k2 (tv : k1) |- g : ty1 ~# ty2@@ -622,7 +618,7 @@ -- Pre-condition: the 'in_scope' set should satisfy Note [The substitution -- invariant]; specifically it should include the free vars of 'tys', -- and of 'ty' minus the domain of the subst.-substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type+substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty =   assert (tvs `equalLength` tys )   substTy (mkTvSubst in_scope tenv) ty@@ -650,12 +646,12 @@ substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)  -- | Type substitution, see 'zipTvSubst'-substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]+substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type] substTysWith tvs tys = assert (tvs `equalLength` tys )                        substTys (zipTvSubst tvs tys)  -- | Type substitution, see 'zipTvSubst'-substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]+substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type] substTysWithCoVars cvs cos = assert (cvs `equalLength` cos )                              substTys (zipCvSubst cvs cos) @@ -663,7 +659,7 @@ -- to the in-scope set. This is useful for the case when the free variables -- aren't already in the in-scope set or easily available. -- See also Note [The substitution invariant].-substTyAddInScope :: Subst -> Type -> Type+substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type substTyAddInScope subst ty =   substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty @@ -715,7 +711,7 @@ -- Note [The substitution invariant]. substTy :: HasDebugCallStack => Subst -> Type  -> Type substTy subst ty-  | isEmptyTCvSubst    subst = ty+  | isEmptyTCvSubst subst = ty   | otherwise             = checkValidSubst subst [ty] [] $                             subst_ty subst ty @@ -726,8 +722,8 @@ -- substTy and remove this function. Please don't use in new code. substTyUnchecked :: Subst -> Type -> Type substTyUnchecked subst ty-                 | isEmptyTCvSubst subst    = ty-                 | otherwise             = subst_ty subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = subst_ty subst ty  substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty@@ -820,7 +816,7 @@       Nothing -> TyVarTy tv  substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar--- Apply the substitution, expecing the result to be a TyVarTy+-- Apply the substitution, expecting the result to be a TyVarTy substTyVarToTyVar (Subst _ _ tenv _) tv   = assert (isTyVar tv) $     case lookupVarEnv tenv tv of@@ -886,18 +882,19 @@     go :: Coercion -> Coercion     go (Refl ty)             = mkNomReflCo $! (go_ty ty)     go (GRefl r ty mco)      = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco)-    go (TyConAppCo r tc args)= let args' = map go args-                               in  args' `seqList` mkTyConAppCo r tc args'+    go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args+    go (AxiomCo con cos)     = mkAxiomCo con $! go_cos cos     go (AppCo co arg)        = (mkAppCo $! go co) $! go arg-    go (ForAllCo tv kind_co co)+    go (ForAllCo tv visL visR kind_co co)       = case substForAllCoBndrUnchecked subst tv kind_co of          (subst', tv', kind_co') ->-          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co+          ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co     go (FunCo r afl afr w co1 co2)   = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2     go (CoVarCo cv)          = substCoVar subst cv-    go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos-    go (UnivCo p r t1 t2)    = (((mkUnivCo $! go_prov p) $! r) $!-                                (go_ty t1)) $! (go_ty t2)+    go (UnivCo { uco_prov = p, uco_role = r+               , uco_lty = t1, uco_rty = t2, uco_deps = deps })+                             = ((((mkUnivCo $! p) $! go_cos deps) $! r) $!+                                  (go_ty t1)) $! (go_ty t2)     go (SymCo co)            = mkSymCo $! (go co)     go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)     go (SelCo d co)          = mkSelCo d $! (go co)@@ -905,23 +902,25 @@     go (InstCo co arg)       = (mkInstCo $! (go co)) $! go arg     go (KindCo co)           = mkKindCo $! (go co)     go (SubCo co)            = mkSubCo $! (go co)-    go (AxiomRuleCo c cs)    = let cs1 = map go cs-                                in cs1 `seqList` AxiomRuleCo c cs1     go (HoleCo h)            = HoleCo $! go_hole h -    go_prov (PhantomProv kco)    = PhantomProv (go kco)-    go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)-    go_prov p@(PluginProv _)     = p-    go_prov p@(CorePrepProv _)   = p+    go_cos cos = let cos' = map go cos+                 in cos' `seqList` cos'      -- See Note [Substituting in a coercion hole]     go_hole h@(CoercionHole { ch_co_var = cv })       = h { ch_co_var = updateVarType go_ty cv } +-- | Perform a substitution within a 'DVarSet' of free variables,+-- returning the shallow free coercion variables.+substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet+substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $+                           dVarSetElems cvs+ substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion                   -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst-  = substForAllCoBndrUsing False (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@@ -931,29 +930,25 @@ substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion                            -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst-  = substForAllCoBndrUsing False (substCoUnchecked subst) subst+  = substForAllCoBndrUsing (substCoUnchecked subst) subst  -- See Note [Sym and ForAllCo]-substForAllCoBndrUsing :: Bool  -- 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 :: Bool  -- 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 && not sym = delVarEnv tenv old_var-            | sym       = extendVarEnv tenv old_var $-                          TyVarTy new_var `CastTy` new_kind_co+    new_env | no_change = delVarEnv tenv old_var             | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)      no_kind_change = noFreeVarsOfCo old_kind_co@@ -970,17 +965,16 @@      new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1) -substForAllCoCoVarBndrUsing :: Bool  -- 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 && not sym = delVarEnv cenv old_var+    new_cenv | no_change = delVarEnv cenv old_var              | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)      no_kind_change = noFreeVarsOfCo old_kind_co@@ -989,11 +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  | sym       = h2-                  | otherwise = h1+    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@@ -1091,7 +1082,7 @@     new_var = uniqAway in_scope subst_old_var     subst_old_var = mkCoVar (varName old_var) new_var_type -    (_, _, t1, t2, role) = coVarKindsTypesRole old_var+    (t1, t2, role) = coVarTypesRole old_var     t1' = subst_fn subst t1     t2' = subst_fn subst t2     new_var_type = mkCoercionType role t1' t2'
compiler/GHC/Core/TyCo/Tidy.hs view
@@ -1,26 +1,27 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- -- | Tidying types and coercions for printing in error messages. module GHC.Core.TyCo.Tidy   (         -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,-        tidyOpenTyCoVar, tidyOpenTyCoVars,-        tidyTyCoVarOcc,+        tidyType, tidyTypes,+        tidyCo,   tidyCos,         tidyTopType,-        tidyCo, tidyCos,-        tidyForAllTyBinder, tidyForAllTyBinders++        tidyOpenType,  tidyOpenTypes,+        tidyOpenTypeX, tidyOpenTypesX,+        tidyFreeTyCoVars, tidyFreeTyCoVarX, tidyFreeTyCoVarsX,++        tidyAvoiding,+        tidyVarBndr, tidyVarBndrs, avoidNameClashes,+        tidyForAllTyBinder, tidyForAllTyBinders,+        tidyTyCoVarOcc   ) where  import GHC.Prelude import GHC.Data.FastString +import GHC.Core.Predicate( scopedSort ) import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList)-+import GHC.Core.TyCo.FVs import GHC.Types.Name hiding (varName) import GHC.Types.Var import GHC.Types.Var.Env@@ -28,12 +29,76 @@  import Data.List (mapAccumL) -{--%************************************************************************-%*                                                                      *-\subsection{TidyType}-%*                                                                      *-%************************************************************************+{- **********************************************************************++                  TidyType++********************************************************************** -}++{- Note [Tidying open types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When tidying some open types [t1,..,tn], we find their free vars, and tidy them first.++But (tricky point) we restrict the occ_env part of inner_env to just the /free/+vars of [t1..tn], so that we don't gratuitously rename the /bound/ variables.++Example: assume the TidyEnv+      ({"a1","b"} , [a_4 :-> a1, b_7 :-> b])+and call tidyOpenTypes on+      [a_1, forall a_2. Maybe (a_2,a_4), forall b. (b,a_1)]+All the a's have the same OccName, but different uniques.++The TidyOccEnv binding for "b" relates b_7, which doesn't appear free in the+these types at all, so we don't want that to mess up the tidying for the+(forall b...).++So we proceed as follows:+  1. Find the free vars.+     In our example:the free vars are a_1 and a_4:++  2. Use tidyFreeTyCoVars to tidy them (workhorse: `tidyFreeCoVarX`)+     In our example:+      * a_4 already has a tidy form, a1, so don't change that+      * a_1 gets tidied to a2++  3. Trim the TidyOccEnv to OccNames of the tidied free vars (`trimTidyEnv`)+     In our example "a1" and "a2"++  4. Now tidy the types.  In our example we get+      [a2, forall a3. Maybe (a3,a1), forall b. (b, a2)]++Note [Tidying is idempotent]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Key invariant: tidyFreeTyCoVars is idempotent, at least if you start with+an empty TidyEnv. This is important because:++  * The typechecker error message processing carefully tidies types, using+    global knowledge; see for example calls to `tidyCt` in GHC.Tc.Errors.++  * Then the type pretty-printer, GHC.Core.TyCo.Ppr.pprType tidies the type+    again, because that's important for pretty-printing types in general.++But the second tidying is a no-op if the first step has happened, because+all the free vars will have distinct OccNames, so no renaming needs to happen.++Note [tidyAvoiding]+~~~~~~~~~~~~~~~~~~~+Consider tidying this unsolved constraint in GHC.Tc.Errors.report_unsolved.+    C a_33, (forall a. Eq a => D a)+Here a_33 is a free unification variable.  If we firs tidy [a_33 :-> "a"]+then we have no choice but to tidy the `forall a` to something else. But it+is confusing (sometimes very confusing) to gratuitously rename skolems in+this way -- see #24868.  So it is better to :++  * Find the /bound/ skolems (just `a` in this case)+  * Initialise the TidyOccEnv to avoid using "a"+  * Now tidy the free a_33 to, say, "a1"+  * Delete "a" from the TidyOccEnv++This is done by `tidyAvoiding`.++The last step is very important; if we leave "a" in the TidyOccEnv, when+we get to the (forall a. blah) we'll rename `a` to "a2", avoiding "a". -}  -- | This tidies up a type for printing in an error message, or in@@ -94,31 +159,38 @@ tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv -- ^ Add the free 'TyVar's to the env in tidy form, -- so that we can tidy the type they are free in-tidyFreeTyCoVars tidy_env tyvars-  = fst (tidyOpenTyCoVars tidy_env tyvars)+-- Precondition: input free vars are closed over kinds and+-- This function does a scopedSort, so that tidied variables+-- have tidied kinds.+-- See Note [Tidying is idempotent]+tidyFreeTyCoVars tidy_env tyvars = fst (tidyFreeTyCoVarsX tidy_env tyvars)  ----------------tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])-tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars+tidyFreeTyCoVarsX :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+-- Precondition: input free vars are closed over kinds and+-- This function does a scopedSort, so that tidied variables+-- have tidied kinds.+-- See Note [Tidying is idempotent]+tidyFreeTyCoVarsX env tyvars = mapAccumL tidyFreeTyCoVarX env $+                               scopedSort tyvars  ----------------tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+tidyFreeTyCoVarX :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name -- using the environment if one has not already been allocated. See -- also 'tidyVarBndr'-tidyOpenTyCoVar env@(_, subst) tyvar+-- See Note [Tidying is idempotent]+tidyFreeTyCoVarX env@(_, subst) tyvar   = case lookupVarEnv subst tyvar of-        Just tyvar' -> (env, tyvar')              -- Already substituted-        Nothing     ->-          let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))-          in tidyVarBndr env' tyvar  -- Treat it as a binder+        Just tyvar' -> (env, tyvar')           -- Already substituted+        Nothing     -> tidyVarBndr env tyvar  -- Treat it as a binder  --------------- tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar-tidyTyCoVarOcc env@(_, subst) tv-  = case lookupVarEnv subst tv of-        Nothing  -> updateVarType (tidyType env) tv-        Just tv' -> tv'+tidyTyCoVarOcc env@(_, subst) tcv+  = case lookupVarEnv subst tcv of+        Nothing   -> updateVarType (tidyType env) tcv+        Just tcv' -> tcv'  --------------- @@ -156,23 +228,27 @@ -- -- See Note [Strictness in tidyType and friends] tidyType :: TidyEnv -> Type -> Type-tidyType _   t@(LitTy {})          = t -- Preserve sharing-tidyType env (TyVarTy tv)          = TyVarTy $! tidyTyCoVarOcc env tv-tidyType _   t@(TyConApp _ [])     = t -- Preserve sharing if possible-tidyType env (TyConApp tycon tys)  = TyConApp tycon $! tidyTypes env tys-tidyType env (AppTy fun arg)       = (AppTy $! (tidyType env fun)) $! (tidyType env arg)-tidyType env ty@(FunTy _ w arg res)  = let { !w'   = tidyType env w-                                           ; !arg' = tidyType env arg-                                           ; !res' = tidyType env res }-                                       in ty { ft_mult = w', ft_arg = arg', ft_res = res' }-tidyType env (ty@(ForAllTy{}))     = (mkForAllTys' $! (zip tvs' vis)) $! tidyType env' body_ty-  where-    (tvs, vis, body_ty) = splitForAllTyCoVars' ty-    (env', tvs') = tidyVarBndrs env tvs-tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)-tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)+tidyType _   t@(LitTy {})           = t -- Preserve sharing+tidyType env (TyVarTy tv)           = TyVarTy $! tidyTyCoVarOcc env tv+tidyType _   t@(TyConApp _ [])      = t -- Preserve sharing if possible+tidyType env (TyConApp tycon tys)   = TyConApp tycon $! tidyTypes env tys+tidyType env (AppTy fun arg)        = (AppTy $! (tidyType env fun)) $! (tidyType env arg)+tidyType env (CastTy ty co)         = (CastTy $! tidyType env ty) $! (tidyCo env co)+tidyType env (CoercionTy co)        = CoercionTy $! (tidyCo env co)+tidyType env ty@(FunTy _ w arg res) = let { !w'   = tidyType env w+                                          ; !arg' = tidyType env arg+                                          ; !res' = tidyType env res }+                                      in ty { ft_mult = w', ft_arg = arg', ft_res = res' }+tidyType env (ty@(ForAllTy{}))      = tidyForAllType env ty  +tidyForAllType :: TidyEnv -> Type -> Type+tidyForAllType env ty+   = (mkForAllTys' $! (zip tcvs' vis)) $! tidyType body_env body_ty+  where+    (tcvs, vis, body_ty) = splitForAllTyCoVars' ty+    (body_env, tcvs') = tidyVarBndrs env tcvs+ -- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that -- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but -- how should they be named?@@ -189,25 +265,54 @@   ---------------+tidyAvoiding :: [OccName]+             -> (TidyEnv -> a -> TidyEnv)+             -> a -> TidyEnv+-- Initialise an empty TidyEnv with some bound vars to avoid,+-- run the do_tidy function, and then remove the bound vars again.+-- See Note [tidyAvoiding]+tidyAvoiding bound_var_avoids do_tidy thing+  = (occs' `delTidyOccEnvList` bound_var_avoids, vars')+  where+    (occs', vars') = do_tidy init_tidy_env thing+    init_tidy_env  = mkEmptyTidyEnv (initTidyOccEnv bound_var_avoids)++---------------+trimTidyEnv :: TidyEnv -> [TyCoVar] -> TidyEnv+trimTidyEnv (occ_env, var_env) tcvs+  = (trimTidyOccEnv occ_env (map getOccName tcvs), var_env)++--------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself-tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])-tidyOpenTypes env tys-  = (env', tidyTypes (trimmed_occ_env, var_env) tys)+tidyOpenTypesX :: TidyEnv -> [Type] -> (TidyEnv, [Type])+-- See Note [Tidying open types]+tidyOpenTypesX env tys+  = (env1, tidyTypes inner_env tys)   where-    (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $-                                tyCoVarsOfTypesWellScoped tys-    trimmed_occ_env = initTidyOccEnv (map getOccName tvs')-      -- The idea here was that we restrict the new TidyEnv to the-      -- _free_ vars of the types, so that we don't gratuitously rename-      -- the _bound_ variables of the types.+    free_tcvs :: [TyCoVar] -- Closed over kinds+    free_tcvs          = tyCoVarsOfTypesList tys+    (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs+    inner_env          = trimTidyEnv env1 free_tcvs'  ----------------tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)-tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in-                      (env', ty')+tidyOpenTypeX :: TidyEnv -> Type -> (TidyEnv, Type)+-- See Note [Tidying open types]+tidyOpenTypeX env ty+  = (env1, tidyType inner_env ty)+  where+    free_tcvs          = tyCoVarsOfTypeList ty+    (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs+    inner_env          = trimTidyEnv env1 free_tcvs'  ---------------+tidyOpenTypes :: TidyEnv -> [Type] -> [Type]+tidyOpenTypes env ty = snd (tidyOpenTypesX env ty)++tidyOpenType :: TidyEnv -> Type -> Type+tidyOpenType env ty = snd (tidyOpenTypeX env ty)++--------------- -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty@@ -218,7 +323,7 @@ -- -- See Note [Strictness in tidyType and friends] tidyCo :: TidyEnv -> Coercion -> Coercion-tidyCo env@(_, subst) co+tidyCo env co   = go co   where     go_mco MRefl    = MRefl@@ -228,18 +333,20 @@     go (GRefl r ty mco)      = (GRefl r $! tidyType env ty) $! go_mco mco     go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2-    go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)-                               where (envp, tvp) = tidyVarBndr env tv+    go (ForAllCo tv visL visR h co)+      = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)+      where (envp, tvp) = tidyVarBndr env tv             -- the case above duplicates a bit of work in tidying h and the kind             -- of tv. But the alternative is to use coercionKind, which seems worse.     go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2-    go (CoVarCo cv)          = case lookupVarEnv subst cv of-                                 Nothing  -> CoVarCo cv-                                 Just cv' -> CoVarCo cv'-    go (HoleCo h)            = HoleCo h-    go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos-    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!-                                tidyType env t1) $! tidyType env t2+    go (CoVarCo cv)          = CoVarCo $! go_cv cv+    go (HoleCo h)            = HoleCo $! go_hole h+    go (AxiomCo ax cos)      = AxiomCo ax $ strictMap go cos+    go (UnivCo prov role t1 t2 cos)+                             = ((UnivCo prov role+                                $! tidyType env t1)+                                $! tidyType env t2)+                                $! strictMap go cos     go (SymCo co)            = SymCo $! go co     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2     go (SelCo d co)          = SelCo d $! go co@@ -247,12 +354,11 @@     go (InstCo co ty)        = (InstCo $! go co) $! go ty     go (KindCo co)           = KindCo $! go co     go (SubCo co)            = SubCo $! go co-    go (AxiomRuleCo ax cos)  = AxiomRuleCo ax $ strictMap go cos -    go_prov (PhantomProv co)    = PhantomProv $! go co-    go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co-    go_prov p@(PluginProv _)    = p-    go_prov p@(CorePrepProv _)  = p+    go_cv cv = tidyTyCoVarOcc env cv++    go_hole (CoercionHole cv r) = (CoercionHole $! go_cv cv) r+    -- Tidy even the holes; tidied types should have tidied kinds  tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env)
compiler/GHC/Core/TyCon.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE LambdaCase         #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -20,12 +19,14 @@         PromDataConInfo(..), TyConFlavour(..),          -- * TyConBinder-        TyConBinder, TyConBndrVis(..), TyConPiTyBinder,+        TyConBinder, TyConBndrVis(..),         mkNamedTyConBinder, mkNamedTyConBinders,         mkRequiredTyConBinder,-        mkAnonTyConBinder, mkAnonTyConBinders, mkInvisAnonTyConBinder,+        mkAnonTyConBinder, mkAnonTyConBinders,         tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder,-        isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis,+        isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder,+        isInferredTyConBinder,+        isVisibleTcbVis, isInvisSpecTcbVis,          -- ** Field labels         tyConFieldLabels, lookupTyConFieldLabel,@@ -45,8 +46,9 @@         noTcTyConScopedTyVars,          -- ** Predicates on TyCons-        isAlgTyCon, isVanillaAlgTyCon,-        isClassTyCon, isFamInstTyCon,+        isAlgTyCon, isVanillaAlgTyCon, isClassTyCon,+        isUnaryClassTyCon, isUnaryClassTyCon_maybe,+        isFamInstTyCon,         isPrimTyCon,         isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,         isUnboxedSumTyCon, isPromotedTupleTyCon,@@ -55,10 +57,10 @@         tyConMustBeSaturated,         isPromotedDataCon, isPromotedDataCon_maybe,         isDataKindsPromotedDataCon,-        isKindTyCon, isLiftedTypeKindTyConName,+        isKindTyCon, isKindName, isLiftedTypeKindTyConName,         isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, -        isDataTyCon,+        isBoxedDataTyCon,         isTypeDataTyCon,         isEnumerationTyCon,         isNewTyCon, isAbstractTyCon,@@ -67,13 +69,14 @@         isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,         tyConInjectivityInfo,         isBuiltInSynFamTyCon_maybe,-        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,+        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon,         isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,         isImplicitTyCon,         isTyConWithSrcDataCons,         isTcTyCon, setTcTyConKind,         tcHasFixedRuntimeRep,         isConcreteTyCon,+        isValidDTT2TyCon,          -- ** Extracting information out of TyCons         tyConName,@@ -84,8 +87,6 @@         tyConCType_maybe,         tyConDataCons, tyConDataCons_maybe,         tyConSingleDataCon_maybe, tyConSingleDataCon,-        tyConAlgDataCons_maybe,-        tyConSingleAlgDataCon_maybe,         tyConFamilySize,         tyConStupidTheta,         tyConArity,@@ -123,11 +124,12 @@         tyConRepModOcc,          -- * Primitive representations of Types-        PrimRep(..), PrimElemRep(..),+        PrimRep(..), PrimElemRep(..), Levity(..),+        PrimOrVoidRep(..),         primElemRepToPrimRep,-        isVoidRep, isGcPtrRep,-        primRepSizeB,-        primElemRepSizeB,+        isGcPtrRep,+        primRepSizeB, primRepSizeW64_B,+        primElemRepSizeB, primElemRepSizeW64_B,         primRepIsFloat,         primRepsCompatible,         primRepCompatible,@@ -172,13 +174,13 @@ import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants import GHC.Utils.Misc import GHC.Types.Unique.Set import GHC.Unit.Module+import Control.DeepSeq  import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -194,7 +196,7 @@ * Type synonym families, also known as "type functions", map directly   onto the type functions in FC: -        type family F a :: *+        type family F a :: Type         type instance F Int = Bool         ..etc... @@ -210,11 +212,11 @@         type instance F (F Int) = ...   -- BAD!  * Translation of type family decl:-        type family F a :: *+        type family F a :: Type   translates to     a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon -        type family G a :: * where+        type family G a :: Type where           G Int = Bool           G Bool = Char           G a = ()@@ -229,7 +231,7 @@ See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make  * Data type families are declared thus-        data family T a :: *+        data family T a :: Type         data instance T Int = T1 | T2 Bool    Here T is the "family TyCon".@@ -321,7 +323,7 @@   should not think of a data family T as a *type function* at all, not   even an injective one!  We can't allow even injective type functions   on the LHS of a type function:-        type family injective G a :: *+        type family injective G a :: Type         type instance F (G Int) = Bool   is no good, even if G is injective, because consider         type instance G Int = Bool@@ -427,7 +429,7 @@  * [Injectivity annotation] in GHC.Hs.Decls  * [Renaming injectivity annotation] in GHC.Rename.Module  * [Verifying injectivity annotation] in GHC.Core.FamInstEnv- * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact+ * [Type inference for type families with injectivity] in GHC.Tc.Solver.Equality  Note [Sharing nullary TyConApps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -445,38 +447,29 @@  ************************************************************************ *                                                                      *-                    TyConBinder, TyConPiTyBinder+                    TyConBinder *                                                                      * ************************************************************************ -}  type TyConBinder     = VarBndr TyVar   TyConBndrVis-type TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis-     -- Only PromotedDataCon has TyConPiTyBinders-     -- See Note [Promoted GADT data constructors]  data TyConBndrVis-  = NamedTCB ForAllTyFlag-  | AnonTCB  FunTyFlag+  = NamedTCB ForAllTyFlag  -- ^ A named, forall-bound variable (invisible or not)+  | AnonTCB                -- ^ an ordinary, visible type argument  instance Outputable TyConBndrVis where   ppr (NamedTCB flag) = ppr flag-  ppr (AnonTCB af)    = ppr af+  ppr AnonTCB         = text "AnonTCB"  mkAnonTyConBinder :: TyVar -> TyConBinder -- Make a visible anonymous TyCon binder mkAnonTyConBinder tv = assert (isTyVar tv) $-                       Bndr tv (AnonTCB visArgTypeLike)+                       Bndr tv AnonTCB  mkAnonTyConBinders :: [TyVar] -> [TyConBinder] mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs -mkInvisAnonTyConBinder :: TyVar -> TyConBinder--- Make an /invisible/ anonymous TyCon binder--- Not used much-mkInvisAnonTyConBinder tv = assert (isTyVar tv) $-                            Bndr tv (AnonTCB invisArgTypeLike)- mkNamedTyConBinder :: ForAllTyFlag -> TyVar -> TyConBinder -- The odd argument order supports currying mkNamedTyConBinder vis tv = assert (isTyVar tv) $@@ -495,14 +488,12 @@   | 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-tyConBndrVisForAllTyFlag (NamedTCB vis)     = vis-tyConBndrVisForAllTyFlag (AnonTCB af)    -- See Note [AnonTCB with constraint arg]-  | isVisibleFunArg af = Required-  | otherwise          = Inferred+tyConBndrVisForAllTyFlag (NamedTCB vis) = vis+tyConBndrVisForAllTyFlag AnonTCB        = Required  isNamedTyConBinder :: TyConBinder -> Bool -- Identifies kind variables@@ -517,12 +508,28 @@  isVisibleTcbVis :: TyConBndrVis -> Bool isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis-isVisibleTcbVis (AnonTCB af)   = isVisibleFunArg af+isVisibleTcbVis AnonTCB        = True +isInvisSpecTcbVis :: TyConBndrVis -> Bool+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@@ -530,7 +537,7 @@   where     mk :: TyConBinder -> Kind -> Kind     mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k-    mk (Bndr tv (AnonTCB af))   k = mkNakedFunTy af (varType tv) k+    mk (Bndr tv AnonTCB)        k = mkNakedFunTy FTF_T_T (varType tv) k     -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types  -- | (mkTyConTy tc) returns (TyConApp tc [])@@ -549,9 +556,7 @@    mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv       where         vis = case tc_vis of-                AnonTCB af    -- Note [AnonTCB with constraint arg]-                  | isInvisibleFunArg af -> InferredSpec-                  | otherwise            -> SpecifiedSpec+                AnonTCB                  -> SpecifiedSpec                 NamedTCB Required        -> SpecifiedSpec                 NamedTCB (Invisible vis) -> vis @@ -561,35 +566,7 @@   = [ tv | Bndr tv vis <- tyConBinders tc          , isVisibleTcbVis vis ] -{- Note [AnonTCB with constraint arg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's pretty rare to have an (AnonTCB af) binder with af=FTF_C_T or FTF_C_C.-The only way it can occur is through equality constraints in kinds. These-can arise in one of two ways:--* In a PromotedDataCon whose kind has an equality constraint:--    'MkT :: forall a b. (a~b) => blah--  See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and-  Note [Promoted data constructors] in this module.--* In a data type whose kind has an equality constraint, as in the-  following example from #12102:--    data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type--When mapping an (AnonTCB FTF_C_x) to an ForAllTyFlag, in-tyConBndrVisForAllTyFlag, we use "Inferred" to mean "the user cannot-specify this arguments, even with visible type/kind application;-instead the type checker must fill it in.--We map (AnonTCB FTF_T_x) to Required, of course: the user must-provide it. It would be utterly wrong to do this for constraint-arguments, which is why AnonTCB must have the FunTyFlag in-the first place.--Note [Building TyVarBinders from TyConBinders]+{- Note [Building TyVarBinders from TyConBinders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes need to build the quantified type of a value from the TyConBinders of a type or class.  For that we need not@@ -613,21 +590,21 @@ information right; and that info is in the TyConBinders. Here is an example: -  data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *+  data App a b = MkApp (a b) -- App :: forall {k}. (k->Type) -> k -> Type  The TyCon has -  tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ]+  tyConTyBinders = [ Named (Bndr (k :: Type) Inferred), Anon (k->Type), Anon k ]  The TyConBinders for App line up with App's kind, given above.  But the DataCon MkApp has the type-  MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b+  MkApp :: forall {k} (a:k->Type) (b:k). a b -> App k a b  That is, its ForAllTyBinders should be -  dataConUnivTyVarBinders = [ Bndr (k:*)    Inferred-                            , Bndr (a:k->*) Specified+  dataConUnivTyVarBinders = [ Bndr (k:Type)    Inferred+                            , Bndr (a:k->Type) Specified                             , Bndr (b:k)    Specified ]  So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:@@ -635,17 +612,18 @@   - but changing Anon/Required to Specified  The last part about Required->Specified comes from this:-  data T k (a:k) b = MkT (a b)-Here k is Required in T's kind, but we don't have Required binders in-the PiTyBinders for a term (see Note [No Required PiTyBinder in terms]-in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's PiTyBinders+  data T k (a :: k) b = MkT (a b)+Here k is Required in T's kind, but we didn't have Required binders in+types of terms before the advent of the new, experimental RequiredTypeArguments+extension. So we historically changed Required to Specified when making MkT's PiTyBinders+and now continue to do so to avoid a breaking change. -}   {- Note [The binders/kind/arity fields of a TyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ All TyCons have this group of fields-  tyConBinders   :: [TyConBinder/TyConPiTyBinder]+  tyConBinders   :: [TyConBinder]   tyConResKind   :: Kind   tyConTyVars    :: [TyVar]   -- Cached = binderVars tyConBinders                               --   NB: Currently (Aug 2018), TyCons that own this@@ -656,13 +634,13 @@  They fit together like so: -* tyConBinders gives the telescope of type/coercion variables on the LHS of the+* tyConBinders gives the telescope of type variables on the LHS of the   type declaration.  For example:      type App a (b :: k) = a b -  tyConBinders = [ Bndr (k::*)   (NamedTCB Inferred)-                 , Bndr (a:k->*) AnonTCB+  tyConBinders = [ Bndr (k::Type)   (NamedTCB Inferred)+                 , Bndr (a:k->Type) AnonTCB                  , Bndr (b:k)    AnonTCB ]    Note that there are three binders here, including the@@ -673,17 +651,17 @@ * See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep   for what the visibility flag means. -* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and+* Each TyConBinder in tyConBinders has a TyVar, and   that TyVar may scope over some other part of the TyCon's definition. Eg       type T a = a -> a   we have-      tyConBinders = [ Bndr (a:*) AnonTCB ]+      tyConBinders = [ Bndr (a:Type) AnonTCB ]       synTcRhs     = a -> a   So the 'a' scopes over the synTcRhs  * From the tyConBinders and tyConResKind we can get the tyConKind   E.g for our App example:-      App :: forall k. (k->*) -> k -> *+      App :: forall k. (k->Type) -> k -> Type    We get a 'forall' in the kind for each NamedTCB, and an arrow   for each AnonTCB@@ -745,15 +723,20 @@   ppr (Bndr v bi) = ppr bi <+> parens (pprBndr LetBind v)  instance Binary TyConBndrVis where-  put_ bh (AnonTCB af)   = do { putByte bh 0; put_ bh af }+  put_ bh AnonTCB        = do { putByte bh 0 }   put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }    get bh = do { h <- getByte bh               ; case h of-                  0 -> do { af  <- get bh; return (AnonTCB af) }+                  0 -> return AnonTCB                   _ -> do { vis <- get bh; return (NamedTCB vis) } } +instance NFData TyConBndrVis where+  rnf AnonTCB        = ()+  rnf (NamedTCB vis) = rnf vis ++ {- ********************************************************************* *                                                                      *                The TyCon type@@ -766,15 +749,15 @@ -- things such as: -- -- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of---    kind @*@+--    kind @Type@ -- -- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor -- -- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor---    of kind @* -> *@+--    of kind @Type -> Type@ -- -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor---    of kind @*@+--    of kind @Constraint@ -- -- This data type also encodes a number of primitive, built in type constructors -- such as those for function and tuple types.@@ -874,11 +857,18 @@                                  --          any type synonym families (data families                                  --          are fine), again after expanding any                                  --          nested synonyms-        synIsForgetful :: Bool   -- True <=  at least one argument is not mentioned++        synIsForgetful :: Bool,  -- See Note [Forgetful type synonyms]+                                 -- True <=  at least one argument is not mentioned                                  --          in the RHS (or is mentioned only under                                  --          forgetful synonyms)                                  -- Test is conservative, so True does not guarantee-                                 -- forgetfulness.+                                 -- forgetfulness. False conveys definite information+                                 -- (definitely not forgetful); True is always safe.++        synIsConcrete :: Bool    -- True <= If 'tys' are concrete then the expansion+                                 --         of (S tys) is definitely concrete+                                 -- But False is always safe     }    -- | Represents families (both type and data)@@ -915,14 +905,17 @@     }    -- | Represents promoted data constructor.+  -- The kind of a promoted data constructor is the *wrapper* type of+  -- the original data constructor. This type must not have constraints+  -- (as checked in GHC.Tc.Gen.HsType.tcTyVar).   | PromotedDataCon {          -- See Note [Promoted data constructors]         dataCon       :: DataCon,   -- ^ Corresponding data constructor         tcRepName     :: TyConRepName,         promDcInfo    :: PromDataConInfo  -- ^ See comments with 'PromDataConInfo'     } -  -- | These exist only during type-checking. See Note [How TcTyCons work]-  -- in "GHC.Tc.TyCl"+  -- | These exist only during type-checking.+  -- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl"   | TcTyCon {           -- NB: the tyConArity of a TcTyCon must match           -- the number of Required (positional, user-specified)@@ -937,7 +930,7 @@         tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized?                               -- Used only to make zonking more efficient -        tctc_flavour :: TyConFlavour+        tctc_flavour :: TyConFlavour TyCon                            -- ^ What sort of 'TyCon' this represents.       } @@ -956,18 +949,7 @@    * tyConArity = length required_tvs  tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons.-See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType.--Note [Promoted GADT data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Any promoted GADT data constructor will have a type with equality-constraints in its type; e.g.-    K :: forall a b. (a ~# [b]) => a -> b -> T a--So, when promoted to become a type constructor, the tyConBinders-will include CoVars.  That is why we use [TyConPiTyBinder] for the-tyconBinders field.  TyConPiTyBinder is a synonym for TyConBinder,-but with the clue that the binder can be a CoVar not just a TyVar.+See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl  Note [Representation-polymorphic TyCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1149,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) @@ -1204,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@@ -1226,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@@ -1301,16 +1291,16 @@     --     -- These are introduced by either a top level declaration:     ---    -- > data family T a :: *+    -- > data family T a :: Type     --     -- Or an associated data type declaration, within a class declaration:     --     -- > class C a b where-    -- >   data T b :: *+    -- >   data T b :: Type      DataFamilyTyCon        TyConRepName -     -- | An open type synonym family  e.g. @type family F x y :: * -> *@+     -- | An open type synonym family  e.g. @type family F x y :: Type -> Type@    | OpenSynFamilyTyCon     -- | A closed type synonym family  e.g.@@ -1374,7 +1364,7 @@ Note [Enumeration types] ~~~~~~~~~~~~~~~~~~~~~~~~ We define datatypes with no constructors to *not* be-enumerations; this fixes trac #2578,  Otherwise we+enumerations; this fixes #2578,  Otherwise we end up generating an empty table for   <mod>_<type>_closure_tbl which is used by tagToEnum# to map Int# to constructors@@ -1444,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@@ -1568,14 +1746,16 @@  -} --- | A 'PrimRep' is an abstraction of a type.  It contains information that--- the code generator needs in order to pass arguments, return results,++-- | A 'PrimRep' is an abstraction of a /non-void/ type.+-- (Use 'PrimRepOrVoidRep' if you want void types too.)+-- It contains information that the code generator needs+-- in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep-  = VoidRep-  | LiftedRep-  | UnliftedRep   -- ^ Unlifted pointer+-- Unpacking of sum types is only supported since 9.6.1+  = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value   | Int32Rep      -- ^ Signed, 32-bit value@@ -1586,12 +1766,16 @@   | Word32Rep     -- ^ Unsigned, 32 bit value   | Word64Rep     -- ^ Unsigned, 64 bit value   | WordRep       -- ^ Unsigned, word-sized value-  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')+  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use 'BoxedRep')   | FloatRep   | DoubleRep   | VecRep Int PrimElemRep  -- ^ A vector   deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep+  -- See Note [VoidRep] in GHC.Types.RepType+  deriving (Data.Data, Eq, Ord, Show)+ data PrimElemRep   = Int8ElemRep   | Int16ElemRep@@ -1612,9 +1796,12 @@   ppr r = text (show r)  instance Binary PrimRep where-  put_ bh VoidRep        = putByte bh 0-  put_ bh LiftedRep      = putByte bh 1-  put_ bh UnliftedRep    = putByte bh 2+  put_ bh (BoxedRep ml)  = case ml of+    -- cheaper storage of the levity than using+    -- the Binary (Maybe Levity) instance+    Nothing       -> putByte bh 0+    Just Lifted   -> putByte bh 1+    Just Unlifted -> putByte bh 2   put_ bh Int8Rep        = putByte bh 3   put_ bh Int16Rep       = putByte bh 4   put_ bh Int32Rep       = putByte bh 5@@ -1632,9 +1819,9 @@   get  bh = do     h <- getByte bh     case h of-      0  -> pure VoidRep-      1  -> pure LiftedRep-      2  -> pure UnliftedRep+      0  -> pure $ BoxedRep Nothing+      1  -> pure $ BoxedRep (Just Lifted)+      2  -> pure $ BoxedRep (Just Unlifted)       3  -> pure Int8Rep       4  -> pure Int16Rep       5  -> pure Int32Rep@@ -1655,14 +1842,9 @@   put_ bh per = putByte bh (fromIntegral (fromEnum per))   get  bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool-isVoidRep VoidRep = True-isVoidRep _other  = False- isGcPtrRep :: PrimRep -> Bool-isGcPtrRep LiftedRep   = True-isGcPtrRep UnliftedRep = True-isGcPtrRep _           = False+isGcPtrRep (BoxedRep _) = True+isGcPtrRep _            = False  -- A PrimRep is compatible with another iff one can be coerced to the other. -- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.@@ -1703,14 +1885,41 @@    FloatRep         -> fLOAT_SIZE    DoubleRep        -> dOUBLE_SIZE    AddrRep          -> platformWordSizeInBytes platform-   LiftedRep        -> platformWordSizeInBytes platform-   UnliftedRep      -> platformWordSizeInBytes platform-   VoidRep          -> 0+   BoxedRep _       -> platformWordSizeInBytes platform    (VecRep len rep) -> len * primElemRepSizeB platform rep +-- | Like primRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primRepSizeW64_B :: PrimRep -> Int+primRepSizeW64_B = \case+   IntRep           -> 8+   WordRep          -> 8+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> 8+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> 8+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> 8+   BoxedRep{}       -> 8+   (VecRep len rep) -> len * primElemRepSizeW64_B rep+ primElemRepSizeB :: Platform -> PrimElemRep -> Int primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep +-- | Like primElemRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primElemRepSizeW64_B :: PrimElemRep -> Int+primElemRepSizeW64_B = primRepSizeW64_B . primElemRepToPrimRep+ primElemRepToPrimRep :: PrimElemRep -> PrimRep primElemRepToPrimRep Int8ElemRep   = Int8Rep primElemRepToPrimRep Int16ElemRep  = Int16Rep@@ -1886,15 +2095,13 @@ -- right-hand side. It lives only during the type-checking of a -- mutually-recursive group of tycons; it is then zonked to a proper -- TyCon in zonkTcTyCon.--- See also Note [Kind checking recursive type and class declarations]--- in "GHC.Tc.TyCl".+-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl" mkTcTyCon :: Name           -> [TyConBinder]           -> Kind                -- ^ /result/ kind only           -> [(Name,TcTyVar)]    -- ^ Scoped type variables;-                                 -- see Note [How TcTyCons work] in GHC.Tc.TyCl           -> Bool                -- ^ Is this TcTyCon generalised already?-          -> TyConFlavour        -- ^ What sort of 'TyCon' this represents+          -> TyConFlavour TyCon  -- ^ What sort of 'TyCon' this represents           -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav   = mkTyCon name binders res_kind (constRoles binders Nominal) $@@ -1906,7 +2113,7 @@ noTcTyConScopedTyVars :: [(Name, TcTyVar)] noTcTyConScopedTyVars = [] --- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld#@+-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld@ -- Primitive TyCons are marshalable iff not lifted. -- If you'd like to change this, modify marshalablePrimTyCon. mkPrimTyCon :: Name -> [TyConBinder]@@ -1922,13 +2129,17 @@  -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind-               -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful+               -> [Role] -> Type+               -> Bool -> Bool -> Bool -> Bool+               -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau+               is_fam_free is_forgetful is_concrete   = mkTyCon name binders res_kind roles $     SynonymTyCon { synTcRhs       = rhs                  , synIsTau       = is_tau                  , synIsFamFree   = is_fam_free-                 , synIsForgetful = is_forgetful }+                 , synIsForgetful = is_forgetful+                 , synIsConcrete  = is_concrete }  -- | Create a type family 'TyCon' mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind@@ -1946,7 +2157,7 @@ -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance mkPromotedDataCon :: DataCon -> Name -> TyConRepName-                  -> [TyConPiTyBinder] -> Kind -> [Role]+                  -> [TyConBinder] -> Kind -> [Role]                   -> PromDataConInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info   = mkTyCon name binders res_kind roles $@@ -1980,19 +2191,30 @@   | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True   | otherwise                                                = False -isDataTyCon :: TyCon -> Bool+-- | Returns @True@ if a boxed type headed by the given @TyCon@+-- satisfies condition DTT2 of Note [DataToTag overview] in+-- GHC.Tc.Instance.Class+isValidDTT2TyCon :: TyCon -> Bool+isValidDTT2TyCon = isBoxedDataTyCon++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 }@@ -2003,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.@@ -2018,32 +2241,46 @@ -- (where r is the role passed in): --   If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2) -- (where r1, r2, and r3, are the roles given by tyConRolesX tc r)--- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical"+-- 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 Note [How TcTyCons work] item (1) 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): --   If (T tys ~r t), then (t's head ~r T).--- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical"+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"+--+-- NB: at Nominal role, isGenerativeTyCon is simple:+--     isGenerativeTyCon tc Nominal+--       = not (isTypeFamilyTyCon tc || isSynonymTyCon tc) isGenerativeTyCon :: TyCon -> Role -> Bool isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role    = go role details@@ -2054,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 })@@ -2111,11 +2339,43 @@ -- True. Thus, False means that all bound variables appear on the RHS; -- True may not mean anything, as the test to set this flag is -- conservative.+--+-- See Note [Forgetful type synonyms] isForgetfulSynTyCon :: TyCon -> Bool isForgetfulSynTyCon (TyCon { tyConDetails = details })   | SynonymTyCon { synIsForgetful = forget } <- details = forget   | otherwise                                           = False +{- Note [Forgetful type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type synonyms is /forgetful/ if its RHS fails to mention one (or more) of its bound variables.++Forgetfulness is conservative:+  * A non-forgetful synonym /guarantees/ to mention all its bound variables in its RHS.+  * It is always safe to classify a synonym as forgetful.++Examples:+    type R = Int             -- Not forgetful+    type S a = Int           -- Forgetful+    type T1 a = Int -> S a   -- Forgetful+    type T2 a = a -> S a     -- Not forgetful+    type T3 a = Int -> F a   -- Not forgetful+      where type family F a++* R shows that nullary synonyms are not forgetful.++* T2 shows that forgetfulness needs to account for uses of forgetful+  synonyms. `a` appears on the RHS, but only under a forgetful S++* T3 shows that non-forgetfulness is not the same as injectivity. T3 mentions its+  bound variable on its RHS, but under a type family.  So it is entirely possible+  that    T3 Int ~ T3 Bool++* Since type synonyms are non-recursive, we don't need a fixpoint analysis to+  determine forgetfulness.  It's rather easy -- see `GHC.Core.Type.buildSynTyCon`,+  which is a bit over-conservative for over-saturated synonyms.+-}+ -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand.@@ -2145,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?@@ -2167,13 +2429,13 @@                   _                  -> False   | otherwise = False --- | Is this a synonym 'TyCon' that can have may have further instances appear?+-- | Is this a type family 'TyCon' (whether open or closed)? isTypeFamilyTyCon :: TyCon -> Bool isTypeFamilyTyCon (TyCon { tyConDetails = details })   | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav)   | otherwise                                   = False --- | Is this a synonym 'TyCon' that can have may have further instances appear?+-- | Is this a data family 'TyCon'? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (TyCon { tyConDetails = details })   | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav@@ -2194,14 +2456,14 @@  isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details })-  | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops } <- details = Just ops-  | otherwise                                                    = Nothing+  | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops} <- details = Just ops+  | otherwise                                                   = Nothing  -- | Extract type variable naming the result of injective type family tyConFamilyResVar_maybe :: TyCon -> Maybe Name tyConFamilyResVar_maybe (TyCon { tyConDetails = details })   | FamilyTyCon {famTcResVar = res} <- details = res-  | otherwise                                   = Nothing+  | otherwise                                  = Nothing  -- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is@@ -2227,12 +2489,6 @@ tyConAssoc_maybe :: TyCon -> Maybe TyCon tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour --- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour-tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon-tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent)     = mb_parent-tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent-tyConFlavourAssoc_maybe _                                 = Nothing- -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon@@ -2315,19 +2571,35 @@               = not (isTypeDataCon dc)   | otherwise = False --- | Is this tycon really meant for use at the kind level? That is,--- should it be permitted without -XDataKinds?+-- | Is this 'TyCon' really meant for use at the kind level? That is,+-- should it be permitted without @DataKinds@? isKindTyCon :: TyCon -> Bool-isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys+isKindTyCon = isKindUniquable +-- | This is 'Name' really meant for use at the kind level? That is,+-- should it be permitted wihout @DataKinds@?+isKindName :: Name -> Bool+isKindName = isKindUniquable++-- | The workhorse for 'isKindTyCon' and 'isKindName'.+isKindUniquable :: Uniquable a => a -> Bool+isKindUniquable thing = getUnique thing `memberUniqueSet` kindTyConKeys+ -- | These TyCons should be allowed at the kind level, even without -- -XDataKinds.-kindTyConKeys :: UniqSet Unique-kindTyConKeys = unionManyUniqSets-  ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ]-  : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon-                                          , multiplicityTyCon-                                          , vecCountTyCon, vecElemTyCon ] )+kindTyConKeys :: UniqueSet+kindTyConKeys = fromListUniqueSet $+  -- Make sure to keep this in sync with the following:+  --+  -- - The Overview section in docs/users_guide/exts/data_kinds.rst in the GHC+  --   User's Guide.+  --+  -- - The typecheck/should_compile/T22141f.hs test case, which ensures that all+  --   of these can successfully be used without DataKinds.+  [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey, cONSTRAINTTyConKey ]+  ++ concatMap tycon_with_datacons [ runtimeRepTyCon, levityTyCon+                                   , multiplicityTyCon+                                   , vecCountTyCon, vecElemTyCon ]   where     tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) @@ -2389,10 +2661,14 @@                -- the representation be fully-known, including levity variables.                -- This might be relaxed in the future (#15532). -       TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort)+       TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) ||+                                               -- (# #) also has fixed rep.+                                               tyConArity tc == 0         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)@@ -2403,30 +2679,24 @@   | TcTyCon{}         <- details = False   | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) --- | Is this 'TyCon' concrete (i.e. not a synonym/type family)?---+-- | Is this 'TyCon' concrete?+-- More specifically, if 'tys' are all concrete, is (T tys) concrete?+--      (for synonyms this requires us to look at the RHS) -- Used for representation polymorphism checks.+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete isConcreteTyCon :: TyCon -> Bool-isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour+isConcreteTyCon tc@(TyCon { tyConDetails = details })+  = case details of+      AlgTyCon {}        -> True   -- Includes AbstractTyCon+      PrimTyCon {}       -> True+      PromotedDataCon {} -> True+      FamilyTyCon {}     -> False --- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)?------ Used for representation polymorphism checks.-isConcreteTyConFlavour :: TyConFlavour -> Bool-isConcreteTyConFlavour = \case-  ClassFlavour             -> True-  TupleFlavour {}          -> True-  SumFlavour               -> True-  DataTypeFlavour          -> True-  NewtypeFlavour           -> True-  AbstractTypeFlavour      -> True  -- See Note [Concrete types] in GHC.Tc.Utils.Concrete-  DataFamilyFlavour {}     -> False-  OpenTypeFamilyFlavour {} -> False-  ClosedTypeFamilyFlavour  -> False-  TypeSynonymFlavour       -> False-  BuiltInTypeFlavour       -> True-  PromotedDataConFlavour   -> True+      SynonymTyCon { synIsConcrete = is_conc } -> is_conc +      TcTyCon {} -> pprPanic "isConcreteTyCon" (ppr tc)+                    -- isConcreteTyCon is only used on "real" tycons+ {- ----------------------------------------------- --      TcTyCon@@ -2530,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@@@ -2545,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@@ -2558,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@@ -2583,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)@@ -2646,6 +2902,7 @@ tyConStupidTheta tc@(TyCon { tyConDetails = details })   | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid   | PrimTyCon {} <- details                         = []+  | PromotedDataCon {} <- details                   = []   | otherwise = pprPanic "tyConStupidTheta" (ppr tc)  -- | Extract the 'TyVar's bound by a vanilla type synonym@@ -2671,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 })@@ -2774,43 +3047,7 @@                   then text "[tc]"                   else empty --- | Paints a picture of what a 'TyCon' represents, in broad strokes.--- This is used towards more informative error messages.-data TyConFlavour-  = ClassFlavour-  | TupleFlavour Boxity-  | SumFlavour-  | DataTypeFlavour-  | NewtypeFlavour-  | AbstractTypeFlavour-  | DataFamilyFlavour (Maybe TyCon)     -- Just tc <=> (tc == associated class)-  | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class)-  | ClosedTypeFamilyFlavour-  | TypeSynonymFlavour-  | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.-  | PromotedDataConFlavour-  deriving Eq--instance Outputable TyConFlavour where-  ppr = text . go-    where-      go ClassFlavour = "class"-      go (TupleFlavour boxed) | isBoxed boxed = "tuple"-                              | otherwise     = "unboxed tuple"-      go SumFlavour              = "unboxed sum"-      go DataTypeFlavour         = "data type"-      go NewtypeFlavour          = "newtype"-      go AbstractTypeFlavour     = "abstract type"-      go (DataFamilyFlavour (Just _))  = "associated data family"-      go (DataFamilyFlavour Nothing)   = "data family"-      go (OpenTypeFamilyFlavour (Just _)) = "associated type family"-      go (OpenTypeFamilyFlavour Nothing)  = "type family"-      go ClosedTypeFamilyFlavour = "type family"-      go TypeSynonymFlavour      = "type synonym"-      go BuiltInTypeFlavour      = "built-in type"-      go PromotedDataConFlavour  = "promoted data constructor"--tyConFlavour :: TyCon -> TyConFlavour+tyConFlavour :: TyCon -> TyConFlavour TyCon tyConFlavour (TyCon { tyConDetails = details })   | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details   = case parent of@@ -2821,12 +3058,13 @@                   SumTyCon {}        -> SumFlavour                   DataTyCon {}       -> DataTypeFlavour                   NewTyCon {}        -> NewtypeFlavour+                  UnaryClassTyCon {} -> ClassFlavour                   AbstractTyCon {}   -> AbstractTypeFlavour    | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details   = case flav of-      DataFamilyTyCon{}            -> DataFamilyFlavour parent-      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour parent+      DataFamilyTyCon{}            -> OpenFamilyFlavour (IAmData DataType) parent+      OpenSynFamilyTyCon           -> OpenFamilyFlavour IAmType parent       ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour       AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour       BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour@@ -2837,24 +3075,22 @@   | TcTyCon { tctc_flavour = flav } <-details   = flav  -- | Can this flavour of 'TyCon' appear unsaturated?-tcFlavourMustBeSaturated :: TyConFlavour -> Bool+tcFlavourMustBeSaturated :: TyConFlavour tc -> Bool tcFlavourMustBeSaturated ClassFlavour            = False tcFlavourMustBeSaturated DataTypeFlavour         = False tcFlavourMustBeSaturated NewtypeFlavour          = False-tcFlavourMustBeSaturated DataFamilyFlavour{}     = False tcFlavourMustBeSaturated TupleFlavour{}          = False tcFlavourMustBeSaturated SumFlavour              = False tcFlavourMustBeSaturated AbstractTypeFlavour {}  = False tcFlavourMustBeSaturated BuiltInTypeFlavour      = False tcFlavourMustBeSaturated PromotedDataConFlavour  = False+tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True } tcFlavourMustBeSaturated TypeSynonymFlavour      = True-tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True  -- | Is this flavour of 'TyCon' an open type family or a data family?-tcFlavourIsOpen :: TyConFlavour -> Bool-tcFlavourIsOpen DataFamilyFlavour{}     = True-tcFlavourIsOpen OpenTypeFamilyFlavour{} = True+tcFlavourIsOpen :: TyConFlavour tc -> Bool+tcFlavourIsOpen OpenFamilyFlavour{}     = True tcFlavourIsOpen ClosedTypeFamilyFlavour = False tcFlavourIsOpen ClassFlavour            = False tcFlavourIsOpen DataTypeFlavour         = False@@ -2896,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.hs-boot view
@@ -12,6 +12,7 @@  type TyConRepName = Name +isNewTyCon          :: TyCon -> Bool isTupleTyCon        :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool
compiler/GHC/Core/TyCon/Env.hs view
@@ -100,10 +100,10 @@ delFromTyConEnv x y      = delFromUFM x y delListFromTyConEnv x y  = delListFromUFM x y filterTyConEnv x y       = filterUFM x y-anyTyConEnv f x          = foldUFM ((||) . f) False x+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
@@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-}+{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Main functions for manipulating types and type-related things@@ -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,@@ -48,14 +48,14 @@          mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,         mkSpecForAllTy, mkSpecForAllTys,-        mkVisForAllTys, mkTyCoInvForAllTy,+        mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy,         mkInfForAllTy, mkInfForAllTys,         splitForAllTyCoVars, splitForAllTyVars,         splitForAllReqTyBinders, splitForAllInvisTyBinders,-        splitForAllForAllTyBinders,+        splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,         splitForAllTyCoVar_maybe, splitForAllTyCoVar,         splitForAllTyVar_maybe, splitForAllCoVar_maybe,-        splitPiTy_maybe, splitPiTy, splitPiTys,+        splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,         getRuntimeArgTys,         mkTyConBindersPreferAnon,         mkPiTy, mkPiTys,@@ -69,20 +69,18 @@         mkCharLitTy, isCharLitTy,         isLitTy, -        isPredTy,-         getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,         getLevity, levityType_maybe,          mkCastTy, mkCoercionTy, splitCastTy_maybe, -        userTypeError_maybe, pprUserTypeErrorTy,+        ErrorMsgType,+        userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy,          coAxNthLHS,         stripCoercionTy, -        splitInvisPiTys, splitInvisPiTysN,-        invisibleTyBndrCount,+        splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount,         filterOutInvisibleTypes, filterOutInferredTypes,         partitionInvisibleTypes, partitionInvisibles,         tyConForAllTyFlags, appTyForAllTyFlags,@@ -110,8 +108,9 @@         isTyVarTy, isFunTy, isCoercionTy,         isCoercionTy_maybe, isForAllTy,         isForAllTy_ty, isForAllTy_co,+        isForAllTy_invis_ty,         isPiTy, isTauTy, isFamFreeTy,-        isCoVarType, isAtomicTy,+        isAtomicTy,          isValidJoinPointType,         tyConAppNeedsKindSig,@@ -120,11 +119,11 @@         mkTYPEapp, mkTYPEapp_maybe,         mkCONSTRAINTapp, mkCONSTRAINTapp_maybe,         mkBoxedRepApp_maybe, mkTupleRepApp_maybe,-        typeOrConstraintKind,+        typeOrConstraintKind, liftedTypeOrConstraintKind,          -- *** Levity and boxity         sORTKind_maybe, typeTypeOrConstraint,-        typeLevity_maybe, tyConIsTYPEorCONSTRAINT,+        typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT,         isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,         isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,         isBoxedRuntimeRep,@@ -132,8 +131,9 @@         isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,         kindBoxedRepLevity_maybe,         mightBeLiftedType, mightBeUnliftedType,-        isAlgType, isDataFamilyAppType,-        isPrimitiveType, isStrictType,+        definitelyLiftedType, definitelyUnliftedType,+        isAlgType, isDataFamilyApp, isSatTyFamApp,+        isPrimitiveType, isStrictType, isTerminatingType,         isLevityTy, isLevityVar,         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,         dropRuntimeRepArgs,@@ -151,7 +151,7 @@         Kind,          -- ** Finding the kind of a type-        typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep,+        typeKind, typeHasFixedRuntimeRep,         tcIsLiftedTypeKind,         isConstraintKind, isConstraintLikeKind, returnsConstraintKind,         tcIsBoxedTypeKind, isTypeLikeKind,@@ -168,22 +168,18 @@          anyFreeVarsOfType, anyFreeVarsOfTypes,         noFreeVarsOfType,-        expandTypeSynonyms,+        expandTypeSynonyms, expandSynTyConApp_maybe,         typeSize, occCheckExpand,          -- ** Closing over kinds         closeOverKindsDSet, closeOverKindsList,         closeOverKinds, -        -- * Well-scoped lists of variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,-         -- * Forcing evaluation of types         seqType, seqTypes,          -- * Other views onto Types-        coreView,+        coreView, coreFullView, rewriterView,          tyConsOfType, @@ -195,15 +191,14 @@         -- ** Manipulating type substitutions         emptyTvSubstEnv, emptySubst, mkEmptySubst, -        mkSubst, zipTvSubst, mkTvSubstPrs,+        mkTCvSubst, zipTvSubst, mkTvSubstPrs,         zipTCvSubst,         notElemSubst,         getTvSubstEnv,-        zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs,+        zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs,         extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,         extendTCvSubst, extendCvSubst,-        extendTvSubst, extendTvSubstBinderAndInScope,-        extendTvSubstList, extendTvSubstAndInScope,+        extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,         extendTCvSubstList,         extendTvSubstWithClone,         extendTCvSubstWithClone,@@ -221,18 +216,10 @@         substTyCoBndr, substTyVarToTyVar,         cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -        -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,-        tidyOpenTyCoVar, tidyOpenTyCoVars,-        tidyTyCoVarOcc,-        tidyTopType,-        tidyForAllTyBinder, tidyForAllTyBinders,-         -- * Kinds         isTYPEorCONSTRAINT,-        isConcrete, isFixedRuntimeRepKind,+        isConcreteType,+        isFixedRuntimeRepKind     ) where  import GHC.Prelude@@ -244,14 +231,12 @@  import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs  -- friends: import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Types.Unique.Set  import GHC.Core.TyCon import GHC.Builtin.Types.Prim@@ -270,9 +255,9 @@ import {-# SOURCE #-} GHC.Core.Coercion    ( mkNomReflCo, mkGReflCo, mkReflCo    , mkTyConAppCo, mkAppCo-   , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo+   , mkForAllCo, mkFunCo2, mkAxiomCo, mkUnivCo    , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo-   , mkKindCo, mkSubCo, mkFunCo1+   , mkKindCo, mkSubCo, mkFunCo, funRole    , decomposePiCos, coercionKind    , coercionRKind, coercionType    , isReflexiveCo, seqCo@@ -285,11 +270,10 @@ import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString -import Control.Monad    ( guard )-import GHC.Data.Maybe   ( orElse, isJust )+import GHC.Data.Maybe   ( orElse, isJust, firstJust )+import GHC.List (build)  -- $type_classification -- #type_classification#@@ -360,6 +344,19 @@ ************************************************************************ -} +rewriterView :: Type -> Maybe Type+-- Unwrap a type synonym only when either:+--   The type synonym is forgetful, or+--   the type synonym mentions a type family in its expansion+-- See Note [Rewriting synonyms]+{-# INLINE rewriterView #-}+rewriterView (TyConApp tc tys)+  | isTypeSynonymTyCon tc+  , isForgetfulSynTyCon tc || not (isFamFreeTyCon tc)+  = expandSynTyConApp_maybe tc tys+rewriterView _other+  = Nothing+ coreView :: Type -> Maybe Type -- ^ This function strips off the /top layer only/ of a type synonym -- application (if any) its underlying representation type.@@ -401,7 +398,11 @@ expandSynTyConApp_maybe tc arg_tys   | Just (tvs, rhs) <- synTyConDefn_maybe tc   , arg_tys `saturates` tyConArity tc-  = Just (expand_syn tvs rhs arg_tys)+  = Just $! (expand_syn tvs rhs arg_tys)+    -- Why strict application? Because every client of this function will evaluat+    -- that (expand_syn ...) thunk, so it's more efficient not to build a thunk.+    -- Mind you, this function is always INLINEd, so the client context is probably+    -- enough to avoid thunk construction and so the $! is just belt-and-braces.   | otherwise   = Nothing @@ -410,7 +411,7 @@ saturates []      _ = False saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1)                        -- Arities are always positive; the assertion just checks-                       -- that, to avoid an ininite loop in the bad case+                       -- that, to avoid an infinite loop in the bad case  -- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path -- into call-sites.@@ -529,17 +530,18 @@       = mkTyConAppCo r tc (map (go_co subst) args)     go_co subst (AppCo co arg)       = mkAppCo (go_co subst co) (go_co subst arg)-    go_co subst (ForAllCo tv kind_co co)+    go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                          , fco_kind = kind_co, fco_body = co })       = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in-        mkForAllCo tv' kind_co' (go_co subst' co)+        mkForAllCo tv' visL visR kind_co' (go_co subst' co)     go_co subst (FunCo r afl afr w co1 co2)       = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2)     go_co subst (CoVarCo cv)       = substCoVar subst cv-    go_co subst (AxiomInstCo ax ind args)-      = mkAxiomInstCo ax ind (map (go_co subst) args)-    go_co subst (UnivCo p r t1 t2)-      = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2)+    go_co subst (AxiomCo ax cs)+      = mkAxiomCo ax (map (go_co subst) cs)+    go_co subst co@(UnivCo { uco_lty = lty, uco_rty = rty })+      = co { uco_lty = go subst lty, uco_rty = go subst rty }     go_co subst (SymCo co)       = mkSymCo (go_co subst co)     go_co subst (TransCo co1 co2)@@ -554,21 +556,10 @@       = mkKindCo (go_co subst co)     go_co subst (SubCo co)       = mkSubCo (go_co subst co)-    go_co subst (AxiomRuleCo ax cs)-      = AxiomRuleCo ax (map (go_co subst) cs)     go_co _ (HoleCo h)       = pprPanic "expandTypeSynonyms hit a hole" (ppr h) -    go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)-    go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)-    go_prov _     p@(PluginProv _)    = p-    go_prov _     p@(CorePrepProv _)  = p--      -- 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 False (go_co subst) subst+    go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst  {- Notes on type synonyms ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -686,8 +677,8 @@ --  * False of type variables, type family applications, --    and of other reps such as @IntRep :: RuntimeRep@. isLiftedRuntimeRep :: RuntimeRepType -> Bool-isLiftedRuntimeRep rep =-  runtimeRepLevity_maybe rep == Just Lifted+isLiftedRuntimeRep rep+  = runtimeRepLevity_maybe rep == Just Lifted  -- | Check whether a type of kind 'RuntimeRep' is unlifted. --@@ -770,7 +761,7 @@ -- expands to `Boxed lev` and returns `Nothing` otherwise. -- -- Types with this runtime rep are represented by pointers on the GC'd heap.-isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe Type+isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType isBoxedRuntimeRep_maybe rep   | Just (rr_tc, args) <- splitRuntimeRep_maybe rep   , rr_tc `hasKey` boxedRepDataConKey@@ -779,9 +770,10 @@   | otherwise   = Nothing --- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown.+-- | Check whether a type (usually of kind 'RuntimeRep') is lifted, unlifted,+--   or unknown.  Returns Nothing if the type isn't of kind 'RuntimeRep'. ----- `isLiftedRuntimeRep rr` returns:+-- `runtimeRepLevity_maybe rr` returns: -- --   * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep` --   * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep`@@ -793,7 +785,9 @@     if (rr_tc `hasKey` boxedRepDataConKey)     then case args of             [lev] -> levityType_maybe lev-            _     -> pprPanic "runtimeRepLevity_maybe" (ppr rep)+            _     -> Nothing  -- Type isn't of kind RuntimeRep+                     -- The latter case happens via the call to isLiftedRuntimeRep+                     -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742)     else Just Unlifted         -- Avoid searching all the unlifted RuntimeRep type cons         -- In the RuntimeRep data type, only LiftedRep is lifted@@ -804,7 +798,7 @@ --  Splitting Levity -------------------------------------------- --- | `levity_maybe` takes a Type of kind Levity, and returns its levity+-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity -- May not be possible for a type variable or type family application levityType_maybe :: LevityType -> Maybe Levity levityType_maybe lev@@ -827,7 +821,7 @@  Note [Efficiency for ForAllCo case of mapTyCoX] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant.+As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches the left-hand kind of the coercion. This is convenient lots of the time, but not when mapping a function over a coercion.@@ -867,7 +861,8 @@           -- ^ What to do with coercion holes.           -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". -      , tcm_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> m (env, TyCoVar)+      , tcm_tycobinder :: forall r. env -> TyCoVar -> ForAllTyFlag+                       -> (env -> TyCoVar -> m r) -> m r           -- ^ The returned env is used in the extended scope        , tcm_tycon :: TyCon -> m TyCon@@ -880,21 +875,22 @@  {-# INLINE mapTyCo #-}  -- See Note [Specialising mappers] mapTyCo :: Monad m => TyCoMapper () m-         -> ( Type       -> m Type-            , [Type]     -> m [Type]-            , Coercion   -> m Coercion-            , [Coercion] -> m[Coercion])+        -> ( Type       -> m  Type+           , [Type]     -> m  [Type]+           , Coercion   -> m  Coercion+           , [Coercion] -> m [Coercion] ) mapTyCo mapper   = case mapTyCoX mapper of      (go_ty, go_tys, go_co, go_cos)         -> (go_ty (), go_tys (), go_co (), go_cos ())  {-# INLINE mapTyCoX #-}  -- See Note [Specialising mappers]-mapTyCoX :: Monad m => TyCoMapper env m+mapTyCoX :: forall m env. Monad m+         => TyCoMapper env m          -> ( env -> Type       -> m Type             , env -> [Type]     -> m [Type]             , env -> Coercion   -> m Coercion-            , env -> [Coercion] -> m[Coercion])+            , env -> [Coercion] -> m [Coercion] ) mapTyCoX (TyCoMapper { tcm_tyvar = tyvar                      , tcm_tycobinder = tycobinder                      , tcm_tycon = tycon@@ -902,20 +898,21 @@                      , tcm_hole = cohole })   = (go_ty, go_tys, go_co, go_cos)   where-    go_tys _   []       = return []-    go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys+    -- See Note [Use explicit recursion in mapTyCo]+    go_tys !_   []       = return []+    go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys -    go_ty env (TyVarTy tv)    = tyvar env tv-    go_ty env (AppTy t1 t2)   = mkAppTy <$> go_ty env t1 <*> go_ty env t2-    go_ty _   ty@(LitTy {})   = return ty-    go_ty env (CastTy ty co)  = mkCastTy <$> go_ty env ty <*> go_co env co-    go_ty env (CoercionTy co) = CoercionTy <$> go_co env co+    go_ty !env (TyVarTy tv)    = tyvar env tv+    go_ty !env (AppTy t1 t2)   = mkAppTy <$> go_ty env t1 <*> go_ty env t2+    go_ty !_   ty@(LitTy {})   = return ty+    go_ty !env (CastTy ty co)  = mkCastTy <$> go_ty env ty <*> go_co env co+    go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co -    go_ty env ty@(FunTy _ w arg res)+    go_ty !env ty@(FunTy _ w arg res)       = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res            ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } -    go_ty env ty@(TyConApp tc tys)+    go_ty !env ty@(TyConApp tc tys)       | isTcTyCon tc       = do { tc' <- tycon tc            ; mkTyConApp tc' <$> go_tys env tys }@@ -927,36 +924,41 @@       | otherwise       = mkTyConApp tc <$> go_tys env tys -    go_ty env (ForAllTy (Bndr tv vis) inner)-      = do { (env', tv') <- tycobinder env tv vis+    go_ty !env (ForAllTy (Bndr tv vis) inner)+      = do { tycobinder env tv vis $ \env' tv' -> do            ; inner' <- go_ty env' inner            ; return $ ForAllTy (Bndr tv' vis) inner' } -    go_cos _   []       = return []-    go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos+    -- See Note [Use explicit recursion in mapTyCo]+    go_cos !_   []       = return []+    go_cos !env (co:cos) = (:) <$> go_co env co <*> go_cos env cos -    go_mco _   MRefl    = return MRefl-    go_mco env (MCo co) = MCo <$> (go_co env co)+    go_mco !_   MRefl    = return MRefl+    go_mco !env (MCo co) = MCo <$> (go_co env co) -    go_co env (Refl ty)                  = Refl <$> go_ty env ty-    go_co env (GRefl r ty mco)           = mkGReflCo r <$> go_ty env ty <*> go_mco env mco-    go_co env (AppCo c1 c2)              = mkAppCo <$> go_co env c1 <*> go_co env c2-    go_co env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw+    go_co :: env -> Coercion -> m Coercion+    go_co !env (Refl ty)                  = Refl <$> go_ty env ty+    go_co !env (GRefl r ty mco)           = mkGReflCo r <$> go_ty env ty <*> go_mco env mco+    go_co !env (AppCo c1 c2)              = mkAppCo <$> go_co env c1 <*> go_co env c2+    go_co !env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw                                            <*> go_co env c1 <*> go_co env c2-    go_co env (CoVarCo cv)               = covar env cv-    go_co env (HoleCo hole)              = cohole env hole-    go_co env (UnivCo p r t1 t2)         = mkUnivCo <$> go_prov env p <*> pure r-                                           <*> go_ty env t1 <*> go_ty env t2-    go_co env (SymCo co)                 = mkSymCo <$> go_co env co-    go_co env (TransCo c1 c2)            = mkTransCo <$> go_co env c1 <*> go_co env c2-    go_co env (AxiomRuleCo r cos)        = AxiomRuleCo r <$> go_cos env cos-    go_co env (SelCo i co)               = mkSelCo i <$> go_co env co-    go_co env (LRCo lr co)               = mkLRCo lr <$> go_co env co-    go_co env (InstCo co arg)            = mkInstCo <$> go_co env co <*> go_co env arg-    go_co env (KindCo co)                = mkKindCo <$> go_co env co-    go_co env (SubCo co)                 = mkSubCo <$> go_co env co-    go_co env (AxiomInstCo ax i cos)     = mkAxiomInstCo ax i <$> go_cos env cos-    go_co env co@(TyConAppCo r tc cos)+    go_co !env (CoVarCo cv)               = covar env cv+    go_co !env (HoleCo hole)              = cohole env hole+    go_co !env (UnivCo { uco_prov = p, uco_role = r+                       , uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                          = mkUnivCo <$> pure p+                                                     <*> go_cos env deps+                                                     <*> pure r+                                                     <*> go_ty env t1 <*> go_ty env t2+    go_co !env (SymCo co)                 = mkSymCo <$> go_co env co+    go_co !env (TransCo c1 c2)            = mkTransCo <$> go_co env c1 <*> go_co env c2+    go_co !env (AxiomCo r cos)            = mkAxiomCo r <$> go_cos env cos+    go_co !env (SelCo i co)               = mkSelCo i <$> go_co env co+    go_co !env (LRCo lr co)               = mkLRCo lr <$> go_co env co+    go_co !env (InstCo co arg)            = mkInstCo <$> go_co env co <*> go_co env arg+    go_co !env (KindCo co)                = mkKindCo <$> go_co env co+    go_co !env (SubCo co)                 = mkSubCo <$> go_co env co+    go_co !env co@(TyConAppCo r tc cos)       | isTcTyCon tc       = do { tc' <- tycon tc            ; mkTyConAppCo r tc' <$> go_cos env cos }@@ -967,19 +969,29 @@        | otherwise       = mkTyConAppCo r tc <$> go_cos env cos-    go_co env (ForAllCo tv kind_co co)+    go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = co })       = do { kind_co' <- go_co env kind_co-           ; (env', tv') <- tycobinder env tv Inferred+           ; tycobinder env tv visL $ \env' tv' ->  do            ; co' <- go_co env' co-           ; return $ mkForAllCo tv' kind_co' co' }+           ; return $ mkForAllCo tv' visL visR kind_co' co' }         -- See Note [Efficiency for ForAllCo case of mapTyCoX] -    go_prov env (PhantomProv co)    = PhantomProv <$> go_co env co-    go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co-    go_prov _   p@(PluginProv _)    = return p-    go_prov _   p@(CorePrepProv _)  = return p +{- Note [Use explicit recursion in mapTyCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use explicit recursion in `mapTyCo`, rather than calling, say, `strictFoldDVarSet`,+for exactly the same reason as in Note [Use explicit recursion in foldTyCo] in+GHC.Core.TyCo.Rep. We are in a monadic context, and using too-clever higher order+functions makes the strictness analyser produce worse results. +We could probably use `foldr`, since it is inlined bodily, fairly early; but+I'm doing the simple thing and inlining it by hand.++See !12037 for performance glitches caused by using `strictFoldDVarSet` (which is+definitely not inlined bodily).+-}+ {- ********************************************************************* *                                                                      *                       TyVarTy@@ -1028,7 +1040,7 @@ Note [Decomposing fat arrow c=>t] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with-a partial application like ((=>) Eq a) which doesn't make sense in+a partial application like ((=>) (Eq a)) which doesn't make sense in source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2). Here's an example (#9858) of how you might do it:    i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep@@ -1039,14 +1051,13 @@ but suppose we want that.  But then in the call to 'i', we end up decomposing (Eq Int => Int), and we definitely don't want that. -This really only applies to the type checker; in Core, '=>' and '->'-are the same, as are 'Constraint' and '*'.  But for now I've put-the test in splitAppTyNoView_maybe, which applies throughout, because-the other calls to splitAppTy are in GHC.Core.Unify, which is also used by-the type checker (e.g. when matching type-function equations).- We are willing to split (t1 -=> t2) because the argument is still of kind Type, not Constraint.  So the criterion is isVisibleFunArg.++In Core there is no real reason to avoid such decomposition.  But for now I've+put the test in splitAppTyNoView_maybe, which applies throughout, because the+other calls to splitAppTy are in GHC.Core.Unify, which is also used by the+type checker (e.g. when matching type-function equations). -}  -- | Applies a type to another, as in e.g. @k a@@@ -1127,7 +1138,7 @@   = splitAppTyNoView_maybe ty  --------------splitAppTys :: Type -> (Type, [Type])+splitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -- ^ Recursively splits a type as far as is possible, leaving a residual -- type being applied to and the type arguments applied to it. Never fails, -- even if that means returning an empty list of type applications.@@ -1208,19 +1219,50 @@   | LitTy l <- coreFullView ty = Just l   | otherwise                  = Nothing +-- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module).+type ErrorMsgType = Type+ -- | Is this type a custom user error?--- If so, give us the kind and the error message.-userTypeError_maybe :: Type -> Maybe Type-userTypeError_maybe t-  = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t+-- If so, give us the error message.+userTypeError_maybe :: Type -> Maybe ErrorMsgType+userTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+userTypeError_maybe (TyConApp tc (_kind : msg : _))+  | tyConName tc == errorMessageTypeErrorFamName           -- There may be more than 2 arguments, if the type error is           -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg+userTypeError_maybe _+  = Nothing -       ; guard (tyConName tc == errorMessageTypeErrorFamName)-       ; return msg }+deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType+-- Look for custom user error, deeply inside the type+deepUserTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+deepUserTypeError_maybe (TyConApp tc tys)+  | tyConName tc == errorMessageTypeErrorFamName+  , _kind : msg : _ <- tys+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg +  | tyConMustBeSaturated tc  -- Don't go looking for user type errors+                             -- inside type family arguments (see #20241).+  = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys)+  | otherwise+  = foldr (firstJust . deepUserTypeError_maybe) Nothing tys+deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty+deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res })+  = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res+deepUserTypeError_maybe (AppTy t1 t2)+  = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2+deepUserTypeError_maybe (CastTy ty _)+  = deepUserTypeError_maybe ty+deepUserTypeError_maybe _   -- TyVarTy, CoercionTy, LitTy+  = Nothing+ -- | Render a type corresponding to a user type error into a SDoc.-pprUserTypeErrorTy :: Type -> SDoc+pprUserTypeErrorTy :: ErrorMsgType -> SDoc pprUserTypeErrorTy ty =   case splitTyConApp_maybe ty of @@ -1246,7 +1288,6 @@     -- An unevaluated type function     _ -> ppr ty - {- ********************************************************************* *                                                                      *                       FunTy@@ -1290,6 +1331,8 @@ funTyConAppTy_maybe af mult arg res   | Just arg_rep <- getRuntimeRep_maybe arg   , Just res_rep <- getRuntimeRep_maybe res+  -- If you're changing the lines below, you'll probably want to adapt the+  -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly.   , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res]              | otherwise   = [      arg_rep, res_rep, arg, res]   = Just $ (funTyFlagTyCon af, args)@@ -1307,9 +1350,12 @@                     -> Maybe Coercion -- ^ Return Just if this TyConAppCo should be represented as a FunCo tyConAppFunCo_maybe r tc cos-  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe (mkReflCo r manyDataConTy) tc cos-            = Just (mkFunCo1 r af mult arg res)-  | otherwise = Nothing+  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos+  = Just (mkFunCo r af mult arg res)+  | otherwise+  = Nothing+  where+    mult_refl = mkReflCo (funRole r SelMult) manyDataConTy  ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]                      -> Maybe (FunTyFlag, a, a, a)@@ -1376,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@@ -1390,7 +1445,7 @@   | FunTy { ft_res = res } <- coreFullView ty = res   | otherwise                                 = pprPanic "funResultTy" (ppr ty) -funArgTy :: Type -> Type+funArgTy :: HasDebugCallStack => Type -> Type -- ^ Extract the function argument type and panic if that is not possible funArgTy ty   | FunTy { ft_arg = arg } <- coreFullView ty = arg@@ -1444,8 +1499,9 @@   | FunTy { ft_res = res } <- ty   = piResultTys res args -  | ForAllTy (Bndr tv _) res <- ty-  = go (extendTCvSubst init_subst tv arg) res args+  | ForAllTy (Bndr tcv _) res <- ty+  = -- Both type and coercion variables+    go (extendTCvSubst init_subst tcv arg) res args    | Just ty' <- coreView ty   = piResultTys ty' orig_args@@ -1558,7 +1614,7 @@                           Just (_, tys) -> Just tys                           Nothing       -> Nothing -tyConAppArgs :: HasCallStack => Type -> [Type]+tyConAppArgs :: HasDebugCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)  -- | Attempts to tease a type apart into a type constructor and the application@@ -1572,7 +1628,7 @@ splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty) -splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type])+splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Same as splitTyConApp_maybe but without looking through synonyms splitTyConAppNoView_maybe ty   = case ty of@@ -1591,14 +1647,14 @@ -- of a 'FunTy' with an argument of unknown kind 'FunTy' -- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of -- the form `TYPE rep`.  This isn't usually a problem but may--- be temporarily the cas during canonicalization:---     see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical+-- be temporarily the case during canonicalization:+--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality --     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, --         Wrinkle around FunTy -- -- Consequently, you may need to zonk your type before -- using this function.-tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])+tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty   = case coreFullView ty of@@ -1732,17 +1788,28 @@ tyConBindersPiTyBinders = map to_tyb   where     to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)-    to_tyb (Bndr tv (AnonTCB af))   = Anon (tymult (varType tv)) af+    to_tyb (Bndr tv AnonTCB)        = Anon (tymult (varType tv)) FTF_T_T --- | Make a dependent forall over an 'Inferred' variable-mkTyCoInvForAllTy :: TyCoVar -> Type -> Type-mkTyCoInvForAllTy tv ty+-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type+mkTyCoForAllTy tv vis ty   | isCoVar tv   , not (tv `elemVarSet` tyCoVarsOfType ty)+   -- Maintain ForAllTy's invariants+    -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep   = mkVisFunTyMany (varType tv) ty   | otherwise-  = ForAllTy (Bndr tv Inferred) ty+  = ForAllTy (mkForAllTyBinder vis tv) ty +-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type+mkTyCoForAllTys bndrs ty+  = foldr (\(Bndr var vis) -> mkTyCoForAllTy var vis) ty bndrs++-- | Make a dependent forall over an 'Inferred' variable+mkTyCoInvForAllTy :: TyCoVar -> Type -> Type+mkTyCoInvForAllTy tv ty = mkTyCoForAllTy tv Inferred ty+ -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar mkInfForAllTy :: TyVar -> Type -> Type mkInfForAllTy tv ty = assert (isTyVar tv )@@ -1794,7 +1861,7 @@               = ( Bndr v (NamedTCB Required) : binders                 , fvs `delVarSet` v `unionVarSet` kind_vars )               | otherwise-              = ( Bndr v (AnonTCB visArgTypeLike) : binders+              = ( Bndr v AnonTCB : binders                 , fvs `unionVarSet` kind_vars )       where         (binders, fvs) = go vs@@ -1863,6 +1930,15 @@    | otherwise = False +-- | Like `isForAllTy`, but returns True only if it is an inferred tyvar binder+isForAllTy_invis_ty :: Type -> Bool+isForAllTy_invis_ty  ty+  | ForAllTy (Bndr tv (Invisible InferredSpec)) _ <- coreFullView ty+  , isTyVar tv+  = True++  | otherwise = False+ -- | Like `isForAllTy`, but returns True only if it is a covar binder isForAllTy_co :: Type -> Bool isForAllTy_co ty@@ -1880,6 +1956,8 @@   _           -> False  -- | Is this a function?+-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function.+--       It would merely be a forall wrapping a function type. isFunTy :: Type -> Bool isFunTy ty   | FunTy {} <- coreFullView ty = True@@ -1899,14 +1977,20 @@     go ty | Just ty' <- coreView ty = go ty'     go res                         = res --- | Attempts to take a forall type apart, but only if it's a proper forall,--- with a named binder+-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder+splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)+splitForAllForAllTyBinder_maybe ty+  | ForAllTy bndr inner_ty <- coreFullView ty = Just (bndr, inner_ty)+  | otherwise                                 = Nothing+++-- | Attempts to take a ForAllTy apart, returning the Var splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTyCoVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty)   | otherwise                                        = Nothing --- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder.+-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) splitForAllTyVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty@@ -1951,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. --@@ -1992,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.@@ -2195,32 +2291,46 @@ isFamFreeTy (CastTy ty _)     = isFamFreeTy ty isFamFreeTy (CoercionTy _)    = False  -- Not sure about this --- | 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-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey-  | otherwise-  = False+-- | 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 --   isFamFree and isTauTy buildSynTyCon name binders res_kind roles rhs-  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful+  = mkSynonymTyCon name binders res_kind roles rhs+                   is_tau is_fam_free is_forgetful is_concrete   where+    qtvs         = mkVarSet (map binderVar binders)     is_tau       = isTauTy rhs     is_fam_free  = isFamFreeTy rhs-    is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders ||-                   uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs)-         -- NB: This is allowed to be conservative, returning True more often-         -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon+    is_concrete  = isConcreteTypeWith qtvs rhs+    is_forgetful = not (qtvs `subVarSet` expanded_rhs_tyvars) +    expanded_rhs_tyvars = tyCoVarsOfType (expandTypeSynonyms rhs)+       -- See Note [Forgetful type synonyms] in GHC.Core.TyCon+       -- To find out if this TyCon is forgetful, expand the synonyms in its RHS+       -- and check that all of the binders are free in the expanded type.+       -- We really only need to expand the /forgetful/ synonyms on the RHS,+       -- but we don't currently have a function to do that.+       -- Failing to expand the RHS led to #25094, e.g.+       --    type Bucket a b c = Key (a,b,c)+       --    type Key x = Any+       -- Here Bucket is definitely forgetful!+ {- ************************************************************************ *                                                                      *@@ -2237,6 +2347,11 @@ typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) +typeLevity :: HasDebugCallStack => Type -> Levity+typeLevity ty = case typeLevity_maybe ty of+                   Just lev -> lev+                   Nothing  -> pprPanic "typeLevity" (ppr ty)+ -- | Is the given type definitely unlifted? -- See "Type#type_classification" for what an unlifted type is. --@@ -2247,14 +2362,11 @@         -- isUnliftedType returns True for forall'd unlifted types:         --      x :: forall a. Int#         -- I found bindings like these were getting floated to the top level.-        -- They are pretty bogus types, mind you.  It would be better never to-        -- construct them isUnliftedType ty =   case typeLevity_maybe ty of     Just Lifted   -> False     Just Unlifted -> True-    Nothing       ->-      pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))+    Nothing       -> pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))  -- | Returns: --@@ -2264,6 +2376,9 @@ mightBeLiftedType :: Type -> Bool mightBeLiftedType = mightBeLifted . typeLevity_maybe +definitelyLiftedType :: Type -> Bool+definitelyLiftedType = not . mightBeUnliftedType+ -- | Returns: -- -- * 'False' if the type is /guaranteed/ lifted or@@ -2272,6 +2387,9 @@ mightBeUnliftedType :: Type -> Bool mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe +definitelyUnliftedType :: Type -> Bool+definitelyUnliftedType = not . mightBeLiftedType+ -- | See "Type#type_classification" for what a boxed type is. -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for -- a more approximate predicate that behaves better in the presence of@@ -2355,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'.@@ -2368,6 +2480,18 @@ isStrictType :: HasDebugCallStack => Type -> Bool isStrictType = isUnliftedType +isTerminatingType :: HasDebugCallStack => Type -> Bool+-- ^ True <=> a term of this type cannot be bottom+-- This identifies the types described by+--    Note [NON-BOTTOM-DICTS invariant] in GHC.Core+-- 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 (isUnaryClassTyCon tc)+               -- A non-unary class TyCon is terminating+               -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon+    _       -> False+ isPrimitiveType :: Type -> Bool -- ^ Returns true of types that are opaque to Haskell. isPrimitiveType ty = case splitTyConApp_maybe ty of@@ -2489,8 +2613,6 @@            torc is TYPE or CONSTRAINT           ty : body_torc rep-          bndr_torc is Type or Constraint-          ki : bndr_torc           ki : Type           `a` is a type variable           `a` is not free in rep@@ -2509,10 +2631,6 @@ Note that: * (FORALL1) rejects (forall (a::Maybe). blah) -* (FORALL1) accepts (forall (a :: t1~t2) blah), where the type variable-  (not coercion variable!) 'a' has a kind (t1~t2) that in turn has kind-  Constraint.  See Note [Constraints in kinds] in GHC.Core.TyCo.Rep.- * (FORALL2) Surprise 1:   See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] @@ -2557,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@@ -2574,25 +2690,27 @@     go fun             args = piResultTys (typeKind fun) args  typeKind ty@(ForAllTy {})-  = case occCheckExpand tvs body_kind of-      -- We must make sure tv does not occur in kind-      -- As it is already out of scope!+  = assertPpr (not (null tcvs)) (ppr ty) $+       -- If tcvs is empty somehow we'll get an infinite loop!+    case occCheckExpand tcvs body_kind of+      -- We must make sure tvs do not occur in kind,+      -- as they would be out of scope!       -- See Note [Phantom type variables in kinds]       Nothing -> pprPanic "typeKind"-                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)+                  (ppr ty $$ ppr tcvs $$ ppr body <+> dcolon <+> ppr body_kind) -      Just k' | all isTyVar tvs -> k'                     -- Rule (FORALL1)-              | otherwise       -> lifted_kind_from_body  -- Rule (FORALL2)+      Just k' | all isTyVar tcvs -> k'                     -- Rule (FORALL1)+              | otherwise        -> lifted_kind_from_body  -- Rule (FORALL2)   where-    (tvs, body) = splitForAllTyVars ty-    body_kind   = typeKind body+    (tcvs, body) = splitForAllTyCoVars ty  -- Important: splits both TyVar and CoVar binders+    body_kind    = typeKind body      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)@@ -2631,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@@ -2723,43 +2833,37 @@     go (ForAllTy _ ty)          = go ty     go ty                       = isFixedRuntimeRepKind (typeKind ty) -argsHaveFixedRuntimeRep :: Type -> Bool--- ^ True if the argument types of this function type--- all have a fixed-runtime-rep-argsHaveFixedRuntimeRep ty-  = all ok bndrs-  where-    ok :: PiTyBinder -> Bool-    ok (Anon ty _) = typeHasFixedRuntimeRep (scaledThing ty)-    ok _           = True--    bndrs :: [PiTyBinder]-    (bndrs, _) = splitPiTys ty- -- | Checks that a kind of the form 'Type', 'Constraint'--- or @'TYPE r@ is concrete. See 'isConcrete'.+-- or @'TYPE r@ is concrete. See 'isConcreteType'. -- -- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah` isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool isFixedRuntimeRepKind k   = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $     -- the isLiftedTypeKind check is necessary b/c of Constraint-    isConcrete k+    isConcreteType k  -- | Tests whether the given type is concrete, i.e. it -- whether it consists only of concrete type constructors, -- concrete type variables, and applications. -- -- See Note [Concrete types] in GHC.Tc.Utils.Concrete.-isConcrete :: Type -> Bool-isConcrete = go+isConcreteType :: Type -> Bool+isConcreteType = isConcreteTypeWith emptyVarSet++-- | 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.+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 ty | Just ty' <- coreView ty = go ty'-    go (TyVarTy tv)        = isConcreteTyVar tv+    go (TyVarTy tv)        = isConcreteTyVar tv || tv `elemVarSet` conc_tvs     go (AppTy ty1 ty2)     = go ty1 && go ty2-    go (TyConApp tc tys)-      | isConcreteTyCon tc = all go tys-      | otherwise          = False+    go (TyConApp tc tys)   = go_tc tc tys     go ForAllTy{}          = False     go (FunTy _ w t1 t2)   =  go w                            && go (typeKind t1) && go t1@@ -2768,7 +2872,22 @@     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+      , Just ty' <- expandSynTyConApp_maybe tc tys+      = go ty' +      -- Apart from forgetful synonyms, isConcreteTyCon+      -- is enough; no need to expand.  This is good for e.g+      --      type LiftedRep = BoxedRep Lifted+      | isConcreteTyCon tc+      = all go tys++      | otherwise  -- E.g. type families+      = False+ {- %************************************************************************ %*                                                                      *@@ -2815,8 +2934,7 @@     injective_vars_of_binder :: TyConBinder -> FV     injective_vars_of_binder (Bndr tv vis) =       case vis of-        AnonTCB af     | isVisibleFunArg af-                       -> injectiveVarsOfType False -- conservative choice+        AnonTCB        -> injectiveVarsOfType False -- conservative choice                                               (varType tv)         NamedTCB argf  | source_of_injectivity argf                        -> unitFV tv `unionFV`@@ -3152,8 +3270,9 @@ Goal (b) is particularly useful as it makes traversals (e.g. free variable traversal, substitution, and comparison) more efficient. Comparison in particular takes special advantage of nullary type synonym-applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing-nullary type synonyms] in "GHC.Core.Type".+applications (e.g. things like @TyConApp typeTyCon []@). See+* Note [Comparing type synonyms] in "GHC.Core.TyCo.Compare"+* Note [Unifying type synonyms] in "GHC.Core.Unify"  To accomplish these we use a number of tricks, implemented by mkTyConApp. @@ -3313,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,30 +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-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
@@ -16,52 +16,53 @@ -}  -{-# LANGUAGE BangPatterns #-}  module GHC.Core.Unfold (         Unfolding, UnfoldingGuidance,   -- Abstract types +        ExprSize(..), sizeExpr,++        ArgSummary(..), nonTriv,+        CallCtxt(..),+         UnfoldingOpts (..), defaultUnfoldingOpts,         updateCreationThreshold, updateUseThreshold,         updateFunAppDiscount, updateDictDiscount,         updateVeryAggressive, updateCaseScaling,         updateCaseThreshold, updateReportPrefix, -        ArgSummary(..),--        couldBeSmallEnoughToInline, inlineBoringOk,-        smallEnoughToInline,--        callSiteInline, CallCtxt(..),-        calcUnfoldingGuidance+        inlineBoringOk, calcUnfoldingGuidance,+        uncondInlineJoin     ) where  import GHC.Prelude -import GHC.Driver.Flags- import GHC.Core import GHC.Core.Utils-import GHC.Types.Id 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-import GHC.Builtin.PrimOps import GHC.Types.Id.Info import GHC.Types.RepType ( isZeroBitTy )-import GHC.Types.Basic  ( Arity, RecFlag(..) )-import GHC.Core.Type+import GHC.Types.Basic  ( Arity, RecFlag )+import GHC.Types.ForeignCall+import GHC.Types.Tickish++import GHC.Builtin.PrimOps import GHC.Builtin.Names+ import GHC.Data.Bag-import GHC.Utils.Logger+ import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Types.ForeignCall-import GHC.Types.Name-import GHC.Types.Tickish  import qualified Data.ByteString as BS-import Data.List (isPrefixOf)-+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE  -- | Unfolding options data UnfoldingOpts = UnfoldingOpts@@ -151,25 +152,42 @@ updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts updateReportPrefix n opts = opts { unfoldingReportPrefix = n } -{--Note [Occurrence analysis of unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do occurrence-analysis of unfoldings once and for all, when the-unfolding is built, rather than each time we inline them.+data ArgSummary = TrivArg       -- Nothing interesting+                | NonTrivArg    -- Arg has structure+                | ValueArg      -- Arg is a con-app or PAP+                                -- ..or con-like. Note [Conlike is interesting] -But given this decision it's vital that we do-*always* do it.  Consider this unfolding-    \x -> letrec { f = ...g...; g* = f } in body-where g* is (for some strange reason) the loop breaker.  If we don't-occ-anal it when reading it in, we won't mark g as a loop breaker, and-we may inline g entirely in body, dropping its binding, and leaving-the occurrence in f out of scope. This happened in #8892, where-the unfolding in question was a DFun unfolding.+instance Outputable ArgSummary where+  ppr TrivArg    = text "TrivArg"+  ppr NonTrivArg = text "NonTrivArg"+  ppr ValueArg   = text "ValueArg" -But more generally, the simplifier is designed on the-basis that it is looking at occurrence-analysed expressions, so better-ensure that they actually are.+nonTriv ::  ArgSummary -> Bool+nonTriv TrivArg = False+nonTriv _       = True +data CallCtxt+  = BoringCtxt+  | RhsCtxt RecFlag     -- Rhs of a let-binding; see Note [RHS of lets]+  | DiscArgCtxt         -- Argument of a function with non-zero arg discount+  | RuleArgCtxt         -- We are somewhere in the argument of a function with rules++  | ValAppCtxt          -- We're applied to at least one value arg+                        -- This arises when we have ((f x |> co) y)+                        -- Then the (f x) has argument 'x' but in a ValAppCtxt++  | CaseCtxt            -- We're the scrutinee of a case+                        -- that decomposes its scrutinee++instance Outputable CallCtxt where+  ppr CaseCtxt    = text "CaseCtxt"+  ppr ValAppCtxt  = text "ValAppCtxt"+  ppr BoringCtxt  = text "BoringCtxt"+  ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir)+  ppr DiscArgCtxt = text "DiscArgCtxt"+  ppr RuleArgCtxt = text "RuleArgCtxt"++{- Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to@@ -201,44 +219,136 @@ ************************************************************************ -} +{- 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-    go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce]-      | isUnsafeEqualityProof scrut        = go credit rhs-    go _      (Var {})                     = boringCxtOk-    go _      _                            = boringCxtNotOk+    -- 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 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+        -> Bool          -- True <=> join point         -> CoreExpr      -- Expression to look at         -> UnfoldingGuidance-calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)+calcUnfoldingGuidance opts is_top_bottoming is_join (Tick t expr)   | not (tickishIsCode t)  -- non-code ticks don't matter for unfolding-  = calcUnfoldingGuidance opts is_top_bottoming expr-calcUnfoldingGuidance opts is_top_bottoming expr+  = calcUnfoldingGuidance opts is_top_bottoming is_join expr+calcUnfoldingGuidance opts is_top_bottoming is_join expr   = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of       TooBig -> UnfNever       SizeIs size cased_bndrs scrut_discount-        | uncondInline expr n_val_bndrs size+        | uncondInline is_join expr bndrs n_val_bndrs body size         -> UnfWhen { ug_unsat_ok = unSaturatedOk                    , ug_boring_ok =  boringCxtOk                    , ug_arity = n_val_bndrs }   -- Note [INLINE for small functions]@@ -275,7 +385,7 @@ We really want to inline unsafeCoerce, even when applied to boring arguments.  It doesn't look as if its RHS is smaller than the call    unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x-but that case is discarded -- see Note [Implementing unsafeCoerce]+but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce] in base:Unsafe.Coerce.  Moreover, if we /don't/ inline it, we may be left with@@ -283,7 +393,9 @@ which will build a thunk -- bad, bad, bad.  Conclusion: we really want inlineBoringOk to be True of the RHS of-unsafeCoerce.  This is (U4) in Note [Implementing unsafeCoerce].+unsafeCoerce. And it really is, because we regard+  case unsafeEqualityProof @a @b of UnsafeRefl -> rhs+as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce].  Note [Computing the size of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -379,39 +491,70 @@     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 :: CoreExpr -> Arity -> Int -> Bool+uncondInline :: Bool -> CoreExpr -> [Var] -> Arity -> CoreExpr -> Int -> Bool -- Inline unconditionally if there no size increase -- Size of call is arity (+1 for the function) -- See Note [INLINE for small functions]-uncondInline rhs arity size+uncondInline is_join rhs bndrs arity body size+  | is_join   = uncondInlineJoin bndrs body   | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)   | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4) +uncondInlineJoin :: [Var] -> CoreExpr -> Bool+-- See Note [Duplicating join points] point (DJ3) in GHC.Core.Opt.Simplify.Iteration+uncondInlineJoin bndrs body++  -- (DJ3)(a)+  | exprIsTrivial body+  = True   -- Nullary constructors, literals++  -- (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@@ -455,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@@ -490,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)@@ -535,7 +676,7 @@                 = False      size_up_rhs (bndr, rhs)-      | Just join_arity <- isJoinId_maybe bndr+      | JoinPoint join_arity <- idJoinPointHood bndr         -- Skip arguments to join point       , (_bndrs, body) <- collectNBinders join_arity rhs       = size_up body@@ -562,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@@ -631,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@@ -662,18 +808,19 @@  :: Int  -- ^ number of value args  -> Int  -- ^ number of value args that are void  -> Int-jumpSize n_val_args voids = 2 * (1 + n_val_args - voids)+jumpSize _n_val_args _voids = 0   -- Jumps are small, and we don't want penalise them++  -- Old version:+  -- 2 * (1 + n_val_args - voids)   -- A jump is 20% the size of a function call. Making jumps free reopens   -- bug #6048, but making them any more expensive loses a 21% improvement in   -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a   -- 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@@ -703,6 +850,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 @@ -930,561 +1079,3 @@  sizeZero = SizeIs 0 emptyBag 0 sizeN n  = SizeIs n emptyBag 0--{--************************************************************************-*                                                                      *-\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}-*                                                                      *-************************************************************************--We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that-we ``couldn't possibly use'' on the other side.  Can be overridden w/-flaggery.  Just the same as smallEnoughToInline, except that it has no-actual arguments.--}--couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool-couldBeSmallEnoughToInline opts threshold rhs-  = case sizeExpr opts threshold [] body of-       TooBig -> False-       _      -> True-  where-    (_, body) = collectBinders rhs-------------------smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool-smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance})-  = case guidance of-       UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts-       UnfWhen {} -> True-       UnfNever   -> False-smallEnoughToInline _ _-  = False--{--************************************************************************-*                                                                      *-\subsection{callSiteInline}-*                                                                      *-************************************************************************--This is the key function.  It decides whether to inline a variable at a call site--callSiteInline is used at call sites, so it is a bit more generous.-It's a very important function that embodies lots of heuristics.-A non-WHNF can be inlined if it doesn't occur inside a lambda,-and occurs exactly once or-    occurs once in each branch of a case and is small--If the thing is in WHNF, there's no danger of duplicating work,-so we can inline if it occurs once, or is small--NOTE: we don't want to inline top-level functions that always diverge.-It just makes the code bigger.  Tt turns out that the convenient way to prevent-them inlining is to give them a NOINLINE pragma, which we do in-StrictAnal.addStrictnessInfoToTopId--}--data ArgSummary = TrivArg       -- Nothing interesting-                | NonTrivArg    -- Arg has structure-                | ValueArg      -- Arg is a con-app or PAP-                                -- ..or con-like. Note [Conlike is interesting]--instance Outputable ArgSummary where-  ppr TrivArg    = text "TrivArg"-  ppr NonTrivArg = text "NonTrivArg"-  ppr ValueArg   = text "ValueArg"--nonTriv ::  ArgSummary -> Bool-nonTriv TrivArg = False-nonTriv _       = True--data CallCtxt-  = BoringCtxt-  | RhsCtxt RecFlag     -- Rhs of a let-binding; see Note [RHS of lets]-  | DiscArgCtxt         -- Argument of a function with non-zero arg discount-  | RuleArgCtxt         -- We are somewhere in the argument of a function with rules--  | ValAppCtxt          -- We're applied to at least one value arg-                        -- This arises when we have ((f x |> co) y)-                        -- Then the (f x) has argument 'x' but in a ValAppCtxt--  | CaseCtxt            -- We're the scrutinee of a case-                        -- that decomposes its scrutinee--instance Outputable CallCtxt where-  ppr CaseCtxt    = text "CaseCtxt"-  ppr ValAppCtxt  = text "ValAppCtxt"-  ppr BoringCtxt  = text "BoringCtxt"-  ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir)-  ppr DiscArgCtxt = text "DiscArgCtxt"-  ppr RuleArgCtxt = text "RuleArgCtxt"--callSiteInline :: Logger-               -> UnfoldingOpts-               -> Int                   -- Case depth-               -> Id                    -- The Id-               -> Bool                  -- True <=> unfolding is active-               -> Bool                  -- True if there are no arguments at all (incl type args)-               -> [ArgSummary]          -- One for each value arg; True if it is interesting-               -> CallCtxt              -- True <=> continuation is interesting-               -> Maybe CoreExpr        -- Unfolding, if any-callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_infos cont_info-  = case idUnfolding id of-      -- idUnfolding checks for loop-breakers, returning NoUnfolding-      -- Things with an INLINE pragma may have an unfolding *and*-      -- be a loop breaker  (maybe the knot is not yet untied)-        CoreUnfolding { uf_tmpl = unf_template-                      , uf_cache = unf_cache-                      , uf_guidance = guidance }-          | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable-                                    arg_infos cont_info unf_template-                                    unf_cache guidance-          | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing-        NoUnfolding      -> Nothing-        BootUnfolding    -> Nothing-        OtherCon {}      -> Nothing-        DFunUnfolding {} -> Nothing     -- Never unfold a DFun---- | Report the inlining of an identifier's RHS to the user, if requested.-traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a-traceInline logger opts inline_id str doc result-  -- We take care to ensure that doc is used in only one branch, ensuring that-  -- the simplifier can push its allocation into the branch. See Note [INLINE-  -- conditional tracing utilities].-  | enable    = logTraceMsg logger str doc result-  | otherwise = result-  where-    enable-      | logHasDumpFlag logger Opt_D_dump_verbose_inlinings-      = True-      | Just prefix <- unfoldingReportPrefix opts-      = prefix `isPrefixOf` occNameString (getOccName inline_id)-      | otherwise-      = False-{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities]--{- Note [Avoid inlining into deeply nested cases]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Consider a function f like this:--  f arg1 arg2 =-    case ...-      ... -> g arg1-      ... -> g arg2--This function is small. So should be safe to inline.-However sometimes this doesn't quite work out like that.-Consider this code:--f1 arg1 arg2 ... = ...-    case _foo of-      alt1 -> ... f2 arg1 ...-      alt2 -> ... f2 arg2 ...--f2 arg1 arg2 ... = ...-    case _foo of-      alt1 -> ... f3 arg1 ...-      alt2 -> ... f3 arg2 ...--f3 arg1 arg2 ... = ...--... repeats up to n times. And then f1 is-applied to some arguments:--foo = ... f1 <interestingArgs> ...--Initially f2..fn are not interesting to inline so we don't.-However we see that f1 is applied to interesting args.-So it's an obvious choice to inline those:--foo =-    ...-      case _foo of-        alt1 -> ... f2 <interestingArg> ...-        alt2 -> ... f2 <interestingArg> ...--As a result we go and inline f2 both mentions of f2 in turn are now applied to interesting-arguments and f2 is small:--foo =-    ...-      case _foo of-        alt1 -> ... case _foo of-            alt1 -> ... f3 <interestingArg> ...-            alt2 -> ... f3 <interestingArg> ...--        alt2 -> ... case _foo of-            alt1 -> ... f3 <interestingArg> ...-            alt2 -> ... f3 <interestingArg> ...--The same thing happens for each binding up to f_n, duplicating the amount of inlining-done in each step. Until at some point we are either done or run out of simplifier-ticks/RAM. This pattern happened #18730.--To combat this we introduce one more heuristic when weighing inlining decision.-We keep track of a "case-depth". Which increases each time we look inside a case-expression with more than one alternative.--We then apply a penalty to inlinings based on the case-depth at which they would-be inlined. Bounding the number of inlinings in such a scenario.--The heuristic can be tuned in two ways:--* We can ignore the first n levels of case nestings for inlining decisions using-  -funfolding-case-threshold.-* The penalty grows linear with the depth. It's computed as size*(depth-threshold)/scaling.-  Scaling can be set with -funfolding-case-scaling.--Some guidance on setting these defaults:--* A low treshold (<= 2) is needed to prevent exponential cases from spiraling out of-  control. We picked 2 for no particular reason.-* Scaling the penalty by any more than 30 means the reproducer from-  T18730 won't compile even with reasonably small values of n. Instead-  it will run out of runs/ticks. This means to positively affect the reproducer-  a scaling <= 30 is required.-* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks.-  (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps)-* A scaling of >= 25 showed no regressions on nofib. However it showed a number of-  (small) regression for compiler perf benchmarks.--The end result is that we are settling for a scaling of 30, with a threshold of 2.-This gives us minimal compiler perf regressions. No nofib runtime regressions and-will still avoid this pattern sometimes. This is a "safe" default, where we err on-the side of compiler blowup instead of risking runtime regressions.--For cases where the default falls short the flag can be changed to allow more/less inlining as-needed on a per-module basis.---}--tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt-             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance-             -> Maybe CoreExpr-tryUnfolding logger opts !case_depth id lone_variable arg_infos-             cont_info unf_template unf_cache guidance- = case guidance of-     UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing--     UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }-        | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts)-                -- See Note [INLINE for small functions] (3)-        -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template)-        | otherwise-        -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing-        where-          some_benefit = calc_some_benefit uf_arity-          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)--     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }-        | unfoldingVeryAggressive opts-        -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)-        | is_wf && some_benefit && small_enough-        -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)-        | otherwise-        -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing-        where-          some_benefit = calc_some_benefit (length arg_discounts)-          -- See Note [Avoid inlining into deeply nested cases]-          depth_treshold = unfoldingCaseThreshold opts-          depth_scaling = unfoldingCaseScaling opts-          depth_penalty | case_depth <= depth_treshold = 0-                        | otherwise       = (size * (case_depth - depth_treshold)) `div` depth_scaling-          adjusted_size = size + depth_penalty - discount-          small_enough = adjusted_size <= unfoldingUseThreshold opts-          discount = computeDiscount arg_discounts res_discount arg_infos cont_info--          extra_doc = vcat [ text "case depth =" <+> int case_depth-                           , text "depth based penalty =" <+> int depth_penalty-                           , text "discounted size =" <+> int adjusted_size ]--  where-    -- Unpack the UnfoldingCache lazily because it may not be needed, and all-    -- its fields are strict; so evaluating unf_cache at all forces all the-    -- isWorkFree etc computations to take place.  That risks wasting effort for-    -- Ids that are never going to inline anyway.-    -- See Note [UnfoldingCache] in GHC.Core-    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache--    mk_doc some_benefit extra_doc yes_or_no-      = vcat [ text "arg infos" <+> ppr arg_infos-             , text "interesting continuation" <+> ppr cont_info-             , text "some_benefit" <+> ppr some_benefit-             , text "is exp:" <+> ppr is_exp-             , text "is work-free:" <+> ppr is_wf-             , text "guidance" <+> ppr guidance-             , extra_doc-             , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]--    ctx = log_default_dump_context (logFlags logger)-    str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id)-    n_val_args = length arg_infos--           -- some_benefit is used when the RHS is small enough-           -- and the call has enough (or too many) value-           -- arguments (ie n_val_args >= arity). But there must-           -- be *something* interesting about some argument, or the-           -- result context, to make it worth inlining-    calc_some_benefit :: Arity -> Bool   -- The Arity is the number of args-                                         -- expected by the unfolding-    calc_some_benefit uf_arity-       | not saturated = interesting_args       -- Under-saturated-                                        -- Note [Unsaturated applications]-       | otherwise = interesting_args   -- Saturated or over-saturated-                  || interesting_call-      where-        saturated      = n_val_args >= uf_arity-        over_saturated = n_val_args > uf_arity-        interesting_args = any nonTriv arg_infos-                -- NB: (any nonTriv arg_infos) looks at the-                -- over-saturated args too which is "wrong";-                -- but if over-saturated we inline anyway.--        interesting_call-          | over_saturated-          = True-          | otherwise-          = case cont_info of-              CaseCtxt   -> not (lone_variable && is_exp)  -- Note [Lone variables]-              ValAppCtxt -> True                           -- Note [Cast then apply]-              RuleArgCtxt -> uf_arity > 0  -- See Note [RHS of lets]-              DiscArgCtxt -> uf_arity > 0  -- Note [Inlining in ArgCtxt]-              RhsCtxt NonRecursive-                          -> uf_arity > 0  -- See Note [RHS of lets]-              _other      -> False         -- See Note [Nested functions]---{- Note [RHS of lets]-~~~~~~~~~~~~~~~~~~~~~-When the call is the argument of a function with a RULE, or the RHS of a let,-we are a little bit keener to inline (in tryUnfolding).  For example-     f y = (y,y,y)-     g y = let x = f y in ...(case x of (a,b,c) -> ...) ...-We'd inline 'f' if the call was in a case context, and it kind-of-is,-only we can't see it.  Also-     x = f v-could be expensive whereas-     x = case v of (a,b) -> a-is patently cheap and may allow more eta expansion.--So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a-/non-recursive/ let as not-totally-boring.  A /recursive/ let isn't-going be inlined so there is much less point.  Hence the (only reason-for the) RecFlag in RhsCtxt--Note [Unsaturated applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When a call is not saturated, we *still* inline if one of the-arguments has interesting structure.  That's sometimes very important.-A good example is the Ord instance for Bool in Base:-- Rec {-    $fOrdBool =GHC.Classes.D:Ord-                 @ Bool-                 ...-                 $cmin_ajX--    $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool-    $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool-  }--But the defn of GHC.Classes.$dmmin is:--  $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a-    {- Arity: 3, HasNoCafRefs, Strictness: SLL,-       Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->-                   case @ a GHC.Classes.<= @ a $dOrd x y of wild {-                     GHC.Types.False -> y GHC.Types.True -> x }) -}--We *really* want to inline $dmmin, even though it has arity 3, in-order to unravel the recursion.---Note [Things to watch]-~~~~~~~~~~~~~~~~~~~~~~-*   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }-    Assume x is exported, so not inlined unconditionally.-    Then we want x to inline unconditionally; no reason for it-    not to, and doing so avoids an indirection.--*   { x = I# 3; ....f x.... }-    Make sure that x does not inline unconditionally!-    Lest we get extra allocation.--Note [Nested functions]-~~~~~~~~~~~~~~~~~~~~~~~-At one time we treated a call of a non-top-level function as-"interesting" (regardless of how boring the context) in the hope-that inlining it would eliminate the binding, and its allocation.-Specifically, in the default case of interesting_call we had-   _other -> not is_top && uf_arity > 0--But actually postInlineUnconditionally does some of this and overall-it makes virtually no difference to nofib.  So I simplified away this-special case--Note [Cast then apply]-~~~~~~~~~~~~~~~~~~~~~~-Consider-   myIndex = __inline_me ( (/\a. <blah>) |> co )-   co :: (forall a. a -> a) ~ (forall a. T a)-     ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...--We need to inline myIndex to unravel this; but the actual call (myIndex a) has-no value arguments.  The ValAppCtxt gives it enough incentive to inline.--Note [Inlining in ArgCtxt]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The condition (arity > 0) here is very important, because otherwise-we end up inlining top-level stuff into useless places; eg-   x = I# 3#-   f = \y.  g x-This can make a very big difference: it adds 16% to nofib 'integer' allocs,-and 20% to 'power'.--At one stage I replaced this condition by 'True' (leading to the above-slow-down).  The motivation was test eyeball/inline1.hs; but that seems-to work ok now.--NOTE: arguably, we should inline in ArgCtxt only if the result of the-call is at least CONLIKE.  At least for the cases where we use ArgCtxt-for the RHS of a 'let', we only profit from the inlining if we get a-CONLIKE thing (modulo lets).--Note [Lone variables]-~~~~~~~~~~~~~~~~~~~~~-See also Note [Interaction of exprIsWorkFree and lone variables]-which appears below--The "lone-variable" case is important.  I spent ages messing about-with unsatisfactory variants, but this is nice.  The idea is that if a-variable appears all alone--        as an arg of lazy fn, or rhs    BoringCtxt-        as scrutinee of a case          CaseCtxt-        as arg of a fn                  ArgCtxt-AND-        it is bound to a cheap expression--then we should not inline it (unless there is some other reason,-e.g. it is the sole occurrence).  That is what is happening at-the use of 'lone_variable' in 'interesting_call'.--Why?  At least in the case-scrutinee situation, turning-        let x = (a,b) in case x of y -> ...-into-        let x = (a,b) in case (a,b) of y -> ...-and thence to-        let x = (a,b) in let y = (a,b) in ...-is bad if the binding for x will remain.--Another example: I discovered that strings-were getting inlined straight back into applications of 'error'-because the latter is strict.-        s = "foo"-        f = \x -> ...(error s)...--Fundamentally such contexts should not encourage inlining because, provided-the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the-context can ``see'' the unfolding of the variable (e.g. case or a-RULE) so there's no gain.--However, watch out:-- * Consider this:-        foo = \n. [n])  {-# INLINE foo #-}-        bar = foo 20    {-# INLINE bar #-}-        baz = \n. case bar of { (m:_) -> m + n }-   Here we really want to inline 'bar' so that we can inline 'foo'-   and the whole thing unravels as it should obviously do.  This is-   important: in the NDP project, 'bar' generates a closure data-   structure rather than a list.--   So the non-inlining of lone_variables should only apply if the-   unfolding is regarded as expandable; because that is when-   exprIsConApp_maybe looks through the unfolding.  Hence the "&&-   is_exp" in the CaseCtxt branch of interesting_call-- * Even a type application or coercion isn't a lone variable.-   Consider-        case $fMonadST @ RealWorld of { :DMonad a b c -> c }-   We had better inline that sucker!  The case won't see through it.--   For now, I'm treating treating a variable applied to types-   in a *lazy* context "lone". The motivating example was-        f = /\a. \x. BIG-        g = /\a. \y.  h (f a)-   There's no advantage in inlining f here, and perhaps-   a significant disadvantage.  Hence some_val_args in the Stop case--Note [Interaction of exprIsWorkFree and lone variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The lone-variable test says "don't inline if a case expression-scrutinises a lone variable whose unfolding is cheap".  It's very-important that, under these circumstances, exprIsConApp_maybe-can spot a constructor application. So, for example, we don't-consider-        let x = e in (x,x)-to be cheap, and that's good because exprIsConApp_maybe doesn't-think that expression is a constructor application.--In the 'not (lone_variable && is_wf)' test, I used to test is_value-rather than is_wf, which was utterly wrong, because the above-expression responds True to exprIsHNF, which is what sets is_value.--This kind of thing can occur if you have--        {-# INLINE foo #-}-        foo = let x = e in (x,x)--which Roman did.----}--computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt-                -> Int-computeDiscount arg_discounts res_discount arg_infos cont_info--  = 10          -- Discount of 10 because the result replaces the call-                -- so we count 10 for the function itself--    + 10 * length actual_arg_discounts-               -- Discount of 10 for each arg supplied,-               -- because the result replaces the call--    + total_arg_discount + res_discount'-  where-    actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos-    total_arg_discount   = sum actual_arg_discounts--    mk_arg_discount _        TrivArg    = 0-    mk_arg_discount _        NonTrivArg = 10-    mk_arg_discount discount ValueArg   = discount--    res_discount'-      | LT <- arg_discounts `compareLength` arg_infos-      = res_discount   -- Over-saturated-      | otherwise-      = case cont_info of-           BoringCtxt  -> 0-           CaseCtxt    -> res_discount  -- Presumably a constructor-           ValAppCtxt  -> res_discount  -- Presumably a function-           _           -> 40 `min` res_discount-                -- ToDo: this 40 `min` res_discount doesn't seem right-                --   for DiscArgCtxt it shouldn't matter because the function will-                --       get the arg discount for any non-triv arg-                --   for RuleArgCtxt we do want to be keener to inline; but not only-                --       constructor results-                --   for RhsCtxt I suppose that exposing a data con is good in general-                --   And 40 seems very arbitrary-                ---                -- res_discount can be very large when a function returns-                -- constructors; but we only want to invoke that large discount-                -- when there's a case continuation.-                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.-                -- But we want to avoid inlining large functions that return-                -- constructors into contexts that are simply "interesting"
compiler/GHC/Core/Unfold/Make.hs view
@@ -57,6 +57,7 @@   = mkUnfolding opts src                 True {- Top level -}                 (isDeadEndSig strict_sig)+                False {- Not a join point -}                 expr  -- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first@@ -79,14 +80,24 @@  mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs-  = mkUnfolding opts VanillaSrc False False rhs Nothing+  = mkUnfolding opts VanillaSrc False False False rhs Nothing  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 }-                  -- See Note [Occurrence analysis of unfoldings]+                  -- See Note [OccInfo in unfoldings and rules] in GHC.Core  mkDataConUnfolding :: CoreExpr -> Unfolding -- Used for non-newtype data constructors with non-trivial wrappers@@ -96,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@@ -117,7 +131,7 @@   = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance   where     new_tmpl = simpleOptExpr opts (work_fn tmpl)-    guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl+    guidance = calcUnfoldingGuidance (so_uf_opts opts) False False new_tmpl  mkWorkerUnfolding _ _ _ = noUnfolding @@ -156,7 +170,7 @@  mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding mkInlinableUnfolding opts src expr-  = mkUnfolding (so_uf_opts opts) src False False expr' Nothing+  = mkUnfolding (so_uf_opts opts) src False False False expr' Nothing   where     expr' = simpleOptExpr opts expr @@ -183,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@@ -319,16 +336,17 @@             -> Bool       -- Is top-level             -> Bool       -- Definitely a bottoming binding                           -- (only relevant for top-level bindings)+            -> Bool       -- True <=> join point             -> CoreExpr             -> Maybe UnfoldingCache             -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it-mkUnfolding opts src top_lvl is_bottoming expr cache+mkUnfolding opts src top_lvl is_bottoming is_join expr cache   = mkCoreUnfolding src top_lvl expr cache guidance   where     is_top_bottoming = top_lvl && is_bottoming-    guidance         = calcUnfoldingGuidance opts is_top_bottoming expr+    guidance         = calcUnfoldingGuidance opts is_top_bottoming is_join expr         -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!         -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] @@ -338,7 +356,7 @@ mkCoreUnfolding src top_lvl expr precomputed_cache guidance   = CoreUnfolding { uf_tmpl = cache `seq`                               occurAnalyseExpr expr-      -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]+      -- occAnalyseExpr: see Note [OccInfo in unfoldings and rules] in GHC.Core       -- See #20905 for what a discussion of this 'seq'.       -- We are careful to make sure we only       -- have one copy of an unfolding around at once.@@ -459,7 +477,7 @@ a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding.  * The template of the unfolding is the result of performing occurrence analysis-  (Note [Occurrence analysis of unfoldings])+  (Note [OccInfo in unfoldings and rules] in GHC.Core) * Predicates are applied to the unanalysed expression  Therefore if we are not thoughtful about forcing you can end up in a situation where the
compiler/GHC/Core/Unify.hs view
@@ -11,2093 +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.Utils.Panic.Plain-import GHC.Data.FastString--import Data.List ( mapAccumL )-import Control.Monad-import qualified Data.Semigroup as S--{---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-                      (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-                      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.---}---- | 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-                       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 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-             -> 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 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_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.Canonical), 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.--}---------------- 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 [Comparing nullary type synonyms] in GHC.Core.Type.-  | 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_tys env 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--        -- 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_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-  deriving (Functor)--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)--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 (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) }--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 _) ty1)-                       (ForAllCo tv2 kind_co2 co2)-                       lkco rkco-  | isTyVar tv1 && isTyVar tv2-  = 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 _) ty, r)-      -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))-    -- NB: NoRefl variant. Otherwise, we get a loop!-    _ -> 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
@@ -6,17 +6,19 @@   , bottomUE   , deleteUE   , lookupUE+  , popUE   , scaleUE   , scaleUsage   , supUE   , supUEs-  , unitUE+  , singleUsageUE   , zeroUE   ) where  import Data.Foldable import GHC.Prelude import GHC.Core.Multiplicity+import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable@@ -54,8 +56,13 @@ -- For now, we use extra multiplicity Bottom for empty case. data UsageEnv = UsageEnv !(NameEnv Mult) Bool -unitUE :: NamedThing n => n -> Mult -> UsageEnv-unitUE x w = UsageEnv (unitNameEnv (getName x) w) False+-- | Record a single usage of an Id, i.e. {n: 1}+-- Exception: We do not record external names (both GlobalIds and top-level LocalIds)+-- because they're not relevant to linearity checking.+singleUsageUE :: Id -> UsageEnv+singleUsageUE x | isExternalName n = zeroUE+                | otherwise = UsageEnv (unitNameEnv n OneTy) False+  where n = getName x  zeroUE, bottomUE :: UsageEnv zeroUE = UsageEnv emptyNameEnv False@@ -83,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@@ -97,6 +108,9 @@   case lookupNameEnv e (getName x) of     Just w  -> MUsage w     Nothing -> if has_bottom then Bottom else Zero++popUE :: NamedThing n => UsageEnv -> n -> (Usage, UsageEnv)+popUE ue x = (lookupUE ue x, deleteUE ue x)  instance Outputable UsageEnv where   ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b
compiler/GHC/Core/Utils.hs view
@@ -11,2668 +11,3056 @@         -- * Constructing expressions         mkCast, mkCastMCo, mkPiMCo,         mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,-        bindNonRec, needsCaseBinding,-        mkAltExpr, mkDefaultCase, mkSingleAltCase,--        -- * Taking expressions apart-        findDefault, addDefault, findAlt, isDefaultAlt,-        mergeAlts, trimConArgs,-        filterAlts, combineIdenticalAlts, refineDefaultAlt,-        scaleAltsBy,--        -- * Properties of expressions-        exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,-        mkFunctionType,-        exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,-        trivial_expr_fold,-        exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,-        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,-        exprIsWorkFree, exprIsConLike,-        isCheapApp, isExpandableApp, isSaturatedConApp,-        exprIsTickedString, exprIsTickedString_maybe,-        exprIsTopLevelBindable,-        altsAreExhaustive, etaExpansionTick,--        -- * Equality-        cheapEqExpr, cheapEqExpr', diffBinds,--        -- * Manipulating data constructors and types-        exprToType,-        applyTypeToArgs,-        dataConRepInstPat, dataConRepFSInstPat,-        isEmptyTy, normSplitTyConApp_maybe,--        -- * Working with ticks-        stripTicksTop, stripTicksTopE, stripTicksTopT,-        stripTicksE, stripTicksT,--        -- * InScopeSet things which work over CoreBinds-        mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,--        -- * StaticPtr-        collectMakeStaticArgs,--        -- * Join points-        isJoinBind,--        -- * Tag inference-        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,--        -- * unsafeEqualityProof-        isUnsafeEqualityProof,--        -- * Dumping stuff-        dumpIdInfoOfProgram-    ) where--import GHC.Prelude-import GHC.Platform--import GHC.Core-import GHC.Core.Ppr-import GHC.Core.DataCon-import GHC.Core.Type as Type-import GHC.Core.FamInstEnv-import GHC.Core.TyCo.Compare( eqType, eqTypeX )-import GHC.Core.Coercion-import GHC.Core.Reduction-import GHC.Core.TyCon-import GHC.Core.Multiplicity--import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )-import GHC.Builtin.PrimOps--import GHC.Types.Var-import GHC.Types.SrcLoc-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name-import GHC.Types.Literal-import GHC.Types.Tickish-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Basic( Arity, Levity(..)-                       )-import GHC.Types.Unique-import GHC.Types.Unique.Set-import GHC.Types.Demand--import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Data.List.SetOps( minusList )-import GHC.Data.OrdList--import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc--import Data.ByteString     ( ByteString )-import Data.Function       ( on )-import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )-import Data.Ord            ( comparing )-import qualified Data.Set as Set-import GHC.Types.RepType (isZeroBitTy)--{--************************************************************************-*                                                                      *-\subsection{Find the type of a Core atom/expression}-*                                                                      *-************************************************************************--}--exprType :: HasDebugCallStack => CoreExpr -> Type--- ^ Recover the type of a well-typed Core expression. Fails when--- applied to the actual 'GHC.Core.Type' expression as it cannot--- really be said to have a type-exprType (Var var)           = idType var-exprType (Lit lit)           = literalType lit-exprType (Coercion co)       = coercionType co-exprType (Let bind body)-  | NonRec tv rhs <- bind    -- See Note [Type bindings]-  , Type ty <- rhs           = substTyWithUnchecked [tv] [ty] (exprType body)-  | otherwise                = exprType body-exprType (Case _ _ ty _)     = ty-exprType (Cast _ co)         = coercionRKind co-exprType (Tick _ e)          = exprType e-exprType (Lam binder expr)   = mkLamType binder (exprType expr)-exprType e@(App _ _)-  = case collectArgs e of-        (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args--exprType other = pprPanic "exprType" (pprCoreExpr other)--coreAltType :: CoreAlt -> Type--- ^ Returns the type of the alternatives right hand side-coreAltType alt@(Alt _ bs rhs)-  = case occCheckExpand bs rhs_ty of-      -- Note [Existential variables and silly type synonyms]-      Just ty -> ty-      Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty)-  where-    rhs_ty = exprType rhs--coreAltsType :: [CoreAlt] -> Type--- ^ Returns the type of the first alternative, which should be the same as for all alternatives-coreAltsType (alt:_) = coreAltType alt-coreAltsType []      = panic "coreAltsType"--mkLamType  :: HasDebugCallStack => Var -> Type -> Type--- ^ Makes a @(->)@ type or an implicit forall type, depending--- on whether it is given a type variable or a term variable.--- This is used, for example, when producing the type of a lambda.--- Always uses Inferred binders.-mkLamTypes :: [Var] -> Type -> Type--- ^ 'mkLamType' for multiple type or value arguments--mkLamType v body_ty-   | isTyVar v-   = mkForAllTy (Bndr v Inferred) body_ty--   | isCoVar v-   , v `elemVarSet` tyCoVarsOfType body_ty-   = mkForAllTy (Bndr v Required) body_ty--   | otherwise-   = mkFunctionType (varMult v) (varType v) body_ty--mkLamTypes vs ty = foldr mkLamType ty vs--{--Note [Type bindings]-~~~~~~~~~~~~~~~~~~~~-Core does allow type bindings, although such bindings are-not much used, except in the output of the desugarer.-Example:-     let a = Int in (\x:a. x)-Given this, exprType must be careful to substitute 'a' in the-result type (#8522).--Note [Existential variables and silly type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        data T = forall a. T (Funny a)-        type Funny a = Bool-        f :: T -> Bool-        f (T x) = x--Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.-That means that 'exprType' and 'coreAltsType' may give a result that *appears*-to mention an out-of-scope type variable.  See #3409 for a more real-world-example.--Various possibilities suggest themselves:-- - Ignore the problem, and make Lint not complain about such variables-- - Expand all type synonyms (or at least all those that discard arguments)-      This is tricky, because at least for top-level things we want to-      retain the type the user originally specified.-- - Expand synonyms on the fly, when the problem arises. That is what-   we are doing here.  It's not too expensive, I think.--Note that there might be existentially quantified coercion variables, too.--}--applyTypeToArgs :: HasDebugCallStack => SDoc -> 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-  = go op_ty args-  where-    go op_ty []                   = op_ty-    go op_ty (Type ty : args)     = go_ty_args op_ty [ty] args-    go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args-    go op_ty (_ : args)           | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty-                                  = go res_ty args-    go _ args = pprPanic "applyTypeToArgs" (panic_msg args)--    -- go_ty_args: accumulate type arguments so we can-    -- instantiate all at once with piResultTys-    go_ty_args op_ty rev_tys (Type ty : args)-       = go_ty_args op_ty (ty:rev_tys) args-    go_ty_args op_ty rev_tys (Coercion co : args)-       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args-    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-                        , text "Args:" <+> ppr args-                        , text "Args':" <+> ppr as ]--mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr-mkCastMCo e MRefl    = e-mkCastMCo e (MCo co) = Cast e co-  -- We are careful to use (MCo co) only when co is not reflexive-  -- Hence (Cast e co) rather than (mkCast e co)--mkPiMCo :: Var -> MCoercionR -> MCoercionR-mkPiMCo _  MRefl   = MRefl-mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)---{- *********************************************************************-*                                                                      *-             Casts-*                                                                      *-********************************************************************* -}---- | Wrap the given expression in the coercion safely, dropping--- identity coercions and coalescing nested coercions-mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr-mkCast e co-  | assertPpr (coercionRole co == Representational)-              (text "coercion" <+> ppr co <+> text "passed to mkCast"-               <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $-    isReflCo co-  = e--mkCast (Coercion e_co) co-  | isCoVarType (coercionRKind co)-       -- The guard here checks that g has a (~#) on both sides,-       -- otherwise decomposeCo fails.  Can in principle happen-       -- with unsafeCoerce-  = Coercion (mkCoCast e_co co)--mkCast (Cast expr co2) co-  = warnPprTrace (let { from_ty = coercionLKind co;-                        to_ty2  = coercionRKind co2 } in-                     not (from_ty `eqType` to_ty2))-             "mkCast"-             (vcat ([ text "expr:" <+> ppr expr-                   , text "co2:" <+> ppr co2-                   , text "co:" <+> ppr co ])) $-    mkCast expr (mkTransCo co2 co)--mkCast (Tick t expr) co-   = Tick t (mkCast expr co)--mkCast expr co-  = let from_ty = coercionLKind co in-    warnPprTrace (not (from_ty `eqType` exprType expr))-          "Trying to coerce" (text "(" <> ppr expr-          $$ text "::" <+> ppr (exprType expr) <> text ")"-          $$ ppr co $$ ppr (coercionType co)-          $$ callStackDoc) $-    (Cast expr co)---{- *********************************************************************-*                                                                      *-             Attaching ticks-*                                                                      *-********************************************************************* -}---- | Wraps the given expression in the source annotation, dropping the--- annotation if possible.-mkTick :: CoreTickish -> CoreExpr -> CoreExpr-mkTick t orig_expr = mkTick' id id orig_expr- where-  -- Some ticks (cost-centres) can be split in two, with the-  -- non-counting part having laxer placement properties.-  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t--  -- mkTick' handles floating of ticks *into* the expression.-  -- In this function, `top` is applied after adding the tick, and `rest` before.-  -- This will result in applications that look like (top $ Tick t $ rest expr).-  -- If we want to push the tick deeper, we pre-compose `top` with a function-  -- adding the tick.-  mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through)-          -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with)-          -> CoreExpr               -- current expression-          -> CoreExpr-  mkTick' top rest expr = case expr of--    -- Cost centre ticks should never be reordered relative to each-    -- other. Therefore we can stop whenever two collide.-    Tick t2 e-      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr--    -- Otherwise we assume that ticks of different placements float-    -- through each other.-      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e--    -- For annotations this is where we make sure to not introduce-    -- redundant ticks.-      | tickishContains t t2              -> mkTick' top rest e-      | tickishContains t2 t              -> orig_expr-      | otherwise                         -> mkTick' top (rest . Tick t2) e--    -- Ticks don't care about types, so we just float all ticks-    -- through them. Note that it's not enough to check for these-    -- cases top-level. While mkTick will never produce Core with type-    -- expressions below ticks, such constructs can be the result of-    -- unfoldings. We therefore make an effort to put everything into-    -- the right place no matter what we start with.-    Cast e co   -> mkTick' (top . flip Cast co) rest e-    Coercion co -> Coercion co--    Lam x e-      -- Always float through type lambdas. Even for non-type lambdas,-      -- floating is allowed for all but the most strict placement rule.-      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime-      -> mkTick' (top . Lam x) rest e--      -- If it is both counting and scoped, we split the tick into its-      -- two components, often allowing us to keep the counting tick on-      -- the outside of the lambda and push the scoped tick inside.-      -- The point of this is that the counting tick can probably be-      -- floated, and the lambda may then be in a position to be-      -- beta-reduced.-      | canSplit-      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e--    App f arg-      -- Always float through type applications.-      | not (isRuntimeArg arg)-      -> mkTick' (top . flip App arg) rest f--      -- We can also float through constructor applications, placement-      -- permitting. Again we can split.-      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)-      -> if tickishPlace t == PlaceCostCentre-         then top $ rest $ tickHNFArgs t expr-         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr--    Var x-      | notFunction && tickishPlace t == PlaceCostCentre-      -> orig_expr-      | notFunction && canSplit-      -> top $ Tick (mkNoScope t) $ rest expr-      where-        -- SCCs can be eliminated on variables provided the variable-        -- is not a function.  In these cases the SCC makes no difference:-        -- the cost of evaluating the variable will be attributed to its-        -- definition site.  When the variable refers to a function, however,-        -- an SCC annotation on the variable affects the cost-centre stack-        -- when the function is called, so we must retain those.-        notFunction = not (isFunTy (idType x))--    Lit{}-      | tickishPlace t == PlaceCostCentre-      -> orig_expr--    -- Catch-all: Annotate where we stand-    _any -> top $ Tick t $ rest expr--mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr-mkTicks ticks expr = foldr mkTick expr ticks--isSaturatedConApp :: CoreExpr -> Bool-isSaturatedConApp e = go e []-  where go (App f a) as = go f (a:as)-        go (Var fun) args-           = isConLikeId fun && idArity fun == valArgCount args-        go (Cast f _) as = go f as-        go _ _ = False--mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr-mkTickNoHNF t e-  | exprIsHNF e = tickHNFArgs t e-  | otherwise   = mkTick t e---- push a tick into the arguments of a HNF (call or constructor app)-tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr-tickHNFArgs t e = push t e- where-  push t (App f (Type u)) = App (push t f) (Type u)-  push t (App f arg) = App (push t f) (mkTick t arg)-  push _t e = e---- | Strip ticks satisfying a predicate from top of an expression-stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)-stripTicksTop p = go []-  where go ts (Tick t e) | p t = go (t:ts) e-        go ts other            = (reverse ts, other)---- | Strip ticks satisfying a predicate from top of an expression,--- returning the remaining expression-stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b-stripTicksTopE p = go-  where go (Tick t e) | p t = go e-        go other            = other---- | Strip ticks satisfying a predicate from top of an expression,--- returning the ticks-stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]-stripTicksTopT p = go []-  where go ts (Tick t e) | p t = go (t:ts) e-        go ts _                = ts---- | Completely strip ticks satisfying a predicate from an--- expression. Note this is O(n) in the size of the expression!-stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b-stripTicksE p expr = go expr-  where go (App e a)        = App (go e) (go a)-        go (Lam b e)        = Lam b (go e)-        go (Let b e)        = Let (go_bs b) (go e)-        go (Case e b t as)  = Case (go e) b t (map go_a as)-        go (Cast e c)       = Cast (go e) c-        go (Tick t e)-          | p t             = go e-          | otherwise       = Tick t (go e)-        go other            = other-        go_bs (NonRec b e)  = NonRec b (go e)-        go_bs (Rec bs)      = Rec (map go_b bs)-        go_b (b, e)         = (b, go e)-        go_a (Alt c bs e)   = Alt c bs (go e)--stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]-stripTicksT p expr = fromOL $ go expr-  where go (App e a)        = go e `appOL` go a-        go (Lam _ e)        = go e-        go (Let b e)        = go_bs b `appOL` go e-        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)-        go (Cast e _)       = go e-        go (Tick t e)-          | p t             = t `consOL` go e-          | otherwise       = go e-        go _                = nilOL-        go_bs (NonRec _ e)  = go e-        go_bs (Rec bs)      = concatOL (map go_b bs)-        go_b (_, e)         = go e-        go_a (Alt _ _ e)    = go e--{--************************************************************************-*                                                                      *-\subsection{Other expression construction}-*                                                                      *-************************************************************************--}--bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr--- ^ @bindNonRec x r b@ produces either:------ > let x = r in b------ or:------ > case r of x { _DEFAULT_ -> b }------ depending on whether we have to use a @case@ or @let@--- binding for the expression (see 'needsCaseBinding').--- It's used by the desugarer to avoid building bindings--- that give Core Lint a heart attack, although actually--- the simplifier deals with them perfectly well. See--- also 'GHC.Core.Make.mkCoreLet'-bindNonRec bndr rhs body-  | isTyVar bndr                       = let_bind-  | isCoVar bndr                       = if isCoArg rhs then let_bind-    {- See Note [Binding coercions] -}                  else case_bind-  | isJoinId bndr                      = let_bind-  | needsCaseBinding (idType bndr) rhs = case_bind-  | otherwise                          = let_bind-  where-    case_bind = mkDefaultCase rhs bndr body-    let_bind  = Let (NonRec bndr rhs) body---- | Tests whether we have to use a @case@ rather than @let@ binding for this--- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant"-needsCaseBinding :: Type -> CoreExpr -> Bool-needsCaseBinding ty rhs-  = mightBeUnliftedType ty && not (exprOkForSpeculation rhs)-        -- Make a case expression instead of a let-        -- These can arise either from the desugarer,-        -- or from beta reductions: (\x.e) (x +# y)--mkAltExpr :: AltCon     -- ^ Case alternative constructor-          -> [CoreBndr] -- ^ Things bound by the pattern match-          -> [Type]     -- ^ The type arguments to the case alternative-          -> CoreExpr--- ^ This guy constructs the value that the scrutinee must have--- given that you are in one particular branch of a case-mkAltExpr (DataAlt con) args inst_tys-  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)-mkAltExpr (LitAlt lit) [] []-  = Lit lit-mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"-mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"--mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr--- Make (case x of y { DEFAULT -> e }-mkDefaultCase scrut case_bndr body-  = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body]--mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr--- Use this function if possible, when building a case,--- because it ensures that the type on the Case itself--- doesn't mention variables bound by the case--- See Note [Care with the type of a case expression]-mkSingleAltCase scrut case_bndr con bndrs body-  = Case scrut case_bndr case_ty [Alt con bndrs body]-  where-    body_ty = exprType body--    case_ty -- See Note [Care with the type of a case expression]-      | Just body_ty' <- occCheckExpand bndrs body_ty-      = body_ty'--      | otherwise-      = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty)--{- Note [Care with the type of a case expression]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a phantom type synonym-   type S a = Int-and we want to form the case expression-   case x of K (a::*) -> (e :: S a)--We must not make the type field of the case-expression (S a) because-'a' isn't in scope.  Hence the call to occCheckExpand.  This caused-issue #17056.--NB: this situation can only arise with type synonyms, which can-falsely "mention" type variables that aren't "really there", and which-can be eliminated by expanding the synonym.--Note [Binding coercions]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider binding a CoVar, c = e.  Then, we must satisfy-Note [Core type and coercion invariant] in GHC.Core,-which allows only (Coercion co) on the RHS.--************************************************************************-*                                                                      *-               Operations over case alternatives-*                                                                      *-************************************************************************--The default alternative must be first, if it exists at all.-This makes it easy to find, though it makes matching marginally harder.--}---- | Extract the default case alternative-findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))-findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)-findDefault alts                          =                    (alts, Nothing)--addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]-addDefault alts Nothing    = alts-addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts--isDefaultAlt :: Alt b -> Bool-isDefaultAlt (Alt DEFAULT _ _) = True-isDefaultAlt _                 = False---- | Find the case alternative corresponding to a particular--- constructor: panics if no such constructor exists-findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)-    -- A "Nothing" result *is* legitimate-    -- See Note [Unreachable code]-findAlt con alts-  = case alts of-        (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt)-        _                              -> go alts Nothing-  where-    go []                     deflt = deflt-    go (alt@(Alt con1 _ _) : alts) deflt-      = case con `cmpAltCon` con1 of-          LT -> deflt   -- Missed it already; the alts are in increasing order-          EQ -> Just alt-          GT -> assert (not (con1 == DEFAULT)) $ go alts deflt--{- Note [Unreachable code]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It is possible (although unusual) for GHC to find a case expression-that cannot match.  For example:--     data Col = Red | Green | Blue-     x = Red-     f v = case x of-              Red -> ...-              _ -> ...(case x of { Green -> e1; Blue -> e2 })...--Suppose that for some silly reason, x isn't substituted in the case-expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff-gets in the way; cf #3118.)  Then the full-laziness pass might produce-this--     x = Red-     lvl = case x of { Green -> e1; Blue -> e2 })-     f v = case x of-             Red -> ...-             _ -> ...lvl...--Now if x gets inlined, we won't be able to find a matching alternative-for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing-we generate (error "Inaccessible alternative").--Similar things can happen (augmented by GADTs) when the Simplifier-filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase.--}------------------------------------mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]--- ^ Merge alternatives preserving order; alternatives in--- the first argument shadow ones in the second-mergeAlts [] as2 = as2-mergeAlts as1 [] = as1-mergeAlts (a1:as1) (a2:as2)-  = case a1 `cmpAlt` a2 of-        LT -> a1 : mergeAlts as1      (a2:as2)-        EQ -> a1 : mergeAlts as1      as2       -- Discard a2-        GT -> a2 : mergeAlts (a1:as1) as2-------------------------------------trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]--- ^ Given:------ > case (C a b x y) of--- >        C b x y -> ...------ We want to drop the leading type argument of the scrutinee--- leaving the arguments to match against the pattern--trimConArgs DEFAULT      args = assert (null args) []-trimConArgs (LitAlt _)   args = assert (null args) []-trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args--filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)-           -> [Type]               -- ^ And its type arguments-           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee-           -> [Alt b] -- ^ Alternatives-           -> ([AltCon], [Alt b])-             -- Returns:-             --  1. Constructors that will never be encountered by the-             --     *default* case (if any).  A superset of imposs_cons-             --  2. The new alternatives, trimmed by-             --        a) remove imposs_cons-             --        b) remove constructors which can't match because of GADTs-             ---             -- NB: the final list of alternatives may be empty:-             -- This is a tricky corner case.  If the data type has no constructors,-             -- which GHC allows, or if the imposs_cons covers all constructors (after taking-             -- account of GADTs), then no alternatives can match.-             ---             -- If callers need to preserve the invariant that there is always at least one branch-             -- in a "case" statement then they will need to manually add a dummy case branch that just-             -- calls "error" or similar.-filterAlts _tycon inst_tys imposs_cons alts-  = imposs_deflt_cons `seqList`-      (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)-  -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which-  -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter-  -- leads to a huge space leak (see #22102 and !8896)-  where-    (alts_wo_default, maybe_deflt) = findDefault alts-    alt_cons = [con | Alt con _ _ <- alts_wo_default]--    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default--    imposs_cons_set = Set.fromList imposs_cons-    imposs_deflt_cons =-      imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons-         -- "imposs_deflt_cons" are handled-         --   EITHER by the context,-         --   OR by a non-DEFAULT branch in this case expression.--    impossible_alt :: [Type] -> Alt b -> Bool-    impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True-    impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con-    impossible_alt _  _                             = False---- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.--- See Note [Refine DEFAULT case alternatives]-refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders-                 -> Mult              -- ^ Multiplicity annotation of the case expression-                 -> TyCon             -- ^ Type constructor of scrutinee's type-                 -> [Type]            -- ^ Type arguments of scrutinee's type-                 -> [AltCon]          -- ^ Constructors that cannot match the DEFAULT (if any)-                 -> [CoreAlt]-                 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt'-refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts-  | Alt DEFAULT _ rhs : rest_alts <- all_alts-  , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.-  , not (isNewTyCon tycon)      -- Exception 1 in Note [Refine DEFAULT case alternatives]-  , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives]-  , Just all_cons <- tyConDataCons_maybe tycon-  , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons]-                             -- We now know it's a data type, so we can use-                             -- UniqSet rather than Set (more efficient)-        impossible con   = con `elementOfUniqSet` imposs_data_cons-                             || dataConCannotMatch tys con-  = case filterOut impossible all_cons of-       -- Eliminate the default alternative-       -- altogether if it can't match:-       []    -> (False, rest_alts)--       -- It matches exactly one constructor, so fill it in:-       [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs])-                       -- We need the mergeAlts to keep the alternatives in the right order-             where-                (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys--       -- It matches more than one, so do nothing-       _  -> (False, all_alts)--  | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)-  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)-        -- Check for no data constructors-        -- This can legitimately happen for abstract types and type families,-        -- so don't report that-  = (False, all_alts)--  | otherwise      -- The common case-  = (False, all_alts)--{- Note [Refine DEFAULT case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-refineDefaultAlt replaces the DEFAULT alt with a constructor if there-is one possible value it could be.--The simplest example being-    foo :: () -> ()-    foo x = case x of !_ -> ()-which rewrites to-    foo :: () -> ()-    foo x = case x of () -> ()--There are two reasons in general why replacing a DEFAULT alternative-with a specific constructor is desirable.--1. We can simplify inner expressions.  For example--       data Foo = Foo1 ()--       test :: Foo -> ()-       test x = case x of-                  DEFAULT -> mid (case x of-                                    Foo1 x1 -> x1)--   refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then-   x becomes bound to `Foo ip1` so is inlined into the other case-   which causes the KnownBranch optimisation to kick in. If we don't-   refine DEFAULT to `Foo ip1`, we are left with both case expressions.--2. combineIdenticalAlts does a better job. For example (Simon Jacobi)-       data D = C0 | C1 | C2--       case e of-         DEFAULT -> e0-         C0      -> e1-         C1      -> e1--   When we apply combineIdenticalAlts to this expression, it can't-   combine the alts for C0 and C1, as we already have a default case.-   But if we apply refineDefaultAlt first, we get-       case e of-         C0 -> e1-         C1 -> e1-         C2 -> e0-   and combineIdenticalAlts can turn that into-       case e of-         DEFAULT -> e1-         C2 -> e0--   It isn't obvious that refineDefaultAlt does this but if you look-   at its one call site in GHC.Core.Opt.Simplify.Utils then the-   `imposs_deflt_cons` argument is populated with constructors which-   are matched elsewhere.--There are two exceptions where we avoid refining a DEFAULT case:--* Exception 1: Newtypes--  We can have a newtype, if we are just doing an eval:--    case x of { DEFAULT -> e }--  And we don't want to fill in a default for them!--* Exception 2: `type data` declarations--  The data constructors for a `type data` declaration (see-  Note [Type data declarations] in GHC.Rename.Module) do not exist at the-  value level. Nevertheless, it is possible to strictly evaluate a value-  whose type is a `type data` declaration. Test case-  type-data/should_compile/T2294b.hs contains an example:--    type data T a where-      A :: T Int--    f :: T a -> ()-    f !x = ()--  We want to generate the following Core for f:--    f = \(@a) (x :: T a) ->-         case x of-           __DEFAULT -> ()--  Namely, we do _not_ want to match on `A`, as it doesn't exist at the value-  level!--Note [Combine identical alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If several alternatives are identical, merge them into a single-DEFAULT alternative.  I've occasionally seen this making a big-difference:--     case e of               =====>     case e of-       C _ -> f x                         D v -> ....v....-       D v -> ....v....                   DEFAULT -> f x-       DEFAULT -> f x--The point is that we merge common RHSs, at least for the DEFAULT case.-[One could do something more elaborate but I've never seen it needed.]-To avoid an expensive test, we just merge branches equal to the *first*-alternative; this picks up the common cases-     a) all branches equal-     b) some branches equal to the DEFAULT (which occurs first)--The case where Combine Identical Alternatives transformation showed up-was like this (base/Foreign/C/Err/Error.hs):--        x | p `is` 1 -> e1-          | p `is` 2 -> e2-        ...etc...--where @is@ was something like--        p `is` n = p /= (-1) && p == n--This gave rise to a horrible sequence of cases--        case p of-          (-1) -> $j p-          1    -> e1-          DEFAULT -> $j p--and similarly in cascade for all the join points!--Note [Combine identical alternatives: wrinkles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--* It's important that we try to combine alternatives *before*-  simplifying them, rather than after. Reason: because-  Simplify.simplAlt may zap the occurrence info on the binders in the-  alternatives, which in turn defeats combineIdenticalAlts use of-  isDeadBinder (see #7360).--  You can see this in the call to combineIdenticalAlts in-  GHC.Core.Opt.Simplify.Utils.prepareAlts.  Here the alternatives have type InAlt-  (the "In" meaning input) rather than OutAlt.--* combineIdenticalAlts does not work well for nullary constructors-      case x of y-         []    -> f []-         (_:_) -> f y-  Here we won't see that [] and y are the same.  Sigh! This problem-  is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version-  of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have-  here.-  See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE).--Note [Care with impossible-constructors when combining alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have (#10538)-   data T = A | B | C | D--      case x::T of   (Imposs-default-cons {A,B})-         DEFAULT -> e1-         A -> e2-         B -> e1--When calling combineIdentialAlts, we'll have computed that the-"impossible constructors" for the DEFAULT alt is {A,B}, since if x is-A or B we'll take the other alternatives.  But suppose we combine B-into the DEFAULT, to get--      case x::T of   (Imposs-default-cons {A})-         DEFAULT -> e1-         A -> e2--Then we must be careful to trim the impossible constructors to just {A},-else we risk compiling 'e1' wrong!--Not only that, but we take care when there is no DEFAULT beforehand,-because we are introducing one.  Consider--   case x of   (Imposs-default-cons {A,B,C})-     A -> e1-     B -> e2-     C -> e1--Then when combining the A and C alternatives we get--   case x of   (Imposs-default-cons {B})-     DEFAULT -> e1-     B -> e2--Note that we have a new DEFAULT branch that we didn't have before.  So-we need delete from the "impossible-default-constructors" all the-known-con alternatives that we have eliminated. (In #11172 we-missed the first one.)---}--combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT-                     -> [CoreAlt]-                     -> (Bool,      -- True <=> something happened-                         [AltCon],  -- New constructors that cannot match DEFAULT-                         [CoreAlt]) -- New alternatives--- See Note [Combine identical alternatives]--- True <=> we did some combining, result is a single DEFAULT alternative-combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)-  | all isDeadBinder bndrs1    -- Remember the default-  , not (null elim_rest) -- alternative comes first-  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)-  where-    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts-    deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1)--     -- See Note [Care with impossible-constructors when combining alternatives]-    imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons-    elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest-    elim_con1 = case con1 of     -- Don't forget con1!-                  DEFAULT -> []-                  _       -> [con1]--    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2-    identical_to_alt1 (Alt _con bndrs rhs)-      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1-    tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest--combineIdenticalAlts imposs_cons alts-  = (False, imposs_cons, alts)---- Scales the multiplicity of the binders of a list of case alternatives. That--- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled.-scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]-scaleAltsBy w alts = map scaleAlt alts-  where-    scaleAlt :: CoreAlt -> CoreAlt-    scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs--    scaleBndr :: CoreBndr -> CoreBndr-    scaleBndr b = scaleVarBy w b---{- *********************************************************************-*                                                                      *-             exprIsTrivial-*                                                                      *-************************************************************************--Note [exprIsTrivial]-~~~~~~~~~~~~~~~~~~~~-@exprIsTrivial@ is true of expressions we are unconditionally happy to-                duplicate; simple variables and constants, and type-                applications.  Note that primop Ids aren't considered-                trivial unless--Note [Variables are trivial]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There used to be a gruesome test for (hasNoBinding v) in the-Var case:-        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0-The idea here is that a constructor worker, like \$wJust, is-really short for (\x -> \$wJust x), because \$wJust has no binding.-So it should be treated like a lambda.  Ditto unsaturated primops.-But now constructor workers are not "have-no-binding" Ids.  And-completely un-applied primops and foreign-call Ids are sufficiently-rare that I plan to allow them to be duplicated and put up with-saturating them.--Note [Tick trivial]-~~~~~~~~~~~~~~~~~~~-Ticks are only trivial if they are pure annotations. If we treat-"tick<n> x" as trivial, it will be inlined inside lambdas and the-entry count will be skewed, for example.  Furthermore "scc<n> x" will-turn into just "x" in mkTick.--Note [Empty case is trivial]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The expression (case (x::Int) Bool of {}) is just a type-changing-case used when we are sure that 'x' will not return.  See-Note [Empty case alternatives] in GHC.Core.--If the scrutinee is trivial, then so is the whole expression; and the-CoreToSTG pass in fact drops the case expression leaving only the-scrutinee.--Having more trivial expressions is good.  Moreover, if we don't treat-it as trivial we may land up with let-bindings like-   let v = case x of {} in ...-and after CoreToSTG that gives-   let v = x in ...-and that confuses the code generator (#11155). So best to kill-it off at source.--}--{-# INLINE trivial_expr_fold #-}-trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r--- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]--- This is meant to have the code of both functions in one place and make it--- easy to derive custom predicates.------ (trivial_expr_fold k_id k_triv k_not_triv e)--- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)--- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)--- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)--- * returns k_not_triv otherwise------ where "trivial wrapping" is--- * Type application or abstraction--- * Ticks other than `tickishIsCode`--- * `case e of {}` an empty case-trivial_expr_fold k_id k_lit k_triv k_not_triv = go-  where-    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 (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-    go (Case e _ _ [])                    = go e              -- See Note [Empty case is trivial]-    go _                                  = k_not_triv--exprIsTrivial :: CoreExpr -> Bool-exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e--{--Note [getIdFromTrivialExpr]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-When substituting in a breakpoint we need to strip away the type cruft-from a trivial expression and get back to the Id.  The invariant is-that the expression we're substituting was originally trivial-according to exprIsTrivial, AND the expression is not a literal.-See Note [substTickish] for how breakpoint substitution preserves-this extra invariant.--We also need this functionality in CorePrep to extract out Id of a-function which we are saturating.  However, in this case we don't know-if the variable actually refers to a literal; thus we use-'getIdFromTrivialExpr_maybe' to handle this case.  See test-T12076lit for an example where this matters.--}--getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id--- See Note [getIdFromTrivialExpr]-getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e-  where-    panic = pprPanic "getIdFromTrivialExpr" (ppr e)--getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id-getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e--{- *********************************************************************-*                                                                      *-             exprIsDupable-*                                                                      *-************************************************************************--Note [exprIsDupable]-~~~~~~~~~~~~~~~~~~~~-@exprIsDupable@ is true of expressions that can be duplicated at a modest-                cost in code size.  This will only happen in different case-                branches, so there's no issue about duplicating work.--                That is, exprIsDupable returns True of (f x) even if-                f is very very expensive to call.--                Its only purpose is to avoid fruitless let-binding-                and then inlining of case join points--}--exprIsDupable :: Platform -> CoreExpr -> Bool-exprIsDupable platform e-  = isJust (go dupAppSize e)-  where-    go :: Int -> CoreExpr -> Maybe Int-    go n (Type {})     = Just n-    go n (Coercion {}) = Just n-    go n (Var {})      = decrement n-    go n (Tick _ e)    = go n e-    go n (Cast e _)    = go n e-    go n (App f a) | Just n' <- go n a = go n' f-    go n (Lit lit) | litIsDupable platform lit = decrement n-    go _ _ = Nothing--    decrement :: Int -> Maybe Int-    decrement 0 = Nothing-    decrement n = Just (n-1)--dupAppSize :: Int-dupAppSize = 8   -- Size of term we are prepared to duplicate-                 -- This is *just* big enough to make test MethSharing-                 -- inline enough join points.  Really it should be-                 -- smaller, and could be if we fixed #4960.--{--************************************************************************-*                                                                      *-             exprIsCheap, exprIsExpandable-*                                                                      *-************************************************************************--Note [exprIsWorkFree]-~~~~~~~~~~~~~~~~~~~~~-exprIsWorkFree is used when deciding whether to inline something; we-don't inline it if doing so might duplicate work, by peeling off a-complete copy of the expression.  Here we do not want even to-duplicate a primop (#5623):-   eg   let x = a #+ b in x +# x-   we do not want to inline/duplicate x--Previously we were a bit more liberal, which led to the primop-duplicating-problem.  However, being more conservative did lead to a big regression in-one nofib benchmark, wheel-sieve1.  The situation looks like this:--   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool-       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->-         case GHC.Prim.<=# x_aRs 2 of _ {-           GHC.Types.False -> notDivBy ps_adM qs_adN;-           GHC.Types.True -> lvl_r2Eb }}-       go = \x. ...(noFactor (I# y))....(go x')...--The function 'noFactor' is heap-allocated and then called.  Turns out-that 'notDivBy' is strict in its THIRD arg, but that is invisible to-the caller of noFactor, which therefore cannot do w/w and-heap-allocates noFactor's argument.  At the moment (May 12) we are just-going to put up with this, because the previous more aggressive inlining-(which treated 'noFactor' as work-free) was duplicating primops, which-in turn was making inner loops of array calculations runs slow (#5623)--Note [Case expressions are work-free]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Are case-expressions work-free?  Consider-    let v = case x of (p,q) -> p-        go = \y -> ...case v of ...-Should we inline 'v' at its use site inside the loop?  At the moment-we do.  I experimented with saying that case are *not* work-free, but-that increased allocation slightly.  It's a fairly small effect, and at-the moment we go for the slightly more aggressive version which treats-(case x of ....) as work-free if the alternatives are.--Moreover it improves arities of overloaded functions where-there is only dictionary selection (no construction) involved--Note [exprIsCheap]-~~~~~~~~~~~~~~~~~~-See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold--@exprIsCheap@ looks at a Core expression and returns \tr{True} if-it is obviously in weak head normal form, or is cheap to get to WHNF.-Note that that's not the same as exprIsDupable; an expression might be-big, and hence not dupable, but still cheap.--By ``cheap'' we mean a computation we're willing to:-        push inside a lambda, or-        inline at more than one place-That might mean it gets evaluated more than once, instead of being-shared.  The main examples of things which aren't WHNF but are-``cheap'' are:--  *     case e of-          pi -> ei-        (where e, and all the ei are cheap)--  *     let x = e in b-        (where e and b are cheap)--  *     op x1 ... xn-        (where op is a cheap primitive operator)--  *     error "foo"-        (because we are happy to substitute it inside a lambda)--Notice that a variable is considered 'cheap': we can push it inside a lambda,-because sharing will make sure it is only evaluated once.--Note [exprIsCheap and exprIsHNF]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note that exprIsHNF does not imply exprIsCheap.  Eg-        let x = fac 20 in Just x-This responds True to exprIsHNF (you can discard a seq), but-False to exprIsCheap.--Note [Arguments and let-bindings exprIsCheapX]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What predicate should we apply to the argument of an application, or the-RHS of a let-binding?--We used to say "exprIsTrivial arg" due to concerns about duplicating-nested constructor applications, but see #4978.  So now we just recursively-use exprIsCheapX.--We definitely want to treat let and app the same.  The principle here is-that-   let x = blah in f x-should behave equivalently to-   f blah--This in turn means that the 'letrec g' does not prevent eta expansion-in this (which it previously was):-    f = \x. let v = case x of-                      True -> letrec g = \w. blah-                              in g-                      False -> \x. x-            in \w. v True--}-----------------------exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]-exprIsWorkFree e = exprIsCheapX isWorkFreeApp e--exprIsCheap :: CoreExpr -> Bool-exprIsCheap e = exprIsCheapX isCheapApp e--exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool-{-# INLINE exprIsCheapX #-}--- allow specialization of exprIsCheap and exprIsWorkFree--- instead of having an unknown call to ok_app-exprIsCheapX ok_app e-  = ok e-  where-    ok e = go 0 e--    -- n is the number of value arguments-    go n (Var v)                      = ok_app v n-    go _ (Lit {})                     = True-    go _ (Type {})                    = True-    go _ (Coercion {})                = True-    go n (Cast e _)                   = go n e-    go n (Case scrut _ _ alts)        = ok scrut &&-                                        and [ go n rhs | Alt _ _ rhs <- alts ]-    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 n (Let (NonRec _ r) e)         = go n e && ok r-    go n (Let (Rec prs) e)            = 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...--  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.)--}----------------------------------------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--isWorkFreeApp :: CheapAppFun-isWorkFreeApp fn n_val_args-  | n_val_args == 0           -- No value args-  = True-  | n_val_args < idArity fn   -- Partial application-  = True-  | otherwise-  = case idDetails fn of-      DataConWorkId {} -> True-      _                -> False--isCheapApp :: CheapAppFun-isCheapApp fn n_val_args-  | isWorkFreeApp fn n_val_args = True-  | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]-  | otherwise-  = case idDetails fn of-      DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp-      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]-      ClassOpId {}     -> n_val_args == 1-      PrimOpId op _    -> primOpIsCheap op-      _                -> False-        -- In principle we should worry about primops-        -- that return a type variable, since the result-        -- might be applied to something, but I'm not going-        -- to bother to check the number of args--isExpandableApp :: CheapAppFun-isExpandableApp fn n_val_args-  | isWorkFreeApp fn n_val_args = True-  | otherwise-  = case idDetails fn of-      RecSelId {}  -> n_val_args == 1  -- See Note [Record selection]-      ClassOpId {} -> n_val_args == 1-      PrimOpId {}  -> False-      _ | isDeadEndId fn     -> False-          -- See Note [isExpandableApp: bottoming functions]-        | isConLikeId fn     -> True-        | all_args_are_preds -> True-        | otherwise          -> False--  where-     -- See if all the arguments are PredTys (implicit params or classes)-     -- If so we'll regard it as expandable; see Note [Expandable overloadings]-     all_args_are_preds = all_pred_args n_val_args (idType fn)--     all_pred_args n_val_args ty-       | n_val_args == 0-       = True--       | Just (bndr, ty) <- splitPiTy_maybe ty-       = case bndr of-           Named {}  -> all_pred_args n_val_args ty-           Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty--       | otherwise-       = False--{- Note [isCheapApp: bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-I'm not sure why we have a special case for bottoming-functions in isCheapApp.  Maybe we don't need it.--Note [isExpandableApp: bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important that isExpandableApp does not respond True to bottoming-functions.  Recall  undefined :: HasCallStack => a-Suppose isExpandableApp responded True to (undefined d), and we had:--  x = undefined <dict-expr>--Then Simplify.prepareRhs would ANF the RHS:--  d = <dict-expr>-  x = undefined d--This is already bad: we gain nothing from having x bound to (undefined-var), unlike the case for data constructors.  Worse, we get the-simplifier loop described in OccurAnal Note [Cascading inlines].-Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will-certainly_inline; so we end up inlining d right back into x; but in-the end x doesn't inline because it is bottom (preInlineUnconditionally);-so the process repeats.. We could elaborate the certainly_inline logic-some more, but it's better just to treat bottoming bindings as-non-expandable, because ANFing them is a bad idea in the first place.--Note [Record selection]-~~~~~~~~~~~~~~~~~~~~~~~~~~-I'm experimenting with making record selection-look cheap, so we will substitute it inside a-lambda.  Particularly for dictionary field selection.--BUT: Take care with (sel d x)!  The (sel d) might be cheap, but-there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)--Note [Expandable overloadings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose the user wrote this-   {-# RULE  forall x. foo (negate x) = h x #-}-   f x = ....(foo (negate x))....-They'd expect the rule to fire. But since negate is overloaded, we might-get this:-    f = \d -> let n = negate d in \x -> ...foo (n x)...-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.---************************************************************************-*                                                                      *-             exprOkForSpeculation-*                                                                      *-************************************************************************--}---------------------------------- | 'exprOkForSpeculation' returns True of an expression that is:------  * Safe to evaluate even if normal order eval might not---    evaluate the expression at all, or------  * Safe /not/ to evaluate even if normal order would do so------ It is usually called on arguments of unlifted type, but not always--- In particular, Simplify.rebuildCase calls it on lifted types--- when a 'case' is a plain 'seq'. See the example in--- Note [exprOkForSpeculation: case expressions] below------ Precisely, it returns @True@ iff:---  a) The expression guarantees to terminate,---  b) soon,---  c) without causing a write side effect (e.g. writing a mutable variable)---  d) without throwing a Haskell exception---  e) without risking an unchecked runtime exception (array out of bounds,---     divide by zero)------ For @exprOkForSideEffects@ the list is the same, but omitting (e).------ Note that---    exprIsHNF            implies exprOkForSpeculation---    exprOkForSpeculation implies exprOkForSideEffects------ See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps"--- and Note [Transformations affected by can_fail and has_side_effects]------ As an example of the considerations in this test, consider:------ > let x = case y# +# 1# of { r# -> I# r# }--- > in E------ being translated to:------ > case y# +# 1# of { r# ->--- >    let x = I# r#--- >    in E--- > }------ We can only do this if the @y + 1@ is ok for speculation: it has no--- side effects, and can't diverge or raise an exception.--exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool-exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation-exprOkForSideEffects = expr_ok fun_always_ok primOpOkForSideEffects--fun_always_ok :: Id -> Bool-fun_always_ok _ = True---- | A special version of 'exprOkForSpeculation' used during--- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False--- for `b`, then `b` is never considered ok-for-spec.-exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool-exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation--expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool-expr_ok _ _ (Lit _)      = True-expr_ok _ _ (Type _)     = True-expr_ok _ _ (Coercion _) = True--expr_ok fun_ok primop_ok (Var v)    = app_ok fun_ok primop_ok v []-expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e-expr_ok fun_ok primop_ok (Lam b e)-                 | isTyVar b = expr_ok fun_ok primop_ok  e-                 | otherwise = True---- Tick annotations that *tick* cannot be speculated, because these--- are meant to identify whether or not (and how often) the particular--- source expression was evaluated at runtime.-expr_ok fun_ok primop_ok (Tick tickish e)-   | tickishCounts tickish = False-   | otherwise             = expr_ok fun_ok primop_ok e--expr_ok _ _ (Let {}) = False-  -- Lets can be stacked deeply, so just give up.-  -- In any case, the argument of exprOkForSpeculation is-  -- usually in a strict context, so any lets will have been-  -- floated away.--expr_ok fun_ok primop_ok (Case scrut bndr _ alts)-  =  -- See Note [exprOkForSpeculation: case expressions]-     expr_ok fun_ok primop_ok scrut-  && isUnliftedType (idType bndr)-      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep-  && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts-  && altsAreExhaustive alts--expr_ok fun_ok primop_ok other_expr-  | (expr, args) <- collectArgs other_expr-  = case stripTicksTopE (not . tickishCounts) expr of-        Var f ->-           app_ok fun_ok primop_ok f args--        -- 'LitRubbish' is the only literal that can occur in the head of an-        -- application and will not be matched by the above case (Var /= Lit).-        -- See Note [How a rubbish literal can be the head of an application]-        -- in GHC.Types.Literal-        Lit lit | debugIsOn, not (isLitRubbish lit)-                 -> pprPanic "Non-rubbish lit in app head" (ppr lit)-                 | otherwise-                 -> True--        _ -> False--------------------------------app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool-app_ok fun_ok primop_ok fun args-  | not (fun_ok fun)-  = False -- This code path is only taken for Note [Speculative evaluation]-  | otherwise-  = case idDetails fun of-      DFunId new_type ->  not new_type-         -- DFuns terminate, unless the dict is implemented-         -- with a newtype in which case they may not--      DataConWorkId {} -> True-                -- The strictness of the constructor has already-                -- been expressed by its "wrapper", so we don't need-                -- to take the arguments into account--      PrimOpId op _-        | primOpIsDiv op-        , [arg1, Lit lit] <- args-        -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1-              -- Special case for dividing operations that fail-              -- In general they are NOT ok-for-speculation-              -- (which primop_ok will catch), but they ARE OK-              -- if the divisor is definitely non-zero.-              -- Often there is a literal divisor, and this-              -- can get rid of a thunk in an inner loop--        | SeqOp <- op  -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp]-        -> False       --     for the special cases for SeqOp and DataToTagOp-        | DataToTagOp <- op-        -> False-        | KeepAliveOp <- op-        -> False--        | otherwise-        -> primop_ok op  -- Check the primop itself-        && and (zipWith arg_ok arg_tys args)  -- Check the arguments--      _  -- Unlifted types-         -- c.f. the Var case of exprIsHNF-         | Just Unlifted <- typeLevity_maybe (idType fun)-         -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)-            True  -- Our only unlifted types are Int# etc, so will have-                  -- no value args.  The assert is just to check this.-                  -- If we added unlifted function types this would change,-                  -- and we'd need to actually test n_val_args == 0.--         -- Partial applications-         | idArity fun > n_val_args ->-           and (zipWith arg_ok arg_tys args)  -- Check the arguments--         -- Functions that terminate fast without raising exceptions etc-         -- See Note [Discarding unnecessary unsafeEqualityProofs]-         | fun `hasKey` unsafeEqualityProofIdKey -> True--         | otherwise -> False-             -- NB: even in the nullary case, do /not/ check-             --     for evaluated-ness of the fun;-             --     see Note [exprOkForSpeculation and evaluated variables]-  where-    n_val_args   = valArgCount args-    (arg_tys, _) = splitPiTys (idType fun)--    -- Used for arguments to primops and to partial applications-    arg_ok :: PiTyVarBinder -> CoreExpr -> Bool-    arg_ok (Named _) _ = True   -- A type argument-    arg_ok (Anon ty _) arg      -- A term argument-       | Just Lifted <- typeLevity_maybe (scaledThing ty)-       = True -- See Note [Primops with lifted arguments]-       | otherwise-       = expr_ok fun_ok primop_ok arg--------------------------------altsAreExhaustive :: [Alt b] -> Bool--- True  <=> the case alternatives are definitely exhaustive--- False <=> they may or may not be-altsAreExhaustive []-  = False    -- Should not happen-altsAreExhaustive (Alt con1 _ _ : alts)-  = case con1 of-      DEFAULT   -> True-      LitAlt {} -> False-      DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1)-      -- It is possible to have an exhaustive case that does not-      -- enumerate all constructors, notably in a GADT match, but-      -- we behave conservatively here -- I don't think it's important-      -- enough to deserve special treatment---- | Should we look past this tick when eta-expanding the given function?------ See Note [Ticks and mandatory eta expansion]--- Takes the function we are applying as argument.-etaExpansionTick :: Id -> GenTickish pass -> Bool-etaExpansionTick id t-  = hasNoBinding id &&-    ( tickishFloatable t || isProfTick t )--{- Note [exprOkForSpeculation: case expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-exprOkForSpeculation accepts very special case expressions.-Reason: (a ==# b) is ok-for-speculation, but the litEq rules-in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to-   case a of { DEFAULT -> 0#; 3# -> 1# }-for excellent reasons described in-  GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case].-So, annoyingly, we want that case expression to be-ok-for-speculation too. Bother.--But we restrict it sharply:--* We restrict it to unlifted scrutinees. Consider this:-     case x of y {-       DEFAULT -> ... (let v::Int# = case y of { True  -> e1-                                               ; False -> e2 }-                       in ...) ...--  Does the RHS of v satisfy the let-can-float invariant?  Previously we said-  yes, on the grounds that y is evaluated.  But the binder-swap done-  by GHC.Core.Opt.SetLevels would transform the inner alternative to-     DEFAULT -> ... (let v::Int# = case x of { ... }-                     in ...) ....-  which does /not/ satisfy the let-can-float invariant, because x is-  not evaluated. See Note [Binder-swap during float-out]-  in GHC.Core.Opt.SetLevels.  To avoid this awkwardness it seems simpler-  to stick to unlifted scrutinees where the issue does not-  arise.--* We restrict it to exhaustive alternatives. A non-exhaustive-  case manifestly isn't ok-for-speculation. for example,-  this is a valid program (albeit a slightly dodgy one)-    let v = case x of { B -> ...; C -> ... }-    in case x of-         A -> ...-         _ ->  ...v...v....-  Should v be considered ok-for-speculation?  Its scrutinee may be-  evaluated, but the alternatives are incomplete so we should not-  evaluate it strictly.--  Now, all this is for lifted types, but it'd be the same for any-  finite unlifted type. We don't have many of them, but we might-  add unlifted algebraic types in due course.-------- Historical note: #15696: ---------  Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide-  floating of single-alternative cases; it now uses exprIsHNF-  Note [Floating single-alternative cases].--  But in those days, consider-    case e of x { DEAFULT ->-      ...(case x of y-            A -> ...-            _ -> ...(case (case x of { B -> p; C -> p }) of-                       I# r -> blah)...-  If GHC.Core.Opt.SetLevels considers the inner nested case as-  ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels).-  So we'd float to:-    case e of x { DEAFULT ->-    case (case x of { B -> p; C -> p }) of I# r ->-    ...(case x of y-            A -> ...-            _ -> ...blah...)...-  which is utterly bogus (seg fault); see #5453.------- Historical note: #3717: ---------    foo :: Int -> Int-    foo 0 = 0-    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)--In earlier GHCs, we got this:-    T.$wfoo =-      \ (ww :: GHC.Prim.Int#) ->-        case ww of ds {-          __DEFAULT -> case (case <# ds 5 of _ {-                          GHC.Types.False -> lvl1;-                          GHC.Types.True -> lvl})-                       of _ { __DEFAULT ->-                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };-          0 -> 0 }--Before join-points etc we could only get rid of two cases (which are-redundant) by recognising that the (case <# ds 5 of { ... }) is-ok-for-speculation, even though it has /lifted/ type.  But now join-points do the job nicely.-------- End of historical note ---------------Note [Primops with lifted arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Is this ok-for-speculation (see #13027)?-   reallyUnsafePtrEquality# a b-Well, yes.  The primop accepts lifted arguments and does not-evaluate them.  Indeed, in general primops are, well, primitive-and do not perform evaluation.--Bottom line:-  * In exprOkForSpeculation we simply ignore all lifted arguments.-  * In the rare case of primops that /do/ evaluate their arguments,-    (namely DataToTagOp and SeqOp) return False; see-    Note [exprOkForSpeculation and evaluated variables]--Note [exprOkForSpeculation and SeqOp/DataToTagOp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Most primops with lifted arguments don't evaluate them-(see Note [Primops with lifted arguments]), so we can ignore-that argument entirely when doing exprOkForSpeculation.--But DataToTagOp and SeqOp are exceptions to that rule.-For reasons described in Note [exprOkForSpeculation and-evaluated variables], we simply return False for them.--Not doing this made #5129 go bad.-Lots of discussion in #15696.--Note [exprOkForSpeculation and evaluated variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Recall that-  seq#       :: forall a s. a -> State# s -> (# State# s, a #)-  dataToTag# :: forall a.   a -> Int#-must always evaluate their first argument.--Now consider these examples:- * case x of y { DEFAULT -> ....y.... }-   Should 'y' (alone) be considered ok-for-speculation?-- * case x of y { DEFAULT -> ....let z = dataToTag# y... }-   Should (dataToTag# y) be considered ok-for-spec?--You could argue 'yes', because in the case alternative we know that-'y' is evaluated.  But the binder-swap transformation, which is-extremely useful for float-out, changes these expressions to-   case x of y { DEFAULT -> ....x.... }-   case x of y { DEFAULT -> ....let z = dataToTag# x... }--And now the expression does not obey the let-can-float invariant!  Yikes!-Moreover we really might float (dataToTag# x) outside the case,-and then it really, really doesn't obey the let-can-float invariant.--The solution is simple: exprOkForSpeculation does not try to take-advantage of the evaluated-ness of (lifted) variables.  And it returns-False (always) for DataToTagOp and SeqOp.--Note that exprIsHNF /can/ and does take advantage of evaluated-ness;-it doesn't have the trickiness of the let-can-float invariant to worry about.--Note [Discarding unnecessary unsafeEqualityProofs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #20143 we found-   case unsafeEqualityProof @t1 @t2 of UnsafeRefl cv[dead] -> blah-where 'blah' didn't mention 'cv'.  We'd like to discard this-redundant use of unsafeEqualityProof, via GHC.Core.Opt.Simplify.rebuildCase.-To do this we need to know-  (a) that cv is unused (done by OccAnal), and-  (b) that unsafeEqualityProof terminates rapidly without side effects.--At the moment we check that explicitly here in exprOkForSideEffects,-but one might imagine a more systematic check in future.---************************************************************************-*                                                                      *-             exprIsHNF, exprIsConLike-*                                                                      *-************************************************************************--}---- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]--- ~~~~~~~~~~~~~~~~--- | exprIsHNF returns true for expressions that are certainly /already/--- evaluated to /head/ normal form.  This is used to decide whether it's ok--- to change:------ > case x of _ -> e------    into:------ > e------ and to decide whether it's safe to discard a 'seq'.------ 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:------ > (:) (f x) (map f xs)--- > map (...redex...)------ because 'seq' on such things completes immediately.------ For unlifted argument types, we have to be careful:------ > C (f x :: Int#)------ Suppose @f x@ diverges; then @C (f x)@ is not a value.--- We check for this using needsCaseBinding below-exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP-exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding---- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as--- data constructors. Conlike arguments are considered interesting by the--- inliner.-exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP-exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding---- | Returns true for values or value-like expressions. These are lambdas,--- constructors / CONLIKE functions (as determined by the function argument)--- or PAPs.----exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool-exprIsHNFlike is_con is_con_unf = is_hnf_like-  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-      || is_con_unf (idUnfolding v)-        -- Check the thing's unfolding; it might be bound to a value-        --   or to a guaranteed-evaluated variable (isEvaldUnfolding)-        --   Contrast with Note [exprOkForSpeculation and evaluated variables]-        -- We don't look through loop breakers here, which is a bit conservative-        -- but otherwise I worry that if an Id's unfolding is just itself,-        -- we could get an infinite loop-      || ( typeLevity_maybe (idType v) == Just Unlifted )-        -- Unlifted binders are always evaluated (#20140)--    is_hnf_like (Lit l)          = not (isLitRubbish l)-        -- Regarding a LitRubbish as ConLike leads to unproductive inlining in-        -- WWRec, see #20035-    is_hnf_like (Type _)         = True       -- Types are honorary Values;-                                              -- we don't mind copying them-    is_hnf_like (Coercion _)     = True       -- Same for coercions-    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e-    is_hnf_like (Tick tickish e) = not (tickishCounts tickish)-                                   && is_hnf_like e-                                      -- 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-      | 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 _                = 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--    id_app_is_value id n_val_args-       = is_con id-       || idArity id > n_val_args--{--Note [exprIsHNF Tick]-~~~~~~~~~~~~~~~~~~~~~-We can discard source annotations on HNFs as long as they aren't-tick-like:--  scc c (\x . e)    =>  \x . e-  scc c (C x1..xn)  =>  C x1..xn--So we regard these as HNFs.  Tick annotations that tick are not-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.--}---- | Can we bind this 'CoreExpr' at the top level?-exprIsTopLevelBindable :: CoreExpr -> Type -> Bool--- See Note [Core top-level string literals]--- Precondition: exprType expr = ty--- Top-level literal strings can't even be wrapped in ticks---   see Note [Core top-level string literals] in "GHC.Core"-exprIsTopLevelBindable expr ty-  = not (mightBeUnliftedType ty)-    -- Note that 'expr' may not have a fixed runtime representation here,-    -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType',-    -- as the latter would panic.-  || exprIsTickedString expr---- | Check if the expression is zero or more Ticks wrapped around a literal--- string.-exprIsTickedString :: CoreExpr -> Bool-exprIsTickedString = isJust . exprIsTickedString_maybe---- | Extract a literal string from an expression that is zero or more Ticks--- wrapped around a literal string. Returns Nothing if the expression has a--- different shape.--- Used to "look through" Ticks in places that need to handle literal strings.-exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString-exprIsTickedString_maybe (Lit (LitString bs)) = Just bs-exprIsTickedString_maybe (Tick t e)-  -- we don't tick literals with CostCentre ticks, compare to mkTick-  | tickishPlace t == PlaceCostCentre = Nothing-  | otherwise = exprIsTickedString_maybe e-exprIsTickedString_maybe _ = Nothing--{--************************************************************************-*                                                                      *-             Instantiating data constructors-*                                                                      *-************************************************************************--These InstPat functions go here to avoid circularity between DataCon and Id--}--dataConRepInstPat   ::                 [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])-dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])--dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))-dataConRepFSInstPat = dataConInstPat--dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names-               -> [Unique]              -- An equally long list of uniques, at least one for each binder-               -> Mult                  -- The multiplicity annotation of the case expression: scales the multiplicity of variables-               -> DataCon-               -> [Type]                -- Types to instantiate the universally quantified tyvars-               -> ([TyCoVar], [Id])     -- Return instantiated variables--- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple--- (ex_tvs, arg_ids),------   ex_tvs are intended to be used as binders for existential type args------   arg_ids are intended to be used as binders for value arguments,---     and their types have been instantiated with inst_tys and ex_tys---     The arg_ids include both evidence and---     programmer-specified arguments (both after rep-ing)------ Example.---  The following constructor T1------  data T a where---    T1 :: forall b. Int -> b -> T(a,b)---    ...------  has representation type---   forall a. forall a1. forall b. (a ~ (a1,b)) =>---     Int -> b -> T a------  dataConInstPat fss us T1 (a1',b') will return------  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])------  where the double-primed variables are created with the FastStrings and---  Uniques given as fss and us-dataConInstPat fss uniqs mult con inst_tys-  = assert (univ_tvs `equalLength` inst_tys) $-    (ex_bndrs, arg_ids)-  where-    univ_tvs = dataConUnivTyVars con-    ex_tvs   = dataConExTyCoVars con-    arg_tys  = dataConRepArgTys con-    arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys-    n_ex = length ex_tvs--      -- split the Uniques and FastStrings-    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs-    (ex_fss,   id_fss)   = splitAt n_ex fss--      -- Make the instantiating substitution for universals-    univ_subst = zipTvSubst univ_tvs inst_tys--      -- Make existential type variables, applying and extending the substitution-    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst-                                       (zip3 ex_tvs ex_fss ex_uniqs)--    mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar)-    mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv-                                       new_tv-                                     , new_tv)-      where-        new_tv | isTyVar tv-               = mkTyVar (mkSysTvName uniq fs) kind-               | otherwise-               = mkCoVar (mkSystemVarName uniq fs) kind-        kind   = Type.substTyUnchecked subst (varType tv)--      -- Make value vars, instantiating types-    arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs-    mk_id_var uniq fs (Scaled m ty) str-      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]-        mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty)-      where-        name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan--{--Note [Mark evaluated arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When pattern matching on a constructor with strict fields, the binder-can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that-when loading an interface file unfolding like:-  data T = MkT !Int-  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1-                             in ... }-we don't want Lint to complain.  The 'y' is evaluated, so the-case in the RHS of the binding for 'v' is fine.  But only if we-*know* that 'y' is evaluated.--c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt--************************************************************************-*                                                                      *-         Equality-*                                                                      *-************************************************************************--}---- | A cheap equality test which bales out fast!---      If it returns @True@ the arguments are definitely equal,---      otherwise, they may or may not be equal.-cheapEqExpr :: Expr b -> Expr b -> Bool-cheapEqExpr = cheapEqExpr' (const False)---- | Cheap expression equality test, can ignore ticks by type.-cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool-{-# INLINE cheapEqExpr' #-}-cheapEqExpr' ignoreTick e1 e2-  = go e1 e2-  where-    go (Var v1)   (Var v2)         = v1 == v2-    go (Lit lit1) (Lit lit2)       = lit1 == lit2-    go (Type t1)  (Type t2)        = t1 `eqType` t2-    go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2-    go (App f1 a1) (App f2 a2)     = f1 `go` f2 && a1 `go` a2-    go (Cast e1 t1) (Cast e2 t2)   = e1 `go` e2 && t1 `eqCoercion` t2--    go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2-    go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2-    go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2--    go _ _ = False------ Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots-eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool-eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)-      = lid == rid &&-        map (rnOccL env) lids == map (rnOccR env) rids &&-        lext == rext-eqTickish _ l r = l == r---- | Finds differences between core bindings, see @diffExpr@.------ The main problem here is that while we expect the binds to have the--- same order in both lists, this is not guaranteed. To do this--- properly we'd either have to do some sort of unification or check--- all possible mappings, which would be seriously expensive. So--- instead we simply match single bindings as far as we can. This--- leaves us just with mutually recursive and/or mismatching bindings,--- which we then speculatively match by ordering them. It's by no means--- perfect, but gets the job done well enough.------ Only used in GHC.Core.Lint.lintAnnots-diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]-          -> ([SDoc], RnEnv2)-diffBinds top env binds1 = go (length binds1) env binds1- where go _    env []     []-          = ([], env)-       go _fuel env [] binds2-          -- No binds remaining to compare on the left? Bail out early.-          = (warn env [] binds2, env)-       go _fuel env binds1 []-          -- No binds remaining to compare on the right? Bail out early.-          = (warn env binds1 [], env)-       go fuel env binds1@(bind1:_) binds2@(_:_)-          -- Iterated over all binds without finding a match? Then-          -- try speculatively matching binders by order.-          | fuel == 0-          = if not $ env `inRnEnvL` fst bind1-            then let env' = uncurry (rnBndrs2 env) $ unzip $-                            zip (sort $ map fst binds1) (sort $ map fst binds2)-                 in go (length binds1) env' binds1 binds2-            -- If we have already tried that, give up-            else (warn env binds1 binds2, env)-       go fuel env ((bndr1,expr1):binds1) binds2-          | let matchExpr (bndr,expr) =-                  (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) &&-                  null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)--          , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2-          = go (length binds1) (rnBndr2 env bndr1 bndr2)-                binds1 (binds2l ++ binds2r)-          | otherwise -- No match, so push back (FIXME O(n^2))-          = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2--       -- We have tried everything, but couldn't find a good match. So-       -- now we just return the comparison results when we pair up-       -- the binds in a pseudo-random order.-       warn env binds1 binds2 =-         concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++-         unmatched "unmatched left-hand:" (drop l binds1') ++-         unmatched "unmatched right-hand:" (drop l binds2')-        where binds1' = sortBy (comparing fst) binds1-              binds2' = sortBy (comparing fst) binds2-              l = min (length binds1') (length binds2')-       unmatched _   [] = []-       unmatched txt bs = [text txt $$ ppr (Rec bs)]-       diffBind env (bndr1,expr1) (bndr2,expr2)-         | ds@(_:_) <- diffExpr top env expr1 expr2-         = locBind "in binding" bndr1 bndr2 ds-         -- Special case for TyVar, which we checked were bound to the same types in-         -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo.-         -- These let-bound types are created temporarily by the simplifier but inlined-         -- immediately.-         | isTyVar bndr1 && isTyVar bndr2-         = []-         | otherwise-         = diffIdInfo env bndr1 bndr2---- | Finds differences between core expressions, modulo alpha and--- renaming. Setting @top@ means that the @IdInfo@ of bindings will be--- checked for differences as well.-diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]-diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []-diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []-diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []-diffExpr _   env (Coercion co1) (Coercion co2)-                                       | eqCoercionX env co1 co2        = []-diffExpr top env (Cast e1 co1)  (Cast e2 co2)-  | eqCoercionX env co1 co2                = diffExpr top env e1 e2-diffExpr top env (Tick n1 e1)   e2-  | not (tickishIsCode n1)                 = diffExpr top env e1 e2-diffExpr top env e1             (Tick n2 e2)-  | not (tickishIsCode n2)                 = diffExpr top env e1 e2-diffExpr top env (Tick n1 e1)   (Tick n2 e2)-  | eqTickish env n1 n2                    = diffExpr top env e1 e2- -- The error message of failed pattern matches will contain- -- generated names, which are allowed to differ.-diffExpr _   _   (App (App (Var absent) _) _)-                 (App (App (Var absent2) _) _)-  | isDeadEndId absent && isDeadEndId absent2 = []-diffExpr top env (App f1 a1)    (App f2 a2)-  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2-diffExpr top env (Lam b1 e1)  (Lam b2 e2)-  | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination-  = diffExpr top (rnBndr2 env b1 b2) e1 e2-diffExpr top env (Let bs1 e1) (Let bs2 e2)-  = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])-    in ds ++ diffExpr top env' e1 e2-diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)-  | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2-    -- See Note [Empty case alternatives] in GHC.Data.TrieMap-  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)-  where env' = rnBndr2 env b1 b2-        diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2)-          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]-          | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2-diffExpr _  _ e1 e2-  = [fsep [ppr e1, text "/=", ppr e2]]---- | Find differences in @IdInfo@. We will especially check whether--- the unfoldings match, if present (see @diffUnfold@).-diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]-diffIdInfo env bndr1 bndr2-  | arityInfo info1 == arityInfo info2-    && cafInfo info1 == cafInfo info2-    && oneShotInfo info1 == oneShotInfo info2-    && inlinePragInfo info1 == inlinePragInfo info2-    && occInfo info1 == occInfo info2-    && demandInfo info1 == demandInfo info2-    && callArityInfo info1 == callArityInfo info2-  = locBind "in unfolding of" bndr1 bndr2 $-    diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2)-  | otherwise-  = locBind "in Id info of" bndr1 bndr2-    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]-  where info1 = idInfo bndr1; info2 = idInfo bndr2---- | Find differences in unfoldings. Note that we will not check for--- differences of @IdInfo@ in unfoldings, as this is generally--- redundant, and can lead to an exponential blow-up in complexity.-diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]-diffUnfold _   NoUnfolding    NoUnfolding                 = []-diffUnfold _   BootUnfolding  BootUnfolding               = []-diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []-diffUnfold env (DFunUnfolding bs1 c1 a1)-               (DFunUnfolding bs2 c2 a2)-  | c1 == c2 && equalLength bs1 bs2-  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)-  where env' = rnBndrs2 env bs1 bs2-diffUnfold env (CoreUnfolding t1 _ _ c1 g1)-               (CoreUnfolding t2 _ _ c2 g2)-  | c1 == c2 && g1 == g2-  = diffExpr False env t1 t2-diffUnfold _   uf1 uf2-  = [fsep [ppr uf1, text "/=", ppr uf2]]---- | Add location information to diff messages-locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]-locBind loc b1 b2 diffs = map addLoc diffs-  where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))-        bindLoc | b1 == b2  = ppr b1-                | otherwise = ppr b1 <> char '/' <> ppr b2---{- *********************************************************************-*                                                                      *-\subsection{Determining non-updatable right-hand-sides}-*                                                                      *-************************************************************************--Top-level constructor applications can usually be allocated-statically, but they can't if the constructor, or any of the-arguments, come from another DLL (because we can't refer to static-labels in other DLLs).--If this happens we simply make the RHS into an updatable thunk,-and 'execute' it rather than allocating it statically.--}--{--************************************************************************-*                                                                      *-\subsection{Type utilities}-*                                                                      *-************************************************************************--}---- | True if the type has no non-bottom elements, e.g. when it is an empty--- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.--- See Note [Bottoming expressions]------ See Note [No alternatives lint check] for another use of this function.-isEmptyTy :: Type -> Bool-isEmptyTy ty-    -- Data types where, given the particular type parameters, no data-    -- constructor matches, are empty.-    -- This includes data types with no constructors, e.g. Data.Void.Void.-    | Just (tc, inst_tys) <- splitTyConApp_maybe ty-    , Just dcs <- tyConDataCons_maybe tc-    , all (dataConCannotMatch inst_tys) dcs-    = True-    | otherwise-    = False---- | 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.-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-  = Just (tc, tc_args, co)-normSplitTyConApp_maybe _ _ = Nothing--{--*****************************************************-*-* InScopeSet things-*-*****************************************************--}---extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet-extendInScopeSetBind (InScope in_scope) binds-   = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds--extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet-extendInScopeSetBndrs (InScope in_scope) binds-   = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds--mkInScopeSetBndrs :: [CoreBind] -> InScopeSet-mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds--{--*****************************************************-*-* StaticPtr-*-*****************************************************--}---- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields--- @Just (makeStatic, t, srcLoc, e)@.------ Returns @Nothing@ for every other expression.-collectMakeStaticArgs-  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)-collectMakeStaticArgs e-    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e-    , idName b == makeStaticName = Just (fun, t, loc, arg)-collectMakeStaticArgs _          = Nothing--{--************************************************************************-*                                                                      *-\subsection{Join points}-*                                                                      *-************************************************************************--}---- | Does this binding bind a join point (or a recursive group of join points)?-isJoinBind :: CoreBind -> Bool-isJoinBind (NonRec b _)       = isJoinId b-isJoinBind (Rec ((b, _) : _)) = isJoinId b-isJoinBind _                  = False--dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc-dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)-  where-  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)-  getIds (NonRec i _) = [ i ]-  getIds (Rec bs)     = map fst bs-  -- By default only include full info for exported ids, unless we run in the verbose-  -- pprDebug mode.-  printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))-             | otherwise       = empty--{--************************************************************************-*                                                                      *-\subsection{Tag inference things}-*                                                                      *-************************************************************************--}--{- Note [Call-by-value for worker args]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we unbox a constructor with strict fields we want to-preserve the information that some of the arguments came-out of strict fields and therefore should be already properly-tagged, however we can't express this directly in core.--Instead what we do is generate a worker like this:--  data T = MkT A !B--  foo = case T of MkT a b -> $wfoo a b--  $wfoo a b = case b of b' -> rhs[b/b']--This makes the worker strict in b causing us to use a more efficient-calling convention for `b` where the caller needs to ensure `b` is-properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids].--Usually the argument will be known to be properly tagged at the call site so there is-no additional work for the caller and the worker can be more efficient since it can-assume the presence of a tag.--This is especially true for recursive functions like this:-    -- myPred expect it's argument properly tagged-    myPred !x = ...--    loop :: MyPair -> Int-    loop (MyPair !x !y) =-        case x of-            A -> 1-            B -> 2-            _ -> loop (MyPair (myPred x) (myPred y))--Here we would ordinarily not be strict in y after unboxing.-However if we pass it as a regular argument then this means on-every iteration of loop we will incur an extra seq on y before-we can pass it to `myPred` which isn't great! That is in STG after-tag inference we get:--    Rec {-    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]-      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#-    [GblId[StrictWorker([!, ~])],-    Arity=2,-    Str=<1L><ML>,-    Unf=OtherCon []] =-        {} \r [x y]-            case x<TagProper> of x' [Occ=Once1] {-              __DEFAULT ->-                  case y of y' [Occ=Once1] {-                  __DEFAULT ->-                  case Find.$wmyPred y' of pred_y [Occ=Once1] {-                  __DEFAULT ->-                  case Find.$wmyPred x' of pred_x [Occ=Once1] {-                  __DEFAULT -> Find.$wloop pred_x pred_y;-                  };-                  };-              Find.A -> 1#;-              Find.B -> 2#;-            };-    end Rec }--Here comes the tricky part: If we make $wloop strict in both x/y and we get:--    Rec {-    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]-      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#-    [GblId[StrictWorker([!, !])],-    Arity=2,-    Str=<1L><!L>,-    Unf=OtherCon []] =-        {} \r [x y]-            case y<TagProper> of y' [Occ=Once1] { __DEFAULT ->-            case x<TagProper> of x' [Occ=Once1] {-              __DEFAULT ->-                  case Find.$wmyPred y' of pred_y [Occ=Once1] {-                  __DEFAULT ->-                  case Find.$wmyPred x' of pred_x [Occ=Once1] {-                  __DEFAULT -> Find.$wloop pred_x pred_y;-                  };-                  };-              Find.A -> 1#;-              Find.B -> 2#;-            };-    end Rec }--Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv.-This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime.--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.-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-it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the-simplifier. See Note [Which Ids should be strictified] for details on this.--}-mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)-mkStrictFieldSeqs args rhs =-  foldr addEval rhs args-    where-      case_ty = exprType rhs-      addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)-      addEval (arg_id,arg_cbv) (rhs)-        -- Argument representing strict field.-        | isMarkedStrict arg_cbv-        , shouldStrictifyIdForCbv arg_id-        -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings.-        = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs])-        -- Normal argument-        | otherwise = do-          rhs--{- Note [Which Ids should be strictified]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For some arguments we would like to convince GHC to pass them call by value.-One way to achieve this is described in see Note [Call-by-value for worker args].--We separate the concerns of "should we pass this argument using cbv" and-"should we do so by making the rhs strict in this argument".-This note deals with the second part.--There are multiple reasons why we might not want to insert a seq in the rhs to-strictify a functions argument:--1) The argument doesn't exist at runtime.--For zero width types (like Types) there is no benefit as we don't operate on them-at runtime at all. This includes things like void#, coercions and state tokens.--2) The argument is a unlifted type.--If the argument is a unlifted type the calling convention already is explicitly-cbv. This means inserting a seq on this argument wouldn't do anything as the seq-would be a no-op *and* it wouldn't affect the calling convention.--3) The argument is absent.--If the argument is absent in the body there is no advantage to it being passed as-cbv to the function. The function won't ever look at it so we don't safe any work.--This mostly happens for join point. For example we might have:--    data T = MkT ![Int] [Char]-    f t = case t of MkT xs{strict} ys-> snd (xs,ys)--and abstract the case alternative to:--    f t = join j1 = \xs ys -> snd (xs,ys)-          in case t of MkT xs{strict} ys-> j1 xs xy--While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to.-In short a absent demand means neither our RHS, nor any function we pass the argument-to will inspect it. So there is no work to be saved by forcing `xs` early.--NB: There is an edge case where if we rebox we *can* end up seqing an absent value.-Note [Absent fillers] has an example of this. However this is so rare it's not worth-caring about here.--4) The argument is already strict.--Consider this code:--    data T = MkT ![Int]-    f t = case t of MkT xs{strict} -> reverse xs--The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`.-If we do a w/w split, and add the extra eval on `xs`, we'll get--    $wf xs =-        case xs of xs1 ->-            let t = MkT xs1 in-            case t of MkT xs2 -> reverse xs2--That's not wrong; but the w/w body will simplify to--    $wf xs = case xs of xs1 -> reverse xs1--and now we'll drop the `case xs` because `xs1` is used strictly in its scope.-Adding that eval was a waste of time.  So don't add it for strictly-demanded Ids.--5) Functions--Functions are tricky (see Note [TagInfo of functions] in InferTags).-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.---}--- | Do we expect there to be any benefit if we make this var strict--- in order for it to get treated as as cbv argument?--- See Note [Which Ids should be strictified]--- See Note [CBV Function Ids] for more background.-shouldStrictifyIdForCbv :: Var -> Bool-shouldStrictifyIdForCbv = wantCbvForId False---- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args.-shouldUseCbvForId :: Var -> Bool-shouldUseCbvForId = wantCbvForId True---- When we strictify we want to skip strict args otherwise the logic is the same--- as for shouldUseCbvForId so we common up the logic here.--- Basically returns true if it would be benefitial for runtime to pass this argument--- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args--- we are not allowed to force.-wantCbvForId :: Bool -> Var -> Bool-wantCbvForId cbv_for_strict v-  -- Must be a runtime var.-  -- See Note [Which Ids should be strictified] point 1)-  | isId v-  , not $ isZeroBitTy ty-  -- Unlifted things don't need special measures to be treated as cbv-  -- 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 [Which Ids should be strictified] point 5)-  , not $ isFunTy ty-  -- If the var is strict already a seq is redundant.-  -- See Note [Which Ids should be strictified] point 4)-  , not (isStrictDmd dmd) || cbv_for_strict-  -- If the var is absent a seq is almost always useless.-  -- See Note [Which Ids should be strictified] point 3)-  , not (isAbsDmd dmd)-  = True-  | otherwise-  = False-  where-    ty = idType v-    dmd = idDemandInfo v--{- *********************************************************************-*                                                                      *-             unsafeEqualityProof-*                                                                      *-********************************************************************* -}--isUnsafeEqualityProof :: CoreExpr -> Bool--- See (U3) and (U4) in--- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce-isUnsafeEqualityProof e-  | Var v `App` Type _ `App` Type _ `App` Type _ <- e-  = v `hasKey` unsafeEqualityProofIdKey-  | otherwise-  = False+        bindNonRec, needsCaseBinding, needsCaseBindingL,+        mkAltExpr, mkDefaultCase, mkSingleAltCase,++        -- * Taking expressions apart+        findDefault, addDefault, findAlt, isDefaultAlt,+        mergeAlts, mergeCaseAlts, trimConArgs,+        filterAlts, combineIdenticalAlts, refineDefaultAlt,+        scaleAltsBy,++        -- * Properties of expressions+        exprType, coreAltType, coreAltsType,+        mkLamType, mkLamTypes,+        mkFunctionType,+        exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,+        trivial_expr_fold,+        exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,+        exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval,+        exprIsWorkFree, exprIsConLike,+        isCheapApp, isExpandableApp, isSaturatedConApp,+        exprIsTickedString, exprIsTickedString_maybe,+        exprIsTopLevelBindable,+        exprIsUnaryClassFun, isUnaryClassId,+        altsAreExhaustive, etaExpansionTick,++        -- * Equality+        cheapEqExpr, cheapEqExpr', diffBinds,++        -- * Manipulating data constructors and types+        exprToType,+        applyTypeToArgs,+        dataConRepInstPat, dataConRepFSInstPat,+        isEmptyTy, normSplitTyConApp_maybe,++        -- * Working with ticks+        stripTicksTop, stripTicksTopE, stripTicksTopT,+        stripTicksE, stripTicksT,++        -- * InScopeSet things which work over CoreBinds+        mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,++        -- * StaticPtr+        collectMakeStaticArgs,++        -- * Join points+        isJoinBind,++        -- * Tag inference+        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,++        -- * unsafeEqualityProof+        isUnsafeEqualityCase,++        -- * Dumping stuff+        dumpIdInfoOfProgram+    ) where++import GHC.Prelude+import GHC.Platform++import GHC.Core+import GHC.Core.Ppr+import GHC.Core.FVs( bindFreeVars )+import GHC.Core.DataCon+import GHC.Core.Type as Type+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+import GHC.Core.Reduction+import GHC.Core.TyCon+import GHC.Core.Multiplicity++import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey )+import GHC.Builtin.PrimOps++import GHC.Types.Var+import GHC.Types.SrcLoc+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic( Arity )+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.Demand+import GHC.Types.RepType (isZeroBitTy)++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.List.SetOps( minusList )+import GHC.Data.OrdList++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Data.ByteString     ( ByteString )+import Data.Function       ( on )+import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )+import qualified Data.List as Partial ( init, last )+import Data.Ord            ( comparing )+import Control.Monad       ( guard )+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+\subsection{Find the type of a Core atom/expression}+*                                                                      *+************************************************************************+-}++exprType :: HasDebugCallStack => CoreExpr -> Type+-- ^ Recover the type of a well-typed Core expression. Fails when+-- applied to the actual 'GHC.Core.Type' expression as it cannot+-- really be said to have a type+exprType (Var var)           = idType var+exprType (Lit lit)           = literalType lit+exprType (Coercion co)       = coercionType co+exprType (Let bind body)+  | NonRec tv rhs <- bind    -- See Note [Type bindings]+  , Type ty <- rhs           = substTyWithUnchecked [tv] [ty] (exprType body)+  | otherwise                = exprType body+exprType (Case _ _ ty _)     = ty+exprType (Cast _ co)         = coercionRKind co+exprType (Tick _ e)          = exprType e+exprType (Lam binder expr)   = mkLamType binder (exprType expr)+exprType e@(App _ _)+  = case collectArgs e of+        (fun, args) -> applyTypeToArgs (exprType fun) args+exprType (Type ty) = pprPanic "exprType" (ppr ty)++coreAltType :: CoreAlt -> Type+-- ^ Returns the type of the alternatives right hand side+coreAltType alt@(Alt _ bs rhs)+  = case occCheckExpand bs rhs_ty of+      -- Note [Existential variables and silly type synonyms]+      Just ty -> ty+      Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty)+  where+    rhs_ty = exprType rhs++coreAltsType :: [CoreAlt] -> Type+-- ^ Returns the type of the first alternative, which should be the same as for all alternatives+coreAltsType (alt:_) = coreAltType alt+coreAltsType []      = panic "coreAltsType"++mkLamType  :: HasDebugCallStack => Var -> Type -> Type+-- ^ Makes a @(->)@ type or an implicit forall type, depending+-- on whether it is given a type variable or a term variable.+-- This is used, for example, when producing the type of a lambda.+--+mkLamTypes :: [Var] -> Type -> Type+-- ^ 'mkLamType' for multiple type or value arguments++mkLamType v body_ty+   | isTyVar v+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty+     -- coreTyLamForAllTyFlag: see Note [Required foralls in Core]+     --                        in GHC.Core.TyCo.Rep++   | isCoVar v+   , v `elemVarSet` tyCoVarsOfType body_ty+     -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty++   | otherwise+   = mkFunctionType (idMult v) (idType v) body_ty++mkLamTypes vs ty = foldr mkLamType ty vs++{-+Note [Type bindings]+~~~~~~~~~~~~~~~~~~~~+Core does allow type bindings, although such bindings are+not much used, except in the output of the desugarer.+Example:+     let a = Int in (\x:a. x)+Given this, exprType must be careful to substitute 'a' in the+result type (#8522).++Note [Existential variables and silly type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        data T = forall a. T (Funny a)+        type Funny a = Bool+        f :: T -> Bool+        f (T x) = x++Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.+That means that 'exprType' and 'coreAltsType' may give a result that *appears*+to mention an out-of-scope type variable.  See #3409 for a more real-world+example.++Various possibilities suggest themselves:++ - Ignore the problem, and make Lint not complain about such variables++ - Expand all type synonyms (or at least all those that discard arguments)+      This is tricky, because at least for top-level things we want to+      retain the type the user originally specified.++ - Expand synonyms on the fly, when the problem arises. That is what+   we are doing here.  It's not too expensive, I think.++Note that there might be existentially quantified coercion variables, too.+-}++applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type+-- ^ Determines the type resulting from applying an expression with given type+--- to given argument expressions.+applyTypeToArgs op_ty args+  = go op_ty args+  where+    go op_ty []                   = op_ty+    go op_ty (Type ty : args)     = go_ty_args op_ty [ty] args+    go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args+    go op_ty (_ : args)           | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty+                                  = go res_ty args+    go _ args = pprPanic "applyTypeToArgs" (panic_msg args)++    -- go_ty_args: accumulate type arguments so we can+    -- instantiate all at once with piResultTys+    go_ty_args op_ty rev_tys (Type ty : args)+       = go_ty_args op_ty (ty:rev_tys) args+    go_ty_args op_ty rev_tys (Coercion co : args)+       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args+    go_ty_args op_ty rev_tys args+       = go (piResultTys op_ty (reverse rev_tys)) args++    panic_msg as = vcat [ text "Type:" <+> ppr op_ty+                        , text "Args:" <+> ppr args+                        , text "Args':" <+> ppr as ]++mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr+mkCastMCo e MRefl    = e+mkCastMCo e (MCo co) = Cast e co+  -- We are careful to use (MCo co) only when co is not reflexive+  -- Hence (Cast e co) rather than (mkCast e co)++mkPiMCo :: Var -> MCoercionR -> MCoercionR+mkPiMCo _  MRefl   = MRefl+mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)+++{- *********************************************************************+*                                                                      *+             Casts+*                                                                      *+********************************************************************* -}++-- | Wrap the given expression in the coercion safely, dropping+-- identity coercions and coalescing nested coercions+mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr++mkCast expr co+  = assertPpr (coercionRole co == Representational)+              (text "coercion" <+> ppr co <+> text "passed to mkCast"+               <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $+    warnPprTrace (not (coercionLKind co `eqType` exprType expr))+          "Trying to coerce" (text "(" <> ppr expr+          $$ text "::" <+> ppr (exprType expr) <> text ")"+          $$ ppr co $$ ppr (coercionType co)+          $$ callStackDoc) $+    case expr of+      Cast expr co2 -> mkCast expr (mkTransCo co2 co)+      Tick t expr   -> Tick t (mkCast expr 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+                      -> Coercion (mkCoCast e_co co)++      _ | isReflCo co -> expr+        | otherwise   -> Cast expr co+++{- *********************************************************************+*                                                                      *+             Attaching ticks+*                                                                      *+********************************************************************* -}++-- | Wraps the given expression in the source annotation, dropping the+-- annotation if possible.+mkTick :: CoreTickish -> CoreExpr -> CoreExpr+mkTick t orig_expr = mkTick' id id orig_expr+ where+  -- Some ticks (cost-centres) can be split in two, with the+  -- non-counting part having laxer placement properties.+  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t+  -- mkTick' handles floating of ticks *into* the expression.+  -- In this function, `top` is applied after adding the tick, and `rest` before.+  -- This will result in applications that look like (top $ Tick t $ rest expr).+  -- If we want to push the tick deeper, we pre-compose `top` with a function+  -- adding the tick.+  mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through)+          -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with)+          -> CoreExpr               -- current expression+          -> CoreExpr+  mkTick' top rest expr = case expr of+    -- Float ticks into unsafe coerce the same way we would do with a cast.+    Case scrut bndr ty alts@[Alt ac abs _rhs]+      | Just rhs <- isUnsafeEqualityCase scrut bndr alts+      -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs++    -- Cost centre ticks should never be reordered relative to each+    -- other. Therefore we can stop whenever two collide.+    Tick t2 e+      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr++    -- Otherwise we assume that ticks of different placements float+    -- through each other.+      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e++    -- For annotations this is where we make sure to not introduce+    -- redundant ticks.+      | tickishContains t t2              -> mkTick' top rest e+      | tickishContains t2 t              -> orig_expr+      | otherwise                         -> mkTick' top (rest . Tick t2) e++    -- Ticks don't care about types, so we just float all ticks+    -- through them. Note that it's not enough to check for these+    -- cases top-level. While mkTick will never produce Core with type+    -- expressions below ticks, such constructs can be the result of+    -- unfoldings. We therefore make an effort to put everything into+    -- the right place no matter what we start with.+    Cast e co   -> mkTick' (top . flip Cast co) rest e+    Coercion co -> Coercion co++    Lam x e+      -- Always float through type lambdas. Even for non-type lambdas,+      -- floating is allowed for all but the most strict placement rule.+      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime+      -> mkTick' (top . Lam x) rest e++      -- If it is both counting and scoped, we split the tick into its+      -- two components, often allowing us to keep the counting tick on+      -- the outside of the lambda and push the scoped tick inside.+      -- The point of this is that the counting tick can probably be+      -- floated, and the lambda may then be in a position to be+      -- beta-reduced.+      | canSplit+      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e++    App f arg+      -- Always float through type applications.+      | not (isRuntimeArg arg)+      -> mkTick' (top . flip App arg) rest f++      -- We can also float through constructor applications, placement+      -- permitting. Again we can split.+      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)+      -> if tickishPlace t == PlaceCostCentre+         then top $ rest $ tickHNFArgs t expr+         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr++    Var x+      | notFunction && tickishPlace t == PlaceCostCentre+      -> orig_expr+      | notFunction && canSplit+      -> top $ Tick (mkNoScope t) $ rest expr+      where+        -- SCCs can be eliminated on variables provided the variable+        -- is not a function.  In these cases the SCC makes no difference:+        -- the cost of evaluating the variable will be attributed to its+        -- definition site.  When the variable refers to a function, however,+        -- an SCC annotation on the variable affects the cost-centre stack+        -- when the function is called, so we must retain those.+        notFunction = not (isFunTy (idType x))++    Lit{}+      | tickishPlace t == PlaceCostCentre+      -> orig_expr++    -- Catch-all: Annotate where we stand+    _any -> top $ Tick t $ rest expr++mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr+mkTicks ticks expr = foldr mkTick expr ticks++isSaturatedConApp :: CoreExpr -> Bool+isSaturatedConApp e = go e []+  where go (App f a) as = go f (a:as)+        go (Var fun) args+           = isConLikeId fun && idArity fun == valArgCount args+        go (Cast f _) as = go f as+        go _ _ = False++mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr+mkTickNoHNF t e+  | exprIsHNF e = tickHNFArgs t e+  | otherwise   = mkTick t e++-- push a tick into the arguments of a HNF (call or constructor app)+tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr+tickHNFArgs t e = push t e+ where+  push t (App f (Type u)) = App (push t f) (Type u)+  push t (App f arg) = App (push t f) (mkTick t arg)+  push _t e = e++-- | Strip ticks satisfying a predicate from top of an expression+stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)+stripTicksTop p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts other            = (reverse ts, other)++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the remaining expression+stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b+stripTicksTopE p = go+  where go (Tick t e) | p t = go e+        go other            = other++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the ticks+stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]+stripTicksTopT p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts _                = ts++-- | Completely strip ticks satisfying a predicate from an+-- expression. Note this is O(n) in the size of the expression!+stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b+stripTicksE p expr = go expr+  where go (App e a)        = App (go e) (go a)+        go (Lam b e)        = Lam b (go e)+        go (Let b e)        = Let (go_bs b) (go e)+        go (Case e b t as)  = Case (go e) b t (map go_a as)+        go (Cast e c)       = Cast (go e) c+        go (Tick t e)+          | p t             = go e+          | otherwise       = Tick t (go e)+        go other            = other+        go_bs (NonRec b e)  = NonRec b (go e)+        go_bs (Rec bs)      = Rec (map go_b bs)+        go_b (b, e)         = (b, go e)+        go_a (Alt c bs e)   = Alt c bs (go e)++stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]+stripTicksT p expr = fromOL $ go expr+  where go (App e a)        = go e `appOL` go a+        go (Lam _ e)        = go e+        go (Let b e)        = go_bs b `appOL` go e+        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)+        go (Cast e _)       = go e+        go (Tick t e)+          | p t             = t `consOL` go e+          | otherwise       = go e+        go _                = nilOL+        go_bs (NonRec _ e)  = go e+        go_bs (Rec bs)      = concatOL (map go_b bs)+        go_b (_, e)         = go e+        go_a (Alt _ _ e)    = go e++{-+************************************************************************+*                                                                      *+\subsection{Other expression construction}+*                                                                      *+************************************************************************+-}++bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr+-- ^ @bindNonRec x r b@ produces either:+--+-- > let x = r in b+--+-- or:+--+-- > case r of x { _DEFAULT_ -> b }+--+-- depending on whether we have to use a @case@ or @let@+-- binding for the expression (see 'needsCaseBinding').+-- It's used by the desugarer to avoid building bindings+-- that give Core Lint a heart attack, although actually+-- the simplifier deals with them perfectly well. See+-- also 'GHC.Core.Make.mkCoreLet'+bindNonRec bndr rhs body+  | isTyVar bndr                       = let_bind+  | isCoVar bndr                       = if isCoArg rhs then let_bind+    {- See Note [Binding coercions] -}                  else case_bind+  | isJoinId bndr                      = let_bind+  | needsCaseBinding (idType bndr) rhs = case_bind+  | otherwise                          = let_bind+  where+    case_bind = mkDefaultCase rhs bndr body+    let_bind  = Let (NonRec bndr rhs) body++-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@+-- binding for this expression as per the invariants of 'CoreExpr': see+-- "GHC.Core#let_can_float_invariant"+-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else+-- `typeLevity ty` will fail; but that should be the case because+-- `needsCaseBinding` is only called once typechecking is complete+needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool+needsCaseBinding ty rhs = needsCaseBindingL (typeLevity ty) rhs++needsCaseBindingL :: Levity -> CoreExpr -> Bool+-- True <=> make a case expression instead of a let+-- These can arise either from the desugarer,+-- or from beta reductions: (\x.e) (x +# y)+needsCaseBindingL Lifted   _rhs = False+needsCaseBindingL Unlifted rhs = not (exprOkForSpeculation rhs)++mkAltExpr :: AltCon     -- ^ Case alternative constructor+          -> [CoreBndr] -- ^ Things bound by the pattern match+          -> [Type]     -- ^ The type arguments to the case alternative+          -> CoreExpr+-- ^ This guy constructs the value that the scrutinee must have+-- given that you are in one particular branch of a case+mkAltExpr (DataAlt con) args inst_tys+  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)+mkAltExpr (LitAlt lit) [] []+  = Lit lit+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"++mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr+-- Make (case x of y { DEFAULT -> e }+mkDefaultCase scrut case_bndr body+  = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body]++mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr+-- Use this function if possible, when building a case,+-- because it ensures that the type on the Case itself+-- doesn't mention variables bound by the case+-- See Note [Care with the type of a case expression]+mkSingleAltCase scrut case_bndr con bndrs body+  = Case scrut case_bndr case_ty [Alt con bndrs body]+  where+    body_ty = exprType body++    case_ty -- See Note [Care with the type of a case expression]+      | Just body_ty' <- occCheckExpand bndrs body_ty+      = body_ty'++      | otherwise+      = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty)++{- Note [Care with the type of a case expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a phantom type synonym+   type S a = Int+and we want to form the case expression+   case x of K (a::*) -> (e :: S a)++We must not make the type field of the case-expression (S a) because+'a' isn't in scope.  Hence the call to occCheckExpand.  This caused+issue #17056.++NB: this situation can only arise with type synonyms, which can+falsely "mention" type variables that aren't "really there", and which+can be eliminated by expanding the synonym.++Note [Binding coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider binding a CoVar, c = e.  Then, we must satisfy+Note [Core type and coercion invariant] in GHC.Core,+which allows only (Coercion co) on the RHS.++************************************************************************+*                                                                      *+               Operations over case alternatives+*                                                                      *+************************************************************************++The default alternative must be first, if it exists at all.+This makes it easy to find, though it makes matching marginally harder.+-}++-- | Extract the default case alternative+findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)+findDefault alts                          =                    (alts, Nothing)++addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]+addDefault alts Nothing    = alts+addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts++isDefaultAlt :: Alt b -> Bool+isDefaultAlt (Alt DEFAULT _ _) = True+isDefaultAlt _                 = False++-- | Find the case alternative corresponding to a particular+-- constructor: panics if no such constructor exists+findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)+    -- A "Nothing" result *is* legitimate+    -- See Note [Unreachable code]+findAlt con alts+  = case alts of+        (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt)+        _                              -> go alts Nothing+  where+    go []                     deflt = deflt+    go (alt@(Alt con1 _ _) : alts) deflt+      = case con `cmpAltCon` con1 of+          LT -> deflt   -- Missed it already; the alts are in increasing order+          EQ -> Just alt+          GT -> assert (not (con1 == DEFAULT)) $ go alts deflt++{- Note [Unreachable code]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible (although unusual) for GHC to find a case expression+that cannot match.  For example:++     data Col = Red | Green | Blue+     x = Red+     f v = case x of+              Red -> ...+              _ -> ...(case x of { Green -> e1; Blue -> e2 })...++Suppose that for some silly reason, x isn't substituted in the case+expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff+gets in the way; cf #3118.)  Then the full-laziness pass might produce+this++     x = Red+     lvl = case x of { Green -> e1; Blue -> e2 })+     f v = case x of+             Red -> ...+             _ -> ...lvl...++Now if x gets inlined, we won't be able to find a matching alternative+for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing+we generate (error "Inaccessible alternative").++Similar things can happen (augmented by GADTs) when the Simplifier+filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase.+-}++---------------------------------+mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])+-- See Note [Merge Nested Cases]+mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)+  | Just (joins, inner_alts) <- go deflt_rhs+  = Just (joins, mergeAlts outer_alts inner_alts)+                -- NB: mergeAlts gives priority to the left+                --      case x of+                --        A -> e1+                --        DEFAULT -> case x of+                --                      A -> e2+                --                      B -> e3+                -- When we merge, we must ensure that e1 takes+                -- precedence over e2 as the value for A!+  where+    go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])++    -- Whizzo: we can merge!+    go (Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       | inner_scrut_var == outer_bndr+       , not (inner_bndr == outer_bndr)   -- Avoid shadowing+       , let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs'+                -- inner_bndr is never dead!  It's the scrutinee!+                -- The let is OK even for unboxed binders+                -- See Note [Merge Nested Cases] wrinkle (MC2)+             do_one (Alt con bndrs rhs)+               | any (== outer_bndr) bndrs = Nothing+               | otherwise                 = Just (Alt con bndrs (wrap_let rhs))+       = do { alts' <- mapM do_one inner_alts+            ; return ([], alts') }++    -- Deal with tagToEnum# See Note [Merge Nested Cases] wrinkle (MC3)+    go (App (App (Var f) (Type type_arg)) (Var v))+      | v == outer_bndr+      , Just TagToEnumOp <- isPrimOpId_maybe f+      , Just tc  <- tyConAppTyCon_maybe type_arg+      , Just (dc1:dcs) <- tyConDataCons_maybe tc   -- At least one data constructor+      , dcs `lengthAtMost` 3  -- Arbitrary+      = return ( [], mk_alts dc1 dcs)+      where+        mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc+        mk_rhs dc = Var (dataConWorkId dc)+        mk_alts dc1 dcs =  Alt DEFAULT              [] (mk_rhs dc1)+                        : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs]++    -- Float out let/join bindings+    -- See Note [Merge Nested Cases] wrinkle (MC4)+    go (Let bind body)+      | null outer_alts || isJoinBind bind+      = do { (joins, alts) <- go body++             -- Check for capture; but only if we could otherwise do a merge+           ; let capture = outer_bndr `elem` bindersOf bind+                           || outer_bndr `elemVarSet` bindFreeVars bind+           ; guard (not capture)++           ; return (bind:joins, alts ) }+      | otherwise+      = Nothing++    -- We don't want ticks to get in the way; just push them inwards.+    -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)+    go (Tick t body)+      = do { (joins, alts) <- go body+           ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }++    go _ = Nothing++mergeCaseAlts _ _ = Nothing++---------------------------------+mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]+-- ^ Merge alternatives preserving order; alternatives in+-- the first argument shadow ones in the second+mergeAlts [] as2 = as2+mergeAlts as1 [] = as1+mergeAlts (a1:as1) (a2:as2)+  = case a1 `cmpAlt` a2 of+        LT -> a1 : mergeAlts as1      (a2:as2)+        EQ -> a1 : mergeAlts as1      as2       -- Discard a2+        GT -> a2 : mergeAlts (a1:as1) as2+++---------------------------------+trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]+-- ^ Given:+--+-- > case (C a b x y) of+-- >        C b x y -> ...+--+-- We want to drop the leading type argument of the scrutinee+-- leaving the arguments to match against the pattern++trimConArgs DEFAULT      args = assert (null args) []+trimConArgs (LitAlt _)   args = assert (null args) []+trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args++filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)+           -> [Type]               -- ^ And its type arguments+           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee+           -> [Alt b] -- ^ Alternatives+           -> ([AltCon], [Alt b])+             -- Returns:+             --  1. Constructors that will never be encountered by the+             --     *default* case (if any).  A superset of imposs_cons+             --  2. The new alternatives, trimmed by+             --        a) remove imposs_cons+             --        b) remove constructors which can't match because of GADTs+             --+             -- NB: the final list of alternatives may be empty:+             -- This is a tricky corner case.  If the data type has no constructors,+             -- which GHC allows, or if the imposs_cons covers all constructors (after taking+             -- account of GADTs), then no alternatives can match.+             --+             -- If callers need to preserve the invariant that there is always at least one branch+             -- in a "case" statement then they will need to manually add a dummy case branch that just+             -- calls "error" or similar.+filterAlts _tycon inst_tys imposs_cons alts+  = imposs_deflt_cons `seqList`+      (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)+  -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which+  -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter+  -- leads to a huge space leak (see #22102 and !8896)+  where+    (alts_wo_default, maybe_deflt) = findDefault alts+    alt_cons = [con | Alt con _ _ <- alts_wo_default]++    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default++    imposs_cons_set = Set.fromList imposs_cons+    imposs_deflt_cons =+      imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons+         -- "imposs_deflt_cons" are handled+         --   EITHER by the context,+         --   OR by a non-DEFAULT branch in this case expression.++    impossible_alt :: [Type] -> Alt b -> Bool+    impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True+    impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con+    impossible_alt _  _                             = False++-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.+-- See Note [Refine DEFAULT case alternatives]+refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders+                 -> Mult              -- ^ Multiplicity annotation of the case expression+                 -> TyCon             -- ^ Type constructor of scrutinee's type+                 -> [Type]            -- ^ Type arguments of scrutinee's type+                 -> [AltCon]          -- ^ Constructors that cannot match the DEFAULT (if any)+                 -> [CoreAlt]+                 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt'+refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts+  | Alt DEFAULT _ rhs : rest_alts <- all_alts+  , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.+  , not (isNewTyCon tycon)      -- Exception 1 in Note [Refine DEFAULT case alternatives]+  , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives]+  , Just all_cons <- tyConDataCons_maybe tycon+  , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons]+                             -- We now know it's a data type, so we can use+                             -- UniqSet rather than Set (more efficient)+        impossible con   = con `elementOfUniqSet` imposs_data_cons+                             || dataConCannotMatch tys con+  = case filterOut impossible all_cons of+       -- Eliminate the default alternative+       -- altogether if it can't match:+       []    -> (False, rest_alts)++       -- It matches exactly one constructor, so fill it in:+       [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs])+                       -- We need the mergeAlts to keep the alternatives in the right order+             where+                (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys++       -- It matches more than one, so do nothing+       _  -> (False, all_alts)++  | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)+  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)+        -- Check for no data constructors+        -- This can legitimately happen for abstract types and type families,+        -- so don't report that+  = (False, all_alts)++  | otherwise      -- The common case+  = (False, all_alts)++{- Note [Merge Nested Cases]+~~~~~~~~~~~~~~~~~~~~~~~~~+       case e of b {             ==>   case e of b {+         p1 -> rhs1                      p1 -> rhs1+         ...                             ...+         pm -> rhsm                      pm -> rhsm+         _  -> case b of b' {            pn -> let b'=b in rhsn+                     pn -> rhsn          ...+                     ...                 po -> let b'=b in rhso+                     po -> rhso          _  -> let b'=b in rhsd+                     _  -> rhsd+       }++which merges two cases in one case when -- the default alternative of+the outer case scrutinises the same variable as the outer case. This+transformation is called Case Merging.  It avoids that the same+variable is scrutinised multiple times.++Wrinkles++(MC1) Historical note. I tried making `mergeCaseAlts` "looks though" an inner+     single-alternative case-on-variable. For example+       case x of {+          ...outer-alts...+          DEFAULT -> case y of (a,b) ->+                     case x of { A -> rhs1; B -> rhs2 }+    ===>+       case x of+         ...outer-alts...+         a -> case y of (a,b) -> rhs1+         B -> case y of (a,b) -> rhs2++    This duplicates the `case y` but it removes the case x; so it is a win+    in terms of execution time (combining the cases on x) at the cost of+    perhaps duplicating the `case y`.  A case in point is integerEq, which+    is defined thus+        integerEq :: Integer -> Integer -> Bool+        integerEq !x !y = isTrue# (integerEq# x y)+    which becomes+        integerEq+          = \ (x :: Integer) (y_aAL :: Integer) ->+              case x of x1 { __DEFAULT ->+              case y of y1 { __DEFAULT ->+              case x1 of {+                IS x2 -> case y1 of {+                           __DEFAULT -> GHC.Types.False;+                           IS y2     -> tagToEnum# @Bool (==# x2 y2) };+                IP x2 -> ...+                IN x2 -> ...+    We want to merge the outer `case x` with the inner `case x1`.++    But (a) this is all a bit dubious: see #24251, and+        (b) it is hard to combine with (MC4)+    So I'm not doing this any more.  If we want to do it, we'll handle it+    separately: #24251.++    End of historical note++(MC2) The auxiliary bindings b'=b are annoying, because they force another+      simplifier pass, but there seems no easy way to avoid them.  See+      Note [Which transformations are innocuous] in GHC.Core.Opt.Stats.++(MC3) Consider+         case f x of (r::Int#) -> tagToEnum# r :: Bool+      `mergeCaseAlts` as a special case to treat this as if it was+         case f x of r ->+           case r of { 0# -> False; 1# -> True }+      which can be merged to+         case f x of { 0# -> False; 1# -> True }++      To see why this is important, return to+         case f x of (r::Int#) -> tagToEnum# r :: Bool+      and supppose `f` inlines to a case expression.  Then then we get+         let $j r = tagToEnum# r+         case .. of { .. jump $j 0#; ...jump $j 1# ... }+      Now if the entire expression is consumed by another case-expression,+      that outer case will only see (tagToEnum# r) which it can't do much+      with.  Whereas the result of the above case-merge generates much better+      code: no branching on Int#++(MC4) Consider+          case f x of r ->+            join $j y = <rhs> in+            case r of { ...alts ... }+      This is pretty common, and it a pity for it to defeat the case-merge+      transformation; and it makes the optimiser fragile to inlining decisions+      for join points.++      So `mergeCaseAlts` floats out any join points. It doesn't float out+      non-join-points unless the /outer/ case has just one alternative; doing+      so would risk more allocation++(MC5) See Note [Cascading case merge]++See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils+++Note [Cascading case merge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case merging should cascade in one sweep, because the Simplifier tries it /after/+simplifying (and hence case-merging) the inner case.  For example++      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> case b of c {+                                     DEFAULT -> e+                                     A -> ea+                      B -> eb+        C -> ec+==> {simplify inner case}+      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> let c = b in e+                      A -> let c = b in ea+                      B -> eb+        C -> ec+==> {case-merge on outer case}+      case e of a {+        DEFAULT -> let b = a in let c = b in e+        A -> let b = a in let c = b in ea+        B -> let b = a in eb+        C -> ec+++However here's a tricky case that we still don't catch, and I don't+see how to catch it in one pass:++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++After occurrence analysis (and its binder-swap) we get this++  case x of c1 { I# a1 ->+  let x = c1 in         -- Binder-swap addition+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++When we simplify the inner case x, we'll see that+x=c1=I# a1.  So we'll bind a2 to a1, and get++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case a1 of ...++This is correct, but we can't do a case merge in this sweep+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards+without getting changed to c1=I# c2.++I don't think this is worth fixing, even if I knew how. It'll+all come out in the next pass anyway.+++Note [Refine DEFAULT case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+refineDefaultAlt replaces the DEFAULT alt with a constructor if there+is one possible value it could be.++The simplest example being+    foo :: () -> ()+    foo x = case x of !_ -> ()+which rewrites to+    foo :: () -> ()+    foo x = case x of () -> ()++There are two reasons in general why replacing a DEFAULT alternative+with a specific constructor is desirable.++1. We can simplify inner expressions.  For example++       data Foo = Foo1 ()++       test :: Foo -> ()+       test x = case x of+                  DEFAULT -> mid (case x of+                                    Foo1 x1 -> x1)++   refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then+   x becomes bound to `Foo ip1` so is inlined into the other case+   which causes the KnownBranch optimisation to kick in. If we don't+   refine DEFAULT to `Foo ip1`, we are left with both case expressions.++2. combineIdenticalAlts does a better job. For example (Simon Jacobi)+       data D = C0 | C1 | C2++       case e of+         DEFAULT -> e0+         C0      -> e1+         C1      -> e1++   When we apply combineIdenticalAlts to this expression, it can't+   combine the alts for C0 and C1, as we already have a default case.+   But if we apply refineDefaultAlt first, we get+       case e of+         C0 -> e1+         C1 -> e1+         C2 -> e0+   and combineIdenticalAlts can turn that into+       case e of+         DEFAULT -> e1+         C2 -> e0++   It isn't obvious that refineDefaultAlt does this but if you look+   at its one call site in GHC.Core.Opt.Simplify.Utils then the+   `imposs_deflt_cons` argument is populated with constructors which+   are matched elsewhere.++There are two exceptions where we avoid refining a DEFAULT case:++* Exception 1: Newtypes++  We can have a newtype, if we are just doing an eval:++    case x of { DEFAULT -> e }++  And we don't want to fill in a default for them!++* Exception 2: `type data` declarations++  The data constructors for a `type data` declaration (see+  Note [Type data declarations] in GHC.Rename.Module) do not exist at the+  value level. Nevertheless, it is possible to strictly evaluate a value+  whose type is a `type data` declaration. Test case+  type-data/should_compile/T2294b.hs contains an example:++    type data T a where+      A :: T Int++    f :: T a -> ()+    f !x = ()++  We want to generate the following Core for f:++    f = \(@a) (x :: T a) ->+         case x of+           __DEFAULT -> ()++  Namely, we do _not_ want to match on `A`, as it doesn't exist at the value+  level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module+++Note [Combine identical alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If several alternatives are identical, merge them into a single+DEFAULT alternative.  I've occasionally seen this making a big+difference:++     case e of               =====>     case e of+       C _ -> f x                         D v -> ....v....+       D v -> ....v....                   DEFAULT -> f x+       DEFAULT -> f x++The point is that we merge common RHSs, at least for the DEFAULT case.+[One could do something more elaborate but I've never seen it needed.]+To avoid an expensive test, we just merge branches equal to the *first*+alternative; this picks up the common cases+     a) all branches equal+     b) some branches equal to the DEFAULT (which occurs first)++The case where Combine Identical Alternatives transformation showed up+was like this (base/Foreign/C/Err/Error.hs):++        x | p `is` 1 -> e1+          | p `is` 2 -> e2+        ...etc...++where @is@ was something like++        p `is` n = p /= (-1) && p == n++This gave rise to a horrible sequence of cases++        case p of+          (-1) -> $j p+          1    -> e1+          DEFAULT -> $j p++and similarly in cascade for all the join points!++Note [Combine identical alternatives: wrinkles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++* It's important that we try to combine alternatives *before*+  simplifying them, rather than after. Reason: because+  Simplify.simplAlt may zap the occurrence info on the binders in the+  alternatives, which in turn defeats combineIdenticalAlts use of+  isDeadBinder (see #7360).++  You can see this in the call to combineIdenticalAlts in+  GHC.Core.Opt.Simplify.Utils.prepareAlts.  Here the alternatives have type InAlt+  (the "In" meaning input) rather than OutAlt.++* combineIdenticalAlts does not work well for nullary constructors+      case x of y+         []    -> f []+         (_:_) -> f y+  Here we won't see that [] and y are the same.  Sigh! This problem+  is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version+  of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have+  here.+  See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE).++Note [Care with impossible-constructors when combining alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#10538)+   data T = A | B | C | D++      case x::T of   (Imposs-default-cons {A,B})+         DEFAULT -> e1+         A -> e2+         B -> e1++When calling combineIdentialAlts, we'll have computed that the+"impossible constructors" for the DEFAULT alt is {A,B}, since if x is+A or B we'll take the other alternatives.  But suppose we combine B+into the DEFAULT, to get++      case x::T of   (Imposs-default-cons {A})+         DEFAULT -> e1+         A -> e2++Then we must be careful to trim the impossible constructors to just {A},+else we risk compiling 'e1' wrong!++Not only that, but we take care when there is no DEFAULT beforehand,+because we are introducing one.  Consider++   case x of   (Imposs-default-cons {A,B,C})+     A -> e1+     B -> e2+     C -> e1++Then when combining the A and C alternatives we get++   case x of   (Imposs-default-cons {B})+     DEFAULT -> e1+     B -> e2++Note that we have a new DEFAULT branch that we didn't have before.  So+we need delete from the "impossible-default-constructors" all the+known-con alternatives that we have eliminated. (In #11172 we+missed the first one.)++-}++combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT+                     -> [CoreAlt]+                     -> (Bool,      -- True <=> something happened+                         [AltCon],  -- New constructors that cannot match DEFAULT+                         [CoreAlt]) -- New alternatives+-- See Note [Combine identical alternatives]+-- True <=> we did some combining, result is a single DEFAULT alternative+combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)+  | all isDeadBinder bndrs1    -- Remember the default+  , not (null elim_rest) -- alternative comes first+  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)+  where+    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts+    deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1)++     -- See Note [Care with impossible-constructors when combining alternatives]+    imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons+    elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest+    elim_con1 = case con1 of     -- Don't forget con1!+                  DEFAULT -> []+                  _       -> [con1]++    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2+    identical_to_alt1 (Alt _con bndrs rhs)+      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1+    tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest++combineIdenticalAlts imposs_cons alts+  = (False, imposs_cons, alts)++-- Scales the multiplicity of the binders of a list of case alternatives. That+-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled.+scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]+scaleAltsBy w alts = map scaleAlt alts+  where+    scaleAlt :: CoreAlt -> CoreAlt+    scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs++    scaleBndr :: CoreBndr -> CoreBndr+    scaleBndr b = scaleVarBy w b+++{- *********************************************************************+*                                                                      *+             exprIsTrivial+*                                                                      *+************************************************************************++Note [exprIsTrivial]+~~~~~~~~~~~~~~~~~~~~+@exprIsTrivial@ is true of expressions we are unconditionally happy to+                duplicate; simple variables and constants, and type+                applications.  Note that primop Ids aren't considered+                trivial unless++Note [Variables are trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There used to be a gruesome test for (hasNoBinding v) in the+Var case:+        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0+The idea here is that a constructor worker, like \$wJust, is+really short for (\x -> \$wJust x), because \$wJust has no binding.+So it should be treated like a lambda.  Ditto unsaturated primops.+But now constructor workers are not "have-no-binding" Ids.  And+completely un-applied primops and foreign-call Ids are sufficiently+rare that I plan to allow them to be duplicated and put up with+saturating them.++Note [Tick trivial]+~~~~~~~~~~~~~~~~~~~+Ticks are only trivial if they are pure annotations. If we treat+"tick<n> x" as trivial, it will be inlined inside lambdas and the+entry count will be skewed, for example.  Furthermore "scc<n> x" will+turn into just "x" in mkTick. At least if `x` is not a function.++Note [Empty case is trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (case (x::Int) Bool of {}) is just a type-changing+case used when we are sure that 'x' will not return.  See+Note [Empty case alternatives] in GHC.Core.++If the scrutinee is trivial, then so is the whole expression; and the+CoreToSTG pass in fact drops the case expression leaving only the+scrutinee.++Having more trivial expressions is good.  Moreover, if we don't treat+it as trivial we may land up with let-bindings like+   let v = case x of {} in ...+and after CoreToSTG that gives+   let v = x in ...+and that confuses the code generator (#11155). So best to kill+it off at source.+-}++{-# INLINE trivial_expr_fold #-}+trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r+-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]+-- This is meant to have the code of both functions in one place and make it+-- easy to derive custom predicates.+--+-- (trivial_expr_fold k_id k_triv k_not_triv e)+-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)+-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)+-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)+-- * returns k_not_triv otherwise+--+-- where "trivial wrapping" is+-- * Type application or abstraction+-- * Ticks other than `tickishIsCode`+-- * `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!+    -- (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 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+    go (Case e b _ as)+      | null as+      = go e     -- See Note [Empty case is trivial]+      | Just rhs <- isUnsafeEqualityCase e b as+      = go rhs   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+    go _                                  = k_not_triv++exprIsTrivial :: CoreExpr -> Bool+exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e++{-+Note [getIdFromTrivialExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When substituting in a breakpoint we need to strip away the type cruft+from a trivial expression and get back to the Id.  The invariant is+that the expression we're substituting was originally trivial+according to exprIsTrivial, AND the expression is not a literal.+See Note [substTickish] for how breakpoint substitution preserves+this extra invariant.++We also need this functionality in CorePrep to extract out Id of a+function which we are saturating.  However, in this case we don't know+if the variable actually refers to a literal; thus we use+'getIdFromTrivialExpr_maybe' to handle this case.  See test+T12076lit for an example where this matters.+-}++getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id+-- See Note [getIdFromTrivialExpr]+getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e+  where+    panic = pprPanic "getIdFromTrivialExpr" (ppr e)++getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id+getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e++{- *********************************************************************+*                                                                      *+             exprIsDupable+*                                                                      *+************************************************************************++Note [exprIsDupable]+~~~~~~~~~~~~~~~~~~~~+@exprIsDupable@ is true of expressions that can be duplicated at a modest+                cost in code size.  This will only happen in different case+                branches, so there's no issue about duplicating work.++                That is, exprIsDupable returns True of (f x) even if+                f is very very expensive to call.++                Its only purpose is to avoid fruitless let-binding+                and then inlining of case join points+-}++exprIsDupable :: Platform -> CoreExpr -> Bool+exprIsDupable platform e+  = isJust (go dupAppSize e)+  where+    go :: Int -> CoreExpr -> Maybe Int+    go n (Type {})     = Just n+    go n (Coercion {}) = Just n+    go n (Var {})      = decrement n+    go n (Tick _ e)    = go n e+    go n (Cast e _)    = go n e+    go n (App f a) | Just n' <- go n a = go n' f+    go n (Lit lit) | litIsDupable platform lit = decrement n+    go _ _ = Nothing++    decrement :: Int -> Maybe Int+    decrement 0 = Nothing+    decrement n = Just (n-1)++dupAppSize :: Int+dupAppSize = 8   -- Size of term we are prepared to duplicate+                 -- This is *just* big enough to make test MethSharing+                 -- inline enough join points.  Really it should be+                 -- smaller, and could be if we fixed #4960.++{-+************************************************************************+*                                                                      *+             exprIsCheap, exprIsExpandable+*                                                                      *+************************************************************************++Note [exprIsWorkFree]+~~~~~~~~~~~~~~~~~~~~~+exprIsWorkFree is used when deciding whether to inline something; we+don't inline it if doing so might duplicate work, by peeling off a+complete copy of the expression.  Here we do not want even to+duplicate a primop (#5623):+   eg   let x = a #+ b in x +# x+   we do not want to inline/duplicate x++Previously we were a bit more liberal, which led to the primop-duplicating+problem.  However, being more conservative did lead to a big regression in+one nofib benchmark, wheel-sieve1.  The situation looks like this:++   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool+       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->+         case GHC.Prim.<=# x_aRs 2 of _ {+           GHC.Types.False -> notDivBy ps_adM qs_adN;+           GHC.Types.True -> lvl_r2Eb }}+       go = \x. ...(noFactor (I# y))....(go x')...++The function 'noFactor' is heap-allocated and then called.  Turns out+that 'notDivBy' is strict in its THIRD arg, but that is invisible to+the caller of noFactor, which therefore cannot do w/w and+heap-allocates noFactor's argument.  At the moment (May 12) we are just+going to put up with this, because the previous more aggressive inlining+(which treated 'noFactor' as work-free) was duplicating primops, which+in turn was making inner loops of array calculations runs slow (#5623)++Note [Case expressions are work-free]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Are case-expressions work-free?  Consider+    let v = case x of (p,q) -> p+        go = \y -> ...case v of ...+Should we inline 'v' at its use site inside the loop?  At the moment+we do.  I experimented with saying that case are *not* work-free, but+that increased allocation slightly.  It's a fairly small effect, and at+the moment we go for the slightly more aggressive version which treats+(case x of ....) as work-free if the alternatives are.++Moreover it improves arities of overloaded functions where+there is only dictionary selection (no construction) involved++Note [exprIsCheap]+~~~~~~~~~~~~~~~~~~+See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold++@exprIsCheap@ looks at a Core expression and returns \tr{True} if+it is obviously in weak head normal form, or is cheap to get to WHNF.+Note that that's not the same as exprIsDupable; an expression might be+big, and hence not dupable, but still cheap.++By ``cheap'' we mean a computation we're willing to:+        push inside a lambda, or+        inline at more than one place+That might mean it gets evaluated more than once, instead of being+shared.  The main examples of things which aren't WHNF but are+``cheap'' are:++  *     case e of+          pi -> ei+        (where e, and all the ei are cheap)++  *     let x = e in b+        (where e and b are cheap)++  *     op x1 ... xn+        (where op is a cheap primitive operator)++  *     error "foo"+        (because we are happy to substitute it inside a lambda)++Notice that a variable is considered 'cheap': we can push it inside a lambda,+because sharing will make sure it is only evaluated once.++Note [exprIsCheap and exprIsHNF]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that exprIsHNF does not imply exprIsCheap.  Eg+        let x = fac 20 in Just x+This responds True to exprIsHNF (you can discard a seq), but+False to exprIsCheap.++Note [Arguments and let-bindings exprIsCheapX]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What predicate should we apply to the argument of an application, or the+RHS of a let-binding?++We used to say "exprIsTrivial arg" due to concerns about duplicating+nested constructor applications, but see #4978.  So now we just recursively+use exprIsCheapX.++We definitely want to treat let and app the same.  The principle here is+that+   let x = blah in f x+should behave equivalently to+   f blah++This in turn means that the 'letrec g' does not prevent eta expansion+in this (which it previously was):+    f = \x. let v = case x of+                      True -> letrec g = \w. blah+                              in g+                      False -> \x. x+            in \w. v True+-}++-------------------------------------+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 -> Bool -> CoreExpr -> Bool+{-# INLINE exprIsCheapX #-}+-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable+-- instead of having an unknown call to ok_app+-- 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++    -- n is the number of value arguments+    go n (Var v)                      = ok_app v n+    go _ (Lit {})                     = True+    go _ (Type {})                    = True+    go _ (Coercion {})                = True+    go n (Cast e _)                   = go n e+    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+    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 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]++--------------------+exprIsWorkFree :: CoreExpr -> Bool+-- See Note [exprIsWorkFree]+exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e++--------------------+exprIsCheap :: CoreExpr -> Bool+-- See Note [exprIsCheap]+exprIsCheap e = exprIsCheapX isCheapApp False e++--------------------+exprIsExpandable :: CoreExpr -> Bool+-- See Note [exprIsExpandable]+exprIsExpandable e = exprIsCheapX isExpandableApp True e++isWorkFreeApp :: CheapAppFun+isWorkFreeApp fn n_val_args+  | n_val_args == 0           -- No value args+  = True+  | n_val_args < idArity fn   -- Partial application+  = True+  | otherwise+  = case idDetails fn of+      DataConWorkId {} -> True+      PrimOpId op _    -> primOpIsWorkFree op+      _                -> False++isCheapApp :: CheapAppFun+isCheapApp fn n_val_args+  | isWorkFreeApp fn n_val_args = True+  | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]+  | otherwise+  = case idDetails fn of+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp+      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {}     -> n_val_args == 1+      PrimOpId op _    -> primOpIsCheap op+      _                -> False+        -- In principle we should worry about primops+        -- that return a type variable, since the result+        -- might be applied to something, but I'm not going+        -- to bother to check the number of args++isExpandableApp :: CheapAppFun+isExpandableApp fn n_val_args+  | 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+      _ | isDeadEndId fn     -> False+          -- See Note [isExpandableApp: bottoming functions]+        | isConLikeId fn     -> True+        | all_args_are_preds -> True+        | otherwise          -> False++  where+     -- See if all the arguments are PredTys (implicit params or classes)+     -- If so we'll regard it as expandable; see Note [Expandable overloadings]+     all_args_are_preds = all_pred_args n_val_args (idType fn)++     all_pred_args n_val_args ty+       | n_val_args == 0+       = True++       | Just (bndr, ty) <- splitPiTy_maybe ty+       = case bndr of+           Named {}  -> all_pred_args n_val_args ty+           Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty++       | otherwise+       = False++{- Note [isCheapApp: bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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+functions.  Recall  undefined :: HasCallStack => a+Suppose isExpandableApp responded True to (undefined d), and we had:++  x = undefined <dict-expr>++Then Simplify.prepareRhs would ANF the RHS:++  d = <dict-expr>+  x = undefined d++This is already bad: we gain nothing from having x bound to (undefined+var), unlike the case for data constructors.  Worse, we get the+simplifier loop described in OccurAnal Note [Cascading inlines].+Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will+certainly_inline; so we end up inlining d right back into x; but in+the end x doesn't inline because it is bottom (preInlineUnconditionally);+so the process repeats.. We could elaborate the certainly_inline logic+some more, but it's better just to treat bottoming bindings as+non-expandable, because ANFing them is a bad idea in the first place.++Note [Record selection]+~~~~~~~~~~~~~~~~~~~~~~~~~~+I'm experimenting with making record selection+look cheap, so we will substitute it inside a+lambda.  Particularly for dictionary field selection.++BUT: Take care with (sel d x)!  The (sel d) might be cheap, but+there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)++Note [Expandable overloadings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose the user wrote this+   {-# RULE  forall x. foo (negate x) = h x #-}+   f x = ....(foo (negate x))....+They'd expect the rule to fire. But since negate is overloaded, we might+get this:+    f = \d -> let n = negate d in \x -> ...foo (n x)...+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+-- an expression that is:+--+--  * Safe to evaluate even if normal order eval might not+--    evaluate the expression at all, and+--+--  * Safe /not/ to evaluate even if normal order would do so+--+-- More specifically, this means that:+--  * A: Evaluation of the expression reaches weak-head-normal-form,+--  * B: soon,+--  * C: without causing a write side effect (e.g. writing a mutable variable).+--+-- In particular, an expression that may+--  * throw a synchronous Haskell exception, or+--  * risk an unchecked runtime exception (e.g. array+--    out of bounds, divide by zero)+-- is /not/ considered OK-for-speculation, as these violate condition A.+--+-- For 'exprOkToDiscard', condition A is weakened to allow expressions+-- that might risk an unchecked runtime exception but must otherwise+-- reach weak-head-normal-form.+-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard')+--+-- But in fact both functions are a bit more conservative than the above,+-- in at least the following ways:+--+--  * W1: We do not take advantage of already-evaluated lifted variables.+--        As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation';+--        if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is+--        'True', while @exprOkForSpeculation y@ is 'False'.+--        See Note [exprOkForSpeculation and evaluated variables] for why.+--  * W2: Read-effects on mutable variables are currently also included.+--        See Note [Classifying primop effects] "GHC.Builtin.PrimOps".+--  * W3: Currently, 'exprOkForSpeculation' always returns 'False' for+--        let-expressions.  Lets can be stacked deeply, so we just give up.+--        In any case, the argument of 'exprOkForSpeculation' is usually in+--        a strict context, so any lets will have been floated away.+--+--+-- As an example of the considerations in this test, consider:+--+-- > let x = case y# +# 1# of { r# -> I# r# }+-- > in E+--+-- being translated to:+--+-- > case y# +# 1# of { r# ->+-- >    let x = I# r#+-- >    in E+-- > }+--+-- We can only do this if the @y# +# 1#@ is ok for speculation: it has no+-- side effects, and can't diverge or raise an exception.+--+--+-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps"+-- and Note [Transformations affected by primop effects].+--+-- 'exprOkForSpeculation' is used to define Core's let-can-float+-- invariant.  (See Note [Core let-can-float invariant] in+-- "GHC.Core".)  It is therefore frequently called on arguments of+-- unlifted type, especially via 'needsCaseBinding'.  But it is+-- sometimes called on expressions of lifted type as well.  For+-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep".+++exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool+exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation+exprOkToDiscard      = expr_ok fun_always_ok primOpOkToDiscard++fun_always_ok :: Id -> Bool+fun_always_ok _ = True++-- | A special version of 'exprOkForSpeculation' used during+-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False+-- for `b`, then `b` is never considered ok-for-spec.+exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool+exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation++expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool+expr_ok _ _ (Lit _)      = True+expr_ok _ _ (Type _)     = True+expr_ok _ _ (Coercion _) = True++expr_ok fun_ok primop_ok (Var v)    = app_ok fun_ok primop_ok v []+expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e+expr_ok fun_ok primop_ok (Lam b e)+                 | isTyVar b = expr_ok fun_ok primop_ok  e+                 | otherwise = True++-- Tick annotations that *tick* cannot be speculated, because these+-- are meant to identify whether or not (and how often) the particular+-- source expression was evaluated at runtime.+expr_ok fun_ok primop_ok (Tick tickish e)+   | tickishCounts tickish = False+   | otherwise             = expr_ok fun_ok primop_ok e++expr_ok _ _ (Let {}) = False+-- See W3 in the Haddock comment for exprOkForSpeculation++expr_ok fun_ok primop_ok (Case scrut bndr _ alts)+  =  -- See Note [exprOkForSpeculation: case expressions]+     expr_ok fun_ok primop_ok scrut+  && isUnliftedType (idType bndr)+      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep+  && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts+  && altsAreExhaustive alts++expr_ok fun_ok primop_ok other_expr+  | (expr, args) <- collectArgs other_expr+  = case stripTicksTopE (not . tickishCounts) expr of+        Var f ->+           app_ok fun_ok primop_ok f args++        -- 'LitRubbish' is the only literal that can occur in the head of an+        -- application and will not be matched by the above case (Var /= Lit).+        -- See Note [How a rubbish literal can be the head of an application]+        -- in GHC.Types.Literal+        Lit lit | debugIsOn, not (isLitRubbish lit)+                 -> pprPanic "Non-rubbish lit in app head" (ppr lit)+                 | otherwise+                 -> True++        _ -> False++-----------------------------+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]++  | idArity fun > n_val_args+  -- Partial application: just check passing the arguments is OK+  = args_ok++  | otherwise+  = case idDetails fun of+      DFunId unary_class -> not unary_class+         -- DFuns terminate, unless the dict is implemented+         -- by a no-op in which case they may not+         -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon++      DataConWorkId dc+        | isLazyDataConRep dc+        -> args_ok+        | otherwise+        -> fields_ok (dataConRepStrictness dc)++      ClassOpId _ is_terminating_result+        | is_terminating_result -- See Note [exprOkForSpeculation and type classes]+        -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $+           True+           -- assert: terminating result type => can't be applied;+           -- c.f the _other case below++      PrimOpId op _+        | primOpIsDiv op+        , 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) (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+              -- if the divisor is definitely non-zero.+              -- Often there is a literal divisor, and this+              -- can get rid of a thunk in an inner loop++        | otherwise -> primop_ok op && args_ok++      _other  -- Unlifted and terminating types;+              -- Also c.f. the Var case of exprIsHNF+         |  isTerminatingType fun_ty  -- See Note [exprOkForSpeculation and type classes]+         || definitelyUnliftedType fun_ty+         -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)+            True  -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)+                  -- are non-functions and so will have no value args.  The assert is+                  -- just to check this.+                  -- (If we added unlifted function types this would change,+                  -- and we'd need to actually test n_val_args == 0.)++         -- Functions that terminate fast without raising exceptions etc+         -- See (U12) of Note [Implementing unsafeCoerce]+         | fun `hasKey` unsafeEqualityProofIdKey -> True++         | otherwise -> False+             -- NB: even in the nullary case, do /not/ check+             --     for evaluated-ness of the fun;+             --     see Note [exprOkForSpeculation and evaluated variables]+  where+    fun_ty       = idType fun+    n_val_args   = valArgCount args+    (arg_tys, _) = splitPiTys fun_ty++    -- Even if a function call itself is OK, any unlifted+    -- args are still evaluated eagerly and must be checked+    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+       | definitelyLiftedType (scaledThing ty)+       = True -- lifted args are not evaluated eagerly+       | 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+-- False <=> they may or may not be+altsAreExhaustive []+  = True    -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core+altsAreExhaustive (Alt con1 _ _ : alts)+  = case con1 of+      DEFAULT   -> True+      LitAlt {} -> False+      DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1)+      -- It is possible to have an exhaustive case that does not+      -- enumerate all constructors, notably in a GADT match, but+      -- we behave conservatively here -- I don't think it's important+      -- enough to deserve special treatment++-- | Should we look past this tick when eta-expanding the given function?+--+-- See Note [Ticks and mandatory eta expansion]+-- Takes the function we are applying as argument.+etaExpansionTick :: Id -> GenTickish pass -> Bool+etaExpansionTick id t+  = hasNoBinding id &&+    ( tickishFloatable t || isProfTick t )++{- Note [exprOkForSpeculation and type classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#22745, #15205)++  \(d :: C a b). case eq_sel (sc_sel d) of+                   (co :: t1 ~# t2) [Dead] ->  blah++We know that+* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates+  (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core)+* eq_sel is simply a superclass selector, and hence is fast+* The field that eq_sel picks is of unlifted type, and hence can't be bottom+  (remember the dictionary argument itself is non-bottom)++So we can treat (eq_sel (sc_sel d)) as ok-for-speculation.  We must check++a) That the function is a class-op, with IdDetails of ClassOpId++b) That the result type of the class-op is terminating or unlifted.  E.g. for+     class C a => D a where ...+     class C a where { op :: a -> a }+   Since C is represented by a newtype, (sc_sel (d :: D a)) might+   not be terminating.++Rather than repeatedly test if the result of the class-op is a+terminating/unlifted type, we cache it as a field of ClassOpId. See+GHC.Types.Id.Make.mkDictSelId for where this field is initialised.++Note [exprOkForSpeculation: case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+exprOkForSpeculation accepts very special case expressions.+Reason: (a ==# b) is ok-for-speculation, but the litEq rules+in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to+   case a of { DEFAULT -> 0#; 3# -> 1# }+for excellent reasons described in+  GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case].+So, annoyingly, we want that case expression to be+ok-for-speculation too. Bother.++But we restrict it sharply:++* We restrict it to unlifted scrutinees. Consider this:+     case x of y {+       DEFAULT -> ... (let v::Int# = case y of { True  -> e1+                                               ; False -> e2 }+                       in ...) ...++  Does the RHS of v satisfy the let-can-float invariant?  Previously we said+  yes, on the grounds that y is evaluated.  But the binder-swap done+  by GHC.Core.Opt.SetLevels would transform the inner alternative to+     DEFAULT -> ... (let v::Int# = case x of { ... }+                     in ...) ....+  which does /not/ satisfy the let-can-float invariant, because x is+  not evaluated. See Note [Binder-swap during float-out]+  in GHC.Core.Opt.SetLevels.  To avoid this awkwardness it seems simpler+  to stick to unlifted scrutinees where the issue does not+  arise.++* We restrict it to exhaustive alternatives. A non-exhaustive+  case manifestly isn't ok-for-speculation. for example,+  this is a valid program (albeit a slightly dodgy one)+    let v = case x of { B -> ...; C -> ... }+    in case x of+         A -> ...+         _ ->  ...v...v....+  Should v be considered ok-for-speculation?  Its scrutinee may be+  evaluated, but the alternatives are incomplete so we should not+  evaluate it strictly.++  Now, all this is for lifted types, but it'd be the same for any+  finite unlifted type. We don't have many of them, but we might+  add unlifted algebraic types in due course.+++----- Historical note: #15696: --------+  Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide+  floating of single-alternative cases; it now uses exprIsHNF+  Note [Floating single-alternative cases].++  But in those days, consider+    case e of x { DEAFULT ->+      ...(case x of y+            A -> ...+            _ -> ...(case (case x of { B -> p; C -> p }) of+                       I# r -> blah)...+  If GHC.Core.Opt.SetLevels considers the inner nested case as+  ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels).+  So we'd float to:+    case e of x { DEAFULT ->+    case (case x of { B -> p; C -> p }) of I# r ->+    ...(case x of y+            A -> ...+            _ -> ...blah...)...+  which is utterly bogus (seg fault); see #5453.++----- Historical note: #3717: --------+    foo :: Int -> Int+    foo 0 = 0+    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)++In earlier GHCs, we got this:+    T.$wfoo =+      \ (ww :: GHC.Prim.Int#) ->+        case ww of ds {+          __DEFAULT -> case (case <# ds 5 of _ {+                          GHC.Types.False -> lvl1;+                          GHC.Types.True -> lvl})+                       of _ { __DEFAULT ->+                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };+          0 -> 0 }++Before join-points etc we could only get rid of two cases (which are+redundant) by recognising that the (case <# ds 5 of { ... }) is+ok-for-speculation, even though it has /lifted/ type.  But now join+points do the job nicely.+------- End of historical note ------------+++Note [exprOkForSpeculation and evaluated variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples:+ * case x of y { DEFAULT -> ....y.... }+   Should 'y' (alone) be considered ok-for-speculation?++ * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... }+   Should (dataToTagLarge# y) be considered ok-for-spec? Recall that+     dataToTagLarge# :: forall a. a -> Int#+   must always evaluate its argument. (See also Note [DataToTag overview].)++You could argue 'yes', because in the case alternative we know that+'y' is evaluated.  But the binder-swap transformation, which is+extremely useful for float-out, changes these expressions to+   case x of y { DEFAULT -> ....x.... }+   case x of y { DEFAULT -> ....let z = dataToTagLarge# x... }++And now the expression does not obey the let-can-float invariant!  Yikes!+Moreover we really might float (dataToTagLarge# x) outside the case,+and then it really, really doesn't obey the let-can-float invariant.++The solution is simple: exprOkForSpeculation does not try to take+advantage of the evaluated-ness of (lifted) variables.  And it returns+False (always) for primops that perform evaluation.  We achieve the latter+by marking the relevant primops as "ThrowsException" or+"ReadWriteEffect"; see also Note [Classifying primop effects] in+GHC.Builtin.PrimOps.++Note that exprIsHNF /can/ and does take advantage of evaluated-ness;+it doesn't have the trickiness of the let-can-float invariant to worry about.++************************************************************************+*                                                                      *+             exprIsHNF, exprIsConLike+*                                                                      *+************************************************************************+-}++-- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]+-- ~~~~~~~~~~~~~~~~+-- | exprIsHNF returns true for expressions that are certainly /already/+-- evaluated to /head/ normal form.  This is used to decide whether it's ok+-- to perform case-to-let for lifted expressions, which changes:+--+-- > case x of x' { _ -> e }+--+--    into:+--+-- > let x' = x in e+--+-- 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:+--+-- > (:) (f x) (map f xs)+-- > map (...redex...)+--+-- because 'seq' on such things completes immediately.+--+-- For unlifted argument types, we have to be careful:+--+-- > C (f x :: Int#)+--+-- Suppose @f x@ diverges; then @C (f x)@ is not a value.+-- We check for this using needsCaseBinding below+exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding++-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as+-- data constructors. Conlike arguments are considered interesting by the+-- inliner.+exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding++-- | Returns true for values or value-like expressions. These are lambdas,+-- constructors / CONLIKE functions (as determined by the function argument)+-- or PAPs.+--+exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool+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 [] -- 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)+        --   Contrast with Note [exprOkForSpeculation and evaluated variables]+        -- We don't look through loop breakers here, which is a bit conservative+        -- but otherwise I worry that if an Id's unfolding is just itself,+        -- we could get an infinite loop++      || definitelyUnliftedType (idType v)+        -- Unlifted binders are always evaluated (#20140)++    is_hnf_like (Lit l)          = not (isLitRubbish l)+        -- Regarding a LitRubbish as ConLike leads to unproductive inlining in+        -- WWRec, see #20035+    is_hnf_like (Type _)         = True       -- Types are honorary Values;+                                              -- we don't mind copying them+    is_hnf_like (Coercion _)     = True       -- Same for coercions+    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e+    is_hnf_like (Tick tickish e) = not (tickishCounts tickish)+                                   && is_hnf_like e+                                      -- 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 [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)+      | Just rhs <- isUnsafeEqualityCase e b as+      = is_hnf_like rhs+    is_hnf_like _                = 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 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]+~~~~~~~~~~~~~~~~~~~~~+We can discard source annotations on HNFs as long as they aren't+tick-like:++  scc c (\x . e)    =>  \x . e+  scc c (C x1..xn)  =>  C x1..xn++So we regard these as HNFs.  Tick annotations that tick are not+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?+exprIsTopLevelBindable :: CoreExpr -> Type -> Bool+-- See Note [Core top-level string literals]+-- Precondition: exprType expr = ty+-- Top-level literal strings can't even be wrapped in ticks+--   see Note [Core top-level string literals] in "GHC.Core"+exprIsTopLevelBindable expr ty+  = not (mightBeUnliftedType ty)+    -- Note that 'expr' may not have a fixed runtime representation here,+    -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType',+    -- as the latter would panic.+  || exprIsTickedString expr++-- | Check if the expression is zero or more Ticks wrapped around a literal+-- string.+exprIsTickedString :: CoreExpr -> Bool+exprIsTickedString = isJust . exprIsTickedString_maybe++-- | Extract a literal string from an expression that is zero or more Ticks+-- wrapped around a literal string. Returns Nothing if the expression has a+-- different shape.+-- Used to "look through" Ticks in places that need to handle literal strings.+exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString+exprIsTickedString_maybe (Lit (LitString bs)) = Just bs+exprIsTickedString_maybe (Tick t e)+  -- we don't tick literals with CostCentre ticks, compare to mkTick+  | tickishPlace t == PlaceCostCentre = Nothing+  | otherwise = exprIsTickedString_maybe e+exprIsTickedString_maybe _ = Nothing++{-+************************************************************************+*                                                                      *+             Instantiating data constructors+*                                                                      *+************************************************************************++These InstPat functions go here to avoid circularity between DataCon and Id+-}++dataConRepInstPat   ::                 [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])+dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])++dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))+dataConRepFSInstPat = dataConInstPat++dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names+               -> [Unique]              -- An equally long list of uniques, at least one for each binder+               -> Mult                  -- The multiplicity annotation of the case expression: scales the multiplicity of variables+               -> DataCon+               -> [Type]                -- Types to instantiate the universally quantified tyvars+               -> ([TyCoVar], [Id])     -- Return instantiated variables+-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple+-- (ex_tvs, arg_ids),+--+--   ex_tvs are intended to be used as binders for existential type args+--+--   arg_ids are intended to be used as binders for value arguments,+--     and their types have been instantiated with inst_tys and ex_tys+--     The arg_ids include both evidence and+--     programmer-specified arguments (both after rep-ing)+--+-- Example.+--  The following constructor T1+--+--  data T a where+--    T1 :: forall b. Int -> b -> T(a,b)+--    ...+--+--  has representation type+--   forall a. forall a1. forall b. (a ~ (a1,b)) =>+--     Int -> b -> T a+--+--  dataConInstPat fss us T1 (a1',b') will return+--+--  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])+--+--  where the double-primed variables are created with the FastStrings and+--  Uniques given as fss and us+dataConInstPat fss uniqs mult con inst_tys+  = assert (univ_tvs `equalLength` inst_tys) $+    (ex_bndrs, arg_ids)+  where+    univ_tvs = dataConUnivTyVars con+    ex_tvs   = dataConExTyCoVars con+    arg_tys  = dataConRepArgTys con+    arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys+    n_ex = length ex_tvs++      -- split the Uniques and FastStrings+    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs+    (ex_fss,   id_fss)   = splitAt n_ex fss++      -- Make the instantiating substitution for universals+    univ_subst = zipTvSubst univ_tvs inst_tys++      -- Make existential type variables, applying and extending the substitution+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst+                                       (zip3 ex_tvs ex_fss ex_uniqs)++    mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar)+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv+                                       new_tv+                                     , new_tv)+      where+        new_tv | isTyVar tv+               = mkTyVar (mkSysTvName uniq fs) kind+               | otherwise+               = mkCoVar (mkSystemVarName uniq fs) kind+        kind   = Type.substTyUnchecked subst (varType tv)++      -- Make value vars, instantiating types+    arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs+    mk_id_var uniq fs (Scaled m ty) str+      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]+        mkUserLocalOrCoVar (mkVarOccFS fs) uniq+                           (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan++{-+Note [Mark evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When pattern matching on a constructor with strict fields, the binder+can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that+when loading an interface file unfolding like:+  data T = MkT !Int+  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1+                             in ... }+we don't want Lint to complain.  The 'y' is evaluated, so the+case in the RHS of the binding for 'v' is fine.  But only if we+*know* that 'y' is evaluated.++c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt++************************************************************************+*                                                                      *+         Equality+*                                                                      *+************************************************************************+-}++-- | A cheap equality test which bales out fast!+--      If it returns @True@ the arguments are definitely equal,+--      otherwise, they may or may not be equal.+cheapEqExpr :: Expr b -> Expr b -> Bool+cheapEqExpr = cheapEqExpr' (const False)++-- | Cheap expression equality test, can ignore ticks by type.+cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool+{-# INLINE cheapEqExpr' #-}+cheapEqExpr' ignoreTick e1 e2+  = go e1 e2+  where+    go (Var v1)   (Var v2)         = v1 == v2+    go (Lit lit1) (Lit lit2)       = lit1 == lit2+    go (Type t1)  (Type t2)        = t1 `eqType` t2+    go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2+    go (App f1 a1) (App f2 a2)     = f1 `go` f2 && a1 `go` a2+    go (Cast e1 t1) (Cast e2 t2)   = e1 `go` e2 && t1 `eqCoercion` t2++    go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2+    go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2+    go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2++    go _ _ = False++++-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots+eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool+eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)+      = lid == rid &&+        map (rnOccL env) lids == map (rnOccR env) rids &&+        lext == rext+eqTickish _ l r = l == r++-- | Finds differences between core bindings, see @diffExpr@.+--+-- The main problem here is that while we expect the binds to have the+-- same order in both lists, this is not guaranteed. To do this+-- properly we'd either have to do some sort of unification or check+-- all possible mappings, which would be seriously expensive. So+-- instead we simply match single bindings as far as we can. This+-- leaves us just with mutually recursive and/or mismatching bindings,+-- which we then speculatively match by ordering them. It's by no means+-- perfect, but gets the job done well enough.+--+-- Only used in GHC.Core.Lint.lintAnnots+diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]+          -> ([SDoc], RnEnv2)+diffBinds top env binds1 = go (length binds1) env binds1+ where go _    env []     []+          = ([], env)+       go _fuel env [] binds2+          -- No binds remaining to compare on the left? Bail out early.+          = (warn env [] binds2, env)+       go _fuel env binds1 []+          -- No binds remaining to compare on the right? Bail out early.+          = (warn env binds1 [], env)+       go fuel env binds1@(bind1:_) binds2@(_:_)+          -- Iterated over all binds without finding a match? Then+          -- try speculatively matching binders by order.+          | fuel == 0+          = if not $ env `inRnEnvL` fst bind1+            then let env' = uncurry (rnBndrs2 env) $ unzip $+                            zip (sort $ map fst binds1) (sort $ map fst binds2)+                 in go (length binds1) env' binds1 binds2+            -- If we have already tried that, give up+            else (warn env binds1 binds2, env)+       go fuel env ((bndr1,expr1):binds1) binds2+          | let matchExpr (bndr,expr) =+                  (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) &&+                  null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)++          , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2+          = go (length binds1) (rnBndr2 env bndr1 bndr2)+                binds1 (binds2l ++ binds2r)+          | otherwise -- No match, so push back (FIXME O(n^2))+          = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2++       -- We have tried everything, but couldn't find a good match. So+       -- now we just return the comparison results when we pair up+       -- the binds in a pseudo-random order.+       warn env binds1 binds2 =+         concatMap (uncurry (diffBind env)) (zip binds1' binds2') +++         unmatched "unmatched left-hand:" (drop l binds1') +++         unmatched "unmatched right-hand:" (drop l binds2')+        where binds1' = sortBy (comparing fst) binds1+              binds2' = sortBy (comparing fst) binds2+              l = min (length binds1') (length binds2')+       unmatched _   [] = []+       unmatched txt bs = [text txt $$ ppr (Rec bs)]+       diffBind env (bndr1,expr1) (bndr2,expr2)+         | ds@(_:_) <- diffExpr top env expr1 expr2+         = locBind "in binding" bndr1 bndr2 ds+         -- Special case for TyVar, which we checked were bound to the same types in+         -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo.+         -- These let-bound types are created temporarily by the simplifier but inlined+         -- immediately.+         | isTyVar bndr1 && isTyVar bndr2+         = []+         | otherwise+         = diffIdInfo env bndr1 bndr2++-- | Finds differences between core expressions, modulo alpha and+-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be+-- checked for differences as well.+diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]+diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []+diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []+diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []+diffExpr _   env (Coercion co1) (Coercion co2)+                                       | eqCoercionX env co1 co2        = []+diffExpr top env (Cast e1 co1)  (Cast e2 co2)+  | eqCoercionX env co1 co2                = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   e2+  | not (tickishIsCode n1)                 = diffExpr top env e1 e2+diffExpr top env e1             (Tick n2 e2)+  | not (tickishIsCode n2)                 = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   (Tick n2 e2)+  | eqTickish env n1 n2                    = diffExpr top env e1 e2+ -- The error message of failed pattern matches will contain+ -- generated names, which are allowed to differ.+diffExpr _   _   (App (App (Var absent) _) _)+                 (App (App (Var absent2) _) _)+  | isDeadEndId absent && isDeadEndId absent2 = []+diffExpr top env (App f1 a1)    (App f2 a2)+  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2+diffExpr top env (Lam b1 e1)  (Lam b2 e2)+  | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination+  = diffExpr top (rnBndr2 env b1 b2) e1 e2+diffExpr top env (Let bs1 e1) (Let bs2 e2)+  = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])+    in ds ++ diffExpr top env' e1 e2+diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+  | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2+    -- See Note [Empty case alternatives] in GHC.Data.TrieMap+  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)+  where env' = rnBndr2 env b1 b2+        diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2)+          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]+          | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2+diffExpr _  _ e1 e2+  = [fsep [ppr e1, text "/=", ppr e2]]++-- | Find differences in @IdInfo@. We will especially check whether+-- the unfoldings match, if present (see @diffUnfold@).+diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]+diffIdInfo env bndr1 bndr2+  | arityInfo info1 == arityInfo info2+    && cafInfo info1 == cafInfo info2+    && oneShotInfo info1 == oneShotInfo info2+    && inlinePragInfo info1 == inlinePragInfo info2+    && occInfo info1 == occInfo info2+    && demandInfo info1 == demandInfo info2+    && callArityInfo info1 == callArityInfo info2+  = locBind "in unfolding of" bndr1 bndr2 $+    diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2)+  | otherwise+  = locBind "in Id info of" bndr1 bndr2+    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]+  where info1 = idInfo bndr1; info2 = idInfo bndr2++-- | Find differences in unfoldings. Note that we will not check for+-- differences of @IdInfo@ in unfoldings, as this is generally+-- redundant, and can lead to an exponential blow-up in complexity.+diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]+diffUnfold _   NoUnfolding    NoUnfolding                 = []+diffUnfold _   BootUnfolding  BootUnfolding               = []+diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []+diffUnfold env (DFunUnfolding bs1 c1 a1)+               (DFunUnfolding bs2 c2 a2)+  | c1 == c2 && equalLength bs1 bs2+  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)+  where env' = rnBndrs2 env bs1 bs2+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)+               (CoreUnfolding t2 _ _ c2 g2)+  | c1 == c2 && g1 == g2+  = diffExpr False env t1 t2+diffUnfold _   uf1 uf2+  = [fsep [ppr uf1, text "/=", ppr uf2]]++-- | Add location information to diff messages+locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]+locBind loc b1 b2 diffs = map addLoc diffs+  where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))+        bindLoc | b1 == b2  = ppr b1+                | otherwise = ppr b1 <> char '/' <> ppr b2+++{- *********************************************************************+*                                                                      *+\subsection{Determining non-updatable right-hand-sides}+*                                                                      *+************************************************************************++Top-level constructor applications can usually be allocated+statically, but they can't if the constructor, or any of the+arguments, come from another DLL (because we can't refer to static+labels in other DLLs).++If this happens we simply make the RHS into an updatable thunk,+and 'execute' it rather than allocating it statically.+-}++{-+************************************************************************+*                                                                      *+\subsection{Type utilities}+*                                                                      *+************************************************************************+-}++-- | True if the type has no non-bottom elements, e.g. when it is an empty+-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.+-- See Note [Bottoming expressions]+--+-- See Note [No alternatives lint check] for another use of this function.+isEmptyTy :: Type -> Bool+isEmptyTy ty+    -- Data types where, given the particular type parameters, no data+    -- constructor matches, are empty.+    -- This includes data types with no constructors, e.g. Data.Void.Void.+    | Just (tc, inst_tys) <- splitTyConApp_maybe ty+    , Just dcs <- tyConDataCons_maybe tc+    , all (dataConCannotMatch inst_tys) dcs+    = True+    | otherwise+    = False++-- | 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++{-+*****************************************************+*+* InScopeSet things+*+*****************************************************+-}+++extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet+extendInScopeSetBind (InScope in_scope) binds+   = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds++extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet+extendInScopeSetBndrs (InScope in_scope) binds+   = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds++mkInScopeSetBndrs :: [CoreBind] -> InScopeSet+mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds++{-+*****************************************************+*+* StaticPtr+*+*****************************************************+-}++-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields+-- @Just (makeStatic, t, srcLoc, e)@.+--+-- Returns @Nothing@ for every other expression.+collectMakeStaticArgs+  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)+collectMakeStaticArgs e+    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e+    , idName b == makeStaticName = Just (fun, t, loc, arg)+collectMakeStaticArgs _          = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Does this binding bind a join point (or a recursive group of join points)?+isJoinBind :: CoreBind -> Bool+isJoinBind (NonRec b _)       = isJoinId b+isJoinBind (Rec ((b, _) : _)) = isJoinId b+isJoinBind _                  = False++dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc+dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)+  where+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)+  getIds (NonRec i _) = [ i ]+  getIds (Rec bs)     = map fst bs+  -- By default only include full info for exported ids, unless we run in the verbose+  -- pprDebug mode.+  printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))+             | otherwise       = empty++{-+************************************************************************+*                                                                      *+\subsection{Tag inference things}+*                                                                      *+************************************************************************+-}++{- Note [Call-by-value for worker args]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we unbox a constructor with strict fields we want to+preserve the information that some of the arguments came+out of strict fields and therefore should be already properly+tagged, however we can't express this directly in core.++Instead what we do is generate a worker like this:++  data T = MkT A !B++  foo = case T of MkT a b -> $wfoo a b++  $wfoo a b = case b of b' -> rhs[b/b']++This makes the worker strict in b causing us to use a more efficient+calling convention for `b` where the caller needs to ensure `b` is+properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids].++Usually the argument will be known to be properly tagged at the call site so there is+no additional work for the caller and the worker can be more efficient since it can+assume the presence of a tag.++This is especially true for recursive functions like this:+    -- myPred expect it's argument properly tagged+    myPred !x = ...++    loop :: MyPair -> Int+    loop (MyPair !x !y) =+        case x of+            A -> 1+            B -> 2+            _ -> loop (MyPair (myPred x) (myPred y))++Here we would ordinarily not be strict in y after unboxing.+However if we pass it as a regular argument then this means on+every iteration of loop we will incur an extra seq on y before+we can pass it to `myPred` which isn't great! That is in STG after+tag inference we get:++    Rec {+    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]+      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#+    [GblId[StrictWorker([!, ~])],+    Arity=2,+    Str=<1L><ML>,+    Unf=OtherCon []] =+        {} \r [x y]+            case x<TagProper> of x' [Occ=Once1] {+              __DEFAULT ->+                  case y of y' [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred y' of pred_y [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred x' of pred_x [Occ=Once1] {+                  __DEFAULT -> Find.$wloop pred_x pred_y;+                  };+                  };+              Find.A -> 1#;+              Find.B -> 2#;+            };+    end Rec }++Here comes the tricky part: If we make $wloop strict in both x/y and we get:++    Rec {+    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]+      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#+    [GblId[StrictWorker([!, !])],+    Arity=2,+    Str=<1L><!L>,+    Unf=OtherCon []] =+        {} \r [x y]+            case y<TagProper> of y' [Occ=Once1] { __DEFAULT ->+            case x<TagProper> of x' [Occ=Once1] {+              __DEFAULT ->+                  case Find.$wmyPred y' of pred_y [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred x' of pred_x [Occ=Once1] {+                  __DEFAULT -> Find.$wloop pred_x pred_y;+                  };+                  };+              Find.A -> 1#;+              Find.B -> 2#;+            };+    end Rec }++Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv.+This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime.++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 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+it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the+simplifier. See Note [Which Ids should be strictified] for details on this.+-}+mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)+mkStrictFieldSeqs args rhs =+  foldr addEval rhs args+    where+      case_ty = exprType rhs+      addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)+      addEval (arg_id,arg_cbv) (rhs)+        -- Argument representing strict field.+        | isMarkedStrict arg_cbv+        , shouldStrictifyIdForCbv arg_id+        -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings.+        = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs])+        -- Normal argument+        | otherwise = do+          rhs++{- Note [Which Ids should be strictified]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some arguments we would like to convince GHC to pass them call by value.+One way to achieve this is described in see Note [Call-by-value for worker args].++We separate the concerns of "should we pass this argument using cbv" and+"should we do so by making the rhs strict in this argument".+This note deals with the second part.++There are multiple reasons why we might not want to insert a seq in the rhs to+strictify a functions argument:++1) The argument doesn't exist at runtime.++For zero width types (like Types) there is no benefit as we don't operate on them+at runtime at all. This includes things like void#, coercions and state tokens.++2) The argument is a unlifted type.++If the argument is a unlifted type the calling convention already is explicitly+cbv. This means inserting a seq on this argument wouldn't do anything as the seq+would be a no-op *and* it wouldn't affect the calling convention.++3) The argument is absent.++If the argument is absent in the body there is no advantage to it being passed as+cbv to the function. The function won't ever look at it so we don't safe any work.++This mostly happens for join point. For example we might have:++    data T = MkT ![Int] [Char]+    f t = case t of MkT xs{strict} ys-> snd (xs,ys)++and abstract the case alternative to:++    f t = join j1 = \xs ys -> snd (xs,ys)+          in case t of MkT xs{strict} ys-> j1 xs xy++While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to.+In short a absent demand means neither our RHS, nor any function we pass the argument+to will inspect it. So there is no work to be saved by forcing `xs` early.++NB: There is an edge case where if we rebox we *can* end up seqing an absent value.+Note [Absent fillers] has an example of this. However this is so rare it's not worth+caring about here.++4) The argument is already strict.++Consider this code:++    data T = MkT ![Int]+    f t = case t of MkT xs{strict} -> reverse xs++The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`.+If we do a w/w split, and add the extra eval on `xs`, we'll get++    $wf xs =+        case xs of xs1 ->+            let t = MkT xs1 in+            case t of MkT xs2 -> reverse xs2++That's not wrong; but the w/w body will simplify to++    $wf xs = case xs of xs1 -> reverse xs1++and now we'll drop the `case xs` because `xs1` is used strictly in its scope.+Adding that eval was a waste of time.  So don't add it for strictly-demanded Ids.++5) Functions++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.++-}+-- | Do we expect there to be any benefit if we make this var strict+-- in order for it to get treated as as cbv argument?+-- See Note [Which Ids should be strictified]+-- See Note [CBV Function Ids] for more background.+shouldStrictifyIdForCbv :: Var -> Bool+shouldStrictifyIdForCbv = wantCbvForId False++-- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args.+shouldUseCbvForId :: Var -> Bool+shouldUseCbvForId = wantCbvForId True++-- When we strictify we want to skip strict args otherwise the logic is the same+-- as for shouldUseCbvForId so we common up the logic here.+-- Basically returns true if it would be beneficial for runtime to pass this argument+-- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args+-- we are not allowed to force.+wantCbvForId :: Bool -> Var -> Bool+wantCbvForId cbv_for_strict v+  -- Must be a runtime var.+  -- See Note [Which Ids should be strictified] point 1)+  | isId v+  , not $ isZeroBitTy ty+  -- Unlifted things don't need special measures to be treated as cbv+  -- 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 EnforceEpt.+  -- See Note [Which Ids should be strictified] point 5)+  , not $ isFunTy ty+  -- If the var is strict already a seq is redundant.+  -- See Note [Which Ids should be strictified] point 4)+  , not (isStrictDmd dmd) || cbv_for_strict+  -- If the var is absent a seq is almost always useless.+  -- See Note [Which Ids should be strictified] point 3)+  , not (isAbsDmd dmd)+  = True+  | otherwise+  = False+  where+    ty = idType v+    dmd = idDemandInfo v++{- *********************************************************************+*                                                                      *+             unsafeEqualityProof+*                                                                      *+********************************************************************* -}++isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr+-- See (U3) and (U4) in+-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+isUnsafeEqualityCase scrut bndr alts+  | [Alt ac _ rhs] <- alts+  , DataAlt dc <- ac+  , dc `hasKey` unsafeReflDataConKey+  , isDeadBinder bndr+      -- We can only discard the case if the case-binder is dead+      -- It usually is, but see #18227+  , Var v `App` _ `App` _ `App` _ <- scrut+  , v `hasKey` unsafeEqualityProofIdKey+      -- Check that the scrutinee really is unsafeEqualityProof+      -- and not, say, error+  = Just rhs+  | otherwise+  = Nothing
compiler/GHC/CoreToIface.hs view
@@ -43,18 +43,13 @@     , toIfaceVar       -- * Other stuff     , toIfaceLFInfo-      -- * CgBreakInfo-    , dehydrateCgBreakInfo+    , toIfaceBooleanFormula     ) where  import GHC.Prelude -import Data.Word- import GHC.StgToCmm.Types -import GHC.ByteCode.Types- import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom@@ -64,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@@ -84,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*]@@ -123,7 +122,7 @@ toIfaceTvBndr = toIfaceTvBndrX emptyVarSet  toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr-toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)+toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar))                           , toIfaceTypeX fr (tyVarKind tyvar)                           ) @@ -135,7 +134,7 @@  toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)-                          , occNameFS (getOccName covar)+                          , mkIfLclName (occNameFS (getOccName covar))                           , toIfaceTypeX fr (varType covar)                           ) @@ -178,7 +177,7 @@ --    translates the tyvars in 'free' as IfaceFreeTyVars -- -- Synonyms are retained in the interface type-toIfaceTypeX fr (TyVarTy tv)   -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type+toIfaceTypeX fr (TyVarTy tv)   -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type   | tv `elemVarSet` fr         = IfaceFreeTyVar tv   | otherwise                  = IfaceTyVar (toIfaceTyVar tv) toIfaceTypeX fr ty@(AppTy {})  =@@ -220,11 +219,11 @@     arity = tyConArity tc     n_tys = length tys -toIfaceTyVar :: TyVar -> FastString-toIfaceTyVar = occNameFS . getOccName+toIfaceTyVar :: TyVar -> IfLclName+toIfaceTyVar = mkIfLclName . occNameFS . getOccName -toIfaceCoVar :: CoVar -> FastString-toIfaceCoVar = occNameFS . getOccName+toIfaceCoVar :: CoVar -> IfLclName+toIfaceCoVar = mkIfLclName . occNameFS . getOccName  ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon@@ -266,7 +265,7 @@  toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x-toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x+toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x) toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x  ----------------@@ -285,24 +284,23 @@     go (Refl ty)            = IfaceReflCo (toIfaceTypeX fr ty)     go (GRefl r ty mco)     = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)     go (CoVarCo cv)-      -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type-      | cv `elemVarSet` fr  = IfaceFreeCoVar cv-      | otherwise           = IfaceCoVarCo (toIfaceCoVar cv)-    go (HoleCo h)           = IfaceHoleCo  (coHoleCoVar h)+      -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type+      | cv `elemVarSet` fr = IfaceFreeCoVar cv+      | otherwise          = IfaceCoVarCo (toIfaceCoVar cv)+    go (HoleCo h)          = IfaceHoleCo  (coHoleCoVar h) -    go (AppCo co1 co2)      = IfaceAppCo  (go co1) (go co2)-    go (SymCo co)           = IfaceSymCo (go co)-    go (TransCo co1 co2)    = IfaceTransCo (go co1) (go co2)-    go (SelCo d co)         = IfaceSelCo d (go co)-    go (LRCo lr co)         = IfaceLRCo lr (go co)-    go (InstCo co arg)      = IfaceInstCo (go co) (go arg)-    go (KindCo c)           = IfaceKindCo (go c)-    go (SubCo co)           = IfaceSubCo (go co)-    go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (coaxrName co) (map go cs)-    go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)-    go (UnivCo p r t1 t2)   = IfaceUnivCo (go_prov p) r-                                          (toIfaceTypeX fr t1)-                                          (toIfaceTypeX fr t2)+    go (AppCo co1 co2)     = IfaceAppCo  (go co1) (go co2)+    go (SymCo co)          = IfaceSymCo (go co)+    go (TransCo co1 co2)   = IfaceTransCo (go co1) (go co2)+    go (SelCo d co)        = IfaceSelCo d (go co)+    go (LRCo lr co)        = IfaceLRCo lr (go co)+    go (InstCo co arg)     = IfaceInstCo (go co) (go arg)+    go (KindCo c)          = IfaceKindCo (go c)+    go (SubCo co)          = IfaceSubCo (go co)+    go (AxiomCo ax cs)     = IfaceAxiomCo (toIfaceAxiomRule ax) (map go cs)+    go (UnivCo { uco_prov = p, uco_role = r, uco_lty = t1, uco_rty = t2, uco_deps = deps })+        = IfaceUnivCo p r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) (map go deps)+     go co@(TyConAppCo r tc cos)       =  assertPpr (isNothing (tyConAppFunCo_maybe r tc cos)) (ppr co) $          IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)@@ -310,17 +308,20 @@     go (FunCo { fco_role = r, fco_mult = w, fco_arg = co1, fco_res = co2 })       = IfaceFunCo r (go w) (go co1) (go co2) -    go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)-                                          (toIfaceCoercionX fr' k)-                                          (toIfaceCoercionX fr' co)+    go (ForAllCo tv visL visR k co)+      = IfaceForAllCo (toIfaceBndr tv)+                      visL+                      visR+                      (toIfaceCoercionX fr' k)+                      (toIfaceCoercionX fr' co)                           where                             fr' = fr `delVarSet` tv -    go_prov :: UnivCoProvenance -> IfaceUnivCoProv-    go_prov (PhantomProv co)    = IfacePhantomProv (go co)-    go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)-    go_prov (PluginProv str)    = IfacePluginProv str-    go_prov (CorePrepProv b)    = IfaceCorePrepProv b+toIfaceAxiomRule :: CoAxiomRule -> IfaceAxiomRule+toIfaceAxiomRule (BuiltInFamRew  bif) = IfaceAR_X (mkIfLclName (bifrw_name bif))+toIfaceAxiomRule (BuiltInFamInj bif)  = IfaceAR_X (mkIfLclName (bifinj_name bif))+toIfaceAxiomRule (BranchedAxiom ax i) = IfaceAR_B (coAxiomName ax) i+toIfaceAxiomRule (UnbranchedAxiom ax) = IfaceAR_U (coAxiomName ax)  toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet@@ -359,12 +360,8 @@         ts' = go (extendTCvSubst env tv t) res ts      go env (FunTy { ft_af = af, ft_res = res }) (t:ts)-      = IA_Arg (toIfaceTypeX fr t) argf (go env res ts)-      where-        argf | isVisibleFunArg af = Required-             | otherwise          = Inferred-             -- It's rare for a kind to have a constraint argument, but it-             -- can happen. See Note [AnonTCB with constraint arg] in GHC.Core.TyCon.+      = assert (isVisibleFunArg af)+        IA_Arg (toIfaceTypeX fr t) Required (go env res ts)      go env ty ts@(t1:ts1)       | not (isEmptyTCvSubst env)@@ -437,10 +434,10 @@ toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang  toIfaceLetBndr :: Id -> IfaceLetBndr-toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))+toIfaceLetBndr id  = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))                                (toIfaceType (idType id))                                (toIfaceIdInfo (idInfo id))-                               (toIfaceJoinInfo (isJoinId_maybe id))+                               (idJoinPointHood id)   -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr   -- has left on the Id.  See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax @@ -448,21 +445,22 @@ toIfaceTopBndr id   = if isExternalName name       then IfGblTopBndr name-      else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id))+      else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id))                         (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id))   where     name = getName id  toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId                      = IfVanillaId-toIfaceIdDetails (WorkerLikeId dmds)          = IfWorkerLikeId dmds+toIfaceIdDetails (WorkerLikeId dmds)            = IfWorkerLikeId dmds toIfaceIdDetails (DFunId {})                    = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n-                           , sel_tycon = tc })  =-  let iface = case tc of-                RecSelData ty_con -> Left (toIfaceTyCon ty_con)-                RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)-  in IfRecSelId iface n+                           , sel_tycon = tc+                           , sel_fieldLabel = fl }) =+  let (iface, first_con) = case tc of+                RecSelData ty_con    -> ( Left (toIfaceTyCon ty_con), dataConName $ head $ tyConDataCons ty_con)+                RecSelPatSyn pat_syn -> ( Right (patSynToIfaceDecl pat_syn), patSynName pat_syn)+  in IfRecSelId iface first_con n fl    -- The remaining cases are all "implicit Ids" which don't   -- appear in interface files at all@@ -506,10 +504,6 @@     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing                   | otherwise = Just (HsInline inline_prag) -toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo-toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar-toIfaceJoinInfo Nothing   = IfaceNotJoinPoint- -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs@@ -544,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+ {- ************************************************************************ *                                                                      *@@ -562,12 +564,10 @@ toIfaceExpr (App f a)       = toIfaceApp f [a] toIfaceExpr (Case s x ty as)   | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)-  | otherwise               = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)+  | otherwise               = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as) toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e) toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)-toIfaceExpr (Tick t e)-  | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)-  | otherwise                   = toIfaceExpr e+toIfaceExpr (Tick t e)      = IfaceTick (toIfaceTickish t) (toIfaceExpr e)  toIfaceOneShot :: Id -> IfaceOneShot toIfaceOneShot id | isId id@@ -577,13 +577,13 @@                   = IfaceNoOneShot  ----------------------toIfaceTickish :: CoreTickish -> Maybe IfaceTickish-toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)-toIfaceTickish (HpcTick modl ix)       = Just (IfaceHpcTick modl ix)-toIfaceTickish (SourceNote src names)  = Just (IfaceSource src names)-toIfaceTickish (Breakpoint {})         = Nothing-   -- Ignore breakpoints, since they are relevant only to GHCi, and-   -- should not be serialised (#8333)+toIfaceTickish :: CoreTickish -> IfaceTickish+toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push+toIfaceTickish (HpcTick modl ix)       = IfaceHpcTick modl ix+toIfaceTickish (SourceNote src (LexicalFastString names)) =+  IfaceSource src names+toIfaceTickish (Breakpoint _ ix fv) =+  IfaceBreakpoint ix (toIfaceVar <$> fv)  --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr@@ -608,7 +608,7 @@           in (top_bndr, rhs')          -- The sharing behaviour is currently disabled due to #22807, and relies on-        -- finished #220056 to be re-enabled.+        -- finished #20056 to be re-enabled.         disabledDueTo22807 = True          already_has_unfolding b = not disabledDueTo22807@@ -619,7 +619,7 @@  --------------------- toIfaceAlt :: CoreAlt -> IfaceAlt-toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r)+toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r)  --------------------- toIfaceCon :: AltCon -> IfaceConAlt@@ -627,7 +627,7 @@ toIfaceCon (LitAlt l)   = assertPpr (not (isLitRubbish l)) (ppr l) $                           -- assert: see Note [Rubbish literals] wrinkle (b)                           IfaceLitAlt l-toIfaceCon DEFAULT      = IfaceDefault+toIfaceCon DEFAULT      = IfaceDefaultAlt  --------------------- toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr@@ -664,7 +664,7 @@                                       -- Foreign calls have special syntax      | isExternalName name             = IfaceExt name-    | otherwise                       = IfaceLcl (getOccFS name)+    | otherwise                       = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name))   where     name = idName v     ty   = idType v@@ -698,16 +698,7 @@     LFLetNoEscape ->       panic "toIfaceLFInfo: LFLetNoEscape" --- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> 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):@@ -780,8 +771,8 @@ Note [Interface File with Core: Sharing RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IMPORTANT: This optimisation is currently disabled due to #22027, it can be-           re-enabled once #220056 is implemented.+IMPORTANT: This optimisation is currently disabled due to #22807, it can be+           re-enabled once #22056 is implemented.  In order to avoid duplicating definitions for bindings which already have unfoldings we do some minor headstands to avoid serialising the RHS of a definition if it has@@ -794,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
@@ -7,19 +7,20 @@ -}  {-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-}  module GHC.Data.Bag (         Bag, -- abstract type          emptyBag, unitBag, unionBags, unionManyBags,-        mapBag,+        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, unzipBag,-        mapBagM, mapBagM_,+        concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag,+        mapBagM, mapBagM_, lookupBag,         flatMapBagM, flatMapBagPairM,         mapAndUnzipBagM, mapAccumBagLM,         anyBagM, filterBagM@@ -38,6 +39,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) )+import Control.Applicative( Alternative( (<|>) ) ) import Control.DeepSeq  infixr 3 `consBag`@@ -121,7 +123,19 @@ filterBagM pred (ListBag vs) = do   sat <- filterM pred (toList vs)   return (listToBag sat)+{-# INLINEABLE filterBagM #-} +lookupBag :: Eq a => a -> Bag (a,b) -> Maybe b+lookupBag _ EmptyBag        = Nothing+lookupBag k (UnitBag kv)    = lookup_one k kv+lookupBag k (TwoBags b1 b2) = lookupBag k b1 <|> lookupBag k b2+lookupBag k (ListBag xs)    = foldr ((<|>) . lookup_one k) Nothing xs+{-# INLINEABLE lookupBag #-}++lookup_one :: Eq a => a -> (a,b) -> Maybe b+lookup_one k (k',v) | k==k'     = Just v+                    | otherwise = Nothing+ allBag :: (a -> Bool) -> Bag a -> Bool allBag _ EmptyBag        = True allBag p (UnitBag v)     = p v@@ -141,6 +155,7 @@                                if flag then return True                                        else anyBagM p b2 anyBagM p (ListBag xs)    = anyM p xs+{-# INLINEABLE anyBagM #-}  concatBag :: Bag (Bag a) -> Bag a concatBag = foldr unionBags emptyBag@@ -179,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@@ -228,6 +229,17 @@ mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) mapMaybeBag f (ListBag xs)    = listToBag $ mapMaybe f (toList xs) +mapMaybeBagM :: Monad m => (a -> m (Maybe b)) -> Bag a -> m (Bag b)+mapMaybeBagM _ EmptyBag        = return EmptyBag+mapMaybeBagM f (UnitBag x)     = do r <- f x+                                    return $ case r of+                                      Nothing -> EmptyBag+                                      Just y  -> UnitBag y+mapMaybeBagM f (TwoBags b1 b2) = do r1 <- mapMaybeBagM f b1+                                    r2 <- mapMaybeBagM f b2+                                    return $ unionBags r1 r2+mapMaybeBagM f (ListBag xs)    = listToBag <$> mapMaybeM f (toList xs)+ mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) mapBagM _ EmptyBag        = return EmptyBag mapBagM f (UnitBag x)     = do r <- f x@@ -237,12 +249,14 @@                                return (TwoBags r1 r2) mapBagM f (ListBag    xs) = do rs <- mapM f xs                                return (ListBag rs)+{-# INLINEABLE mapBagM #-}  mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () mapBagM_ _ EmptyBag        = return () mapBagM_ f (UnitBag x)     = f x >> return () mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 mapBagM_ f (ListBag    xs) = mapM_ f xs+{-# INLINEABLE mapBagM_ #-}  flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) flatMapBagM _ EmptyBag        = return EmptyBag@@ -253,6 +267,7 @@ flatMapBagM f (ListBag    xs) = foldrM k EmptyBag xs   where     k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) }+{-# INLINEABLE flatMapBagM #-}  flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) flatMapBagPairM _ EmptyBag        = return (EmptyBag, EmptyBag)@@ -264,6 +279,7 @@   where     k x (r2,s2) = do { (r1,s1) <- f x                      ; return (r1 `unionBags` r2, s1 `unionBags` s2) }+{-# INLINEABLE flatMapBagPairM #-}  mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) mapAndUnzipBagM _ EmptyBag        = return (EmptyBag, EmptyBag)@@ -275,6 +291,7 @@ mapAndUnzipBagM f (ListBag xs)    = do ts <- mapM f xs                                        let (rs,ss) = NE.unzip ts                                        return (ListBag rs, ListBag ss)+{-# INLINEABLE mapAndUnzipBagM #-}  mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function             -> acc                    -- ^ initial state@@ -300,6 +317,7 @@                                        ; return (s2, TwoBags b1' b2') } mapAccumBagLM f s (ListBag xs)    = do { (s', xs') <- mapAccumLM f s xs                                        ; return (s', ListBag xs') }+{-# INLINEABLE mapAccumBagLM #-}  listToBag :: [a] -> Bag a listToBag [] = EmptyBag@@ -331,7 +349,10 @@ headMaybe (ListBag (v:|_)) = Just v  instance (Outputable a) => Outputable (Bag a) where-    ppr bag = braces (pprWithCommas ppr (bagToList bag))+    ppr = pprBag++pprBag :: Outputable a => Bag a -> SDoc+pprBag bag = braces (pprWithCommas ppr (bagToList bag))  instance Data a => Data (Bag a) where   gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
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,76 +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.Utils.Binary-import GHC.Parser.Annotation ( LocatedL, noLocA )-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] ~~~~~~~~~~~~~~~~~~~~~~@@ -116,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@@ -132,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'@@ -156,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  ----------------------------------------------------------------------@@ -200,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@@ -231,34 +227,14 @@   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)     go (Parens x) = parens (go $ unLoc x)---------------------------------------------------------------------------- Binary-------------------------------------------------------------------------instance Binary a => Binary (BooleanFormula a) where-  put_ bh (Var x)    = putByte bh 0 >> put_ bh x-  put_ bh (And xs)   = putByte bh 1 >> put_ bh (unLoc <$> xs)-  put_ bh (Or  xs)   = putByte bh 2 >> put_ bh (unLoc <$> xs)-  put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x)--  get bh = do-    h <- getByte bh-    case h of-      0 -> Var                  <$> get bh-      1 -> And    . fmap noLocA <$> get bh-      2 -> Or     . fmap noLocA <$> get bh-      _ -> Parens . noLocA      <$> get bh
compiler/GHC/Data/EnumSet.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet
compiler/GHC/Data/FastMutInt.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected
compiler/GHC/Data/FastString.hs view
@@ -1,15 +1,20 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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:@@ -52,6 +57,9 @@         fastStringToShortByteString,         mkFastStringShortByteString, +        -- * ShortText+        fastStringToShortText,+         -- * FastZString         FastZString,         hPutFZS,@@ -127,9 +135,7 @@ 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 import Data.Data@@ -138,13 +144,8 @@  import Foreign -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import GHC.Conc.Sync    (sharedCAF)-#endif -#if __GLASGOW_HASKELL__ < 811-import GHC.Base (unpackCString#,unpackNBytes#)-#endif import GHC.Exts import GHC.IO @@ -159,6 +160,9 @@ fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs +fastStringToShortText :: FastString -> ShortText+fastStringToShortText = ShortText . fs_sbs+ fastZStringToByteString :: FastZString -> ByteString fastZStringToByteString (FastZString bs) = bs @@ -197,8 +201,8 @@  -- ----------------------------------------------------------------------------- -{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All-'FastString's are stored in a global hashtable to support fast O(1)+{-| A 'FastString' is a Modified UTF-8 encoded string together with a unique ID.+All 'FastString's are stored in a global hashtable to support fast O(1) comparison.  It is also associated with a lazy reference to the Z-encoding@@ -282,13 +286,16 @@ -- `lexicalCompareFS` (i.e. which compares FastStrings on their String -- representation). Hence it is deterministic from one run to the other. newtype LexicalFastString-   = LexicalFastString FastString+   = LexicalFastString { getLexicalFastString :: FastString }    deriving newtype (Eq, Show)    deriving stock Data  instance Ord LexicalFastString where    compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2 +instance NFData LexicalFastString where+  rnf (LexicalFastString f) = rnf f+ -- ----------------------------------------------------------------------------- -- Construction @@ -303,9 +310,18 @@ See Note [Updating the FastString table] on how it's updated. -} data FastStringTable = FastStringTable-  {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets-  {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets-  (Array# (IORef FastStringTableSegment)) -- concurrent segments+  {-# UNPACK #-} !FastMutInt+  -- ^ The unique ID counter shared with all buckets+  --+  -- We unpack the 'FastMutInt' counter as it is always consumed strictly.+  {-# NOUNPACK #-} !FastMutInt+  -- ^ Number of computed z-encodings for all buckets.+  --+  -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk+  -- in 'mkFastStringWith' and needs to be boxed any way.+  -- If this is unpacked, then we box this single 'FastMutInt' once for each+  -- allocated FastString.+  (Array# (IORef FastStringTableSegment)) -- ^  concurrent segments  data FastStringTableSegment = FastStringTableSegment   {-# UNPACK #-} !(MVar ())  -- the lock for write in each segment@@ -387,17 +403,13 @@    -- 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 previouss RTS before might not have this symbol.  The+-- from the 9.3 RTS; the previous RTS before might not have this symbol.  The -- right way to do this however would be to define some HAVE_FAST_STRING_TABLE -- or similar rather than use (odd parity) development versions. foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"   getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)-#endif  {- @@ -412,7 +424,8 @@ be looked up /by the plugin/.     let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT"-   putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts+   putMsgS $ showSDoc dflags $ ppr $+     lookupGRE (mg_rdr_env guts) (LookupRdrName rdrName AllRelevantGREs)  `mkTcOcc` involves the lookup (or creation) of a FastString.  Since the plugin's FastString.string_table is empty, constructing the RdrName also@@ -501,6 +514,10 @@         go (fs@(FastString {fs_sbs=fs_sbs}) : ls)           | fs_sbs == sbs = Just fs           | otherwise     = go ls+-- bucket_match used to inline before changes to instance Eq ShortByteString+-- in bytestring-0.12, which made it slightly larger than inlining threshold.+-- Non-inlining causes a small, but measurable performance regression, so let's force it.+{-# INLINE bucket_match #-}  mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len =@@ -575,11 +592,7 @@           -- DO NOT move this let binding! indexCharOffAddr# reads from the           -- pointer so we need to evaluate this based on the length check           -- above. Not doing this right caused #17909.-#if __GLASGOW_HASKELL__ >= 901           !c = int8ToInt# (indexInt8Array# ba# n)-#else-          !c = indexInt8Array# ba# n-#endif           !h2 = (h *# 16777619#) `xorI#` c         in           loop h2 (n +# 1#)@@ -690,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
@@ -18,7 +18,8 @@         filterFsEnv,         plusFsEnv, plusFsEnv_C, alterFsEnv,         lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv,-        elemFsEnv, mapFsEnv,+        elemFsEnv, mapFsEnv, strictMapFsEnv, mapMaybeFsEnv,+        nonDetFoldFsEnv,          -- * Deterministic FastString environments (maps)         DFastStringEnv,@@ -60,6 +61,7 @@ lookupFsEnv_NF     :: FastStringEnv a -> FastString -> a filterFsEnv        :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt mapFsEnv           :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2+mapMaybeFsEnv      :: (elt1 -> Maybe elt2) -> FastStringEnv elt1 -> FastStringEnv elt2  emptyFsEnv                = emptyUFM unitFsEnv x y             = unitUFM x y@@ -78,8 +80,19 @@ delFromFsEnv x y          = delFromUFM x y delListFromFsEnv x y      = delListFromUFM x y 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++-- | Fold over a 'FastStringEnv'.+--+-- Non-deterministic, unless the folding function is commutative+-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@).+nonDetFoldFsEnv :: (a -> b -> b) -> b -> FastStringEnv a -> b+nonDetFoldFsEnv = nonDetFoldUFM  -- Deterministic FastStringEnv -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need
+ compiler/GHC/Data/FlatBag.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE UnboxedTuples #-}+module GHC.Data.FlatBag+  ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag)+  , emptyFlatBag+  , unitFlatBag+  , sizeFlatBag+  , elemsFlatBag+  , mappendFlatBag+  -- * Construction+  , fromList+  , fromSmallArray+  ) where++import GHC.Prelude++import Control.DeepSeq++import GHC.Data.SmallArray++-- | Store elements in a flattened representation.+--+-- A 'FlatBag' is a data structure that stores an ordered list of elements+-- in a flat structure, avoiding the overhead of a linked list.+-- Use this data structure, if the code requires the following properties:+--+-- * Elements are stored in a long-lived object, and benefit from a flattened+--   representation.+-- * The 'FlatBag' will be traversed but not extended or filtered.+-- * The number of elements should be known.+-- * Sharing of the empty case improves memory behaviour.+--+-- A 'FlagBag' aims to have as little overhead as possible to store its elements.+-- To achieve that, it distinguishes between the empty case, singleton, tuple+-- and general case.+-- Thus, we only pay for the additional three words of an 'Array' if we have at least+-- three elements.+data FlatBag a+  = EmptyFlatBag+  | UnitFlatBag !a+  | TupleFlatBag !a !a+  | FlatBag {-# UNPACK #-} !(SmallArray a)++instance Functor FlatBag where+  fmap _ EmptyFlatBag = EmptyFlatBag+  fmap f (UnitFlatBag a) = UnitFlatBag $ f a+  fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b)+  fmap f (FlatBag e) = FlatBag $ mapSmallArray f e++instance Foldable FlatBag where+  foldMap _ EmptyFlatBag = mempty+  foldMap f (UnitFlatBag a) = f a+  foldMap f (TupleFlatBag a b) = f a `mappend` f b+  foldMap f (FlatBag arr) = foldMapSmallArray f arr++  length = fromIntegral . sizeFlatBag++instance Traversable FlatBag where+  traverse _ EmptyFlatBag = pure EmptyFlatBag+  traverse f (UnitFlatBag a) = UnitFlatBag <$> f a+  traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b+  traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl)++instance NFData a => NFData (FlatBag a) where+  rnf EmptyFlatBag = ()+  rnf (UnitFlatBag a) = rnf a+  rnf (TupleFlatBag a b) = rnf a `seq` rnf b+  rnf (FlatBag arr) = rnfSmallArray arr++-- | Create an empty 'FlatBag'.+--+-- The empty 'FlatBag' is shared over all instances.+emptyFlatBag :: FlatBag a+emptyFlatBag = EmptyFlatBag++-- | Create a singleton 'FlatBag'.+unitFlatBag :: a -> FlatBag a+unitFlatBag = UnitFlatBag++-- | Calculate the size of+sizeFlatBag :: FlatBag a -> Word+sizeFlatBag EmptyFlatBag = 0+sizeFlatBag UnitFlatBag{} = 1+sizeFlatBag TupleFlatBag{} = 2+sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr++-- | Get all elements that are stored in the 'FlatBag'.+elemsFlatBag :: FlatBag a -> [a]+elemsFlatBag EmptyFlatBag = []+elemsFlatBag (UnitFlatBag a) = [a]+elemsFlatBag (TupleFlatBag a b) = [a, b]+elemsFlatBag (FlatBag arr) =+  [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]]++-- | Combine two 'FlatBag's.+--+-- The new 'FlatBag' contains all elements from both 'FlatBag's.+--+-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused.+mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a+mappendFlatBag EmptyFlatBag b = b+mappendFlatBag a EmptyFlatBag = a+mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b+mappendFlatBag a b =+  fromList (sizeFlatBag a + sizeFlatBag b)+           (elemsFlatBag a ++ elemsFlatBag b)++-- | Store the list in a flattened memory representation, avoiding the memory overhead+-- of a linked list.+--+-- The size 'n' needs to be smaller or equal to the length of the list.+-- If it is smaller than the length of the list, overflowing elements are+-- discarded. It is undefined behaviour to set 'n' to be bigger than the+-- length of the list.+fromList :: Word -> [a] -> FlatBag a+fromList n elts =+  case elts of+    [] -> EmptyFlatBag+    [a] -> UnitFlatBag a+    [a, b] -> TupleFlatBag a b+    xs ->+      FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs))++-- | Convert a 'SizedSeq' into its flattened representation.+-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification+-- is necessary.+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
@@ -4,16 +4,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}  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,@@ -42,7 +44,6 @@ -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ - import GHC.Prelude  import GHC.Utils.Misc ( sortWith, count )@@ -59,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+ {- ************************************************************************ *                                                                      *@@ -85,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@@ -108,7 +101,7 @@       node_payload :: payload, -- ^ User data       node_key :: key, -- ^ User defined node id       node_dependencies :: [key] -- ^ Dependencies/successors of the node-  }+  } deriving Functor   instance (Outputable a, Outputable b) => Outputable (Node a b) where@@ -356,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)@@ -409,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@@ -618,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,19 +22,19 @@         IOEnvFailure(..),          -- Getting at the environment-        getEnv, setEnv, updEnv,+        getEnv, setEnv, updEnv, updEnvIO,          runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,         tryM, tryAllM, tryMostM, fixM,          -- I/O operations-        IORef, newMutVar, readMutVar, writeMutVar, updMutVar, updMutVarM,+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,         atomicUpdMutVar, atomicUpdMutVar'   ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Hooks import GHC.IO (catchException) import GHC.Utils.Exception@@ -227,12 +227,6 @@ updMutVar :: IORef a -> (a -> a) -> IOEnv env () updMutVar var upd = liftIO (modifyIORef var upd) -updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env ()-updMutVarM ref upd-  = do { contents     <- liftIO $ readIORef ref-       ; new_contents <- upd contents-       ; liftIO $ writeIORef ref new_contents }- -- | Atomically update the reference.  Does not force the evaluation of the -- new variable contents.  For strict update, use 'atomicUpdMutVar''. atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b@@ -259,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/List/SetOps.hs view
@@ -18,7 +18,7 @@         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,          -- Duplicate handling-        hasNoDups, removeDups, nubOrdBy, findDupsEq,+        hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq,         equivClasses,          -- Indexing@@ -37,6 +37,7 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..))+import Data.Ord (comparing) import qualified Data.Set as S  getNth :: Outputable a => [a] -> Int -> a@@ -192,6 +193,9 @@     collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)     collect_dups dups_so_far (x :| [])     = (dups_so_far,      x)     collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)++removeDupsOn :: Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])+removeDupsOn f x = removeDups (comparing f) x  -- | Remove the duplicates from a list using the provided -- comparison function.
compiler/GHC/Data/Maybe.hs view
@@ -34,7 +34,10 @@ import Data.Maybe import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Panic+import GHC.Utils.Outputable import Data.List.NonEmpty ( NonEmpty )+import Control.Applicative( Alternative( (<|>) ) )  infixr 4 `orElse` @@ -47,7 +50,7 @@ -}  firstJust :: Maybe a -> Maybe a -> Maybe a-firstJust a b = firstJusts [a, b]+firstJust = (<|>)  -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or -- @Nothing@ otherwise.@@ -65,10 +68,14 @@   go Nothing         action  = action   go result@(Just _) _action = return result -expectJust :: HasCallStack => 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/OrdList.hs view
@@ -4,8 +4,6 @@   -}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-}@@ -16,8 +14,8 @@         OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,         headOL,-        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,-        strictlyEqOL, strictlyOrdOL+        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL,+        partitionOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL ) where  import GHC.Prelude@@ -219,6 +217,25 @@ foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 foldlOL k z (Many xs)   = foldl' k z xs++partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a)+partitionOL _ None = (None,None)+partitionOL f (One x)+  | f x       = (One x, None)+  | otherwise = (None, One x)+partitionOL f (Two xs ys) = (Two ls1 ls2, Two rs1 rs2)+  where !(!ls1,!rs1) = partitionOL f xs+        !(!ls2,!rs2) = partitionOL f ys+partitionOL f (Cons x xs)+  | f x       = (Cons x ls, rs)+  | otherwise = (ls, Cons x rs)+  where !(!ls,!rs) = partitionOL f xs+partitionOL f (Snoc xs x)+  | f x       = (Snoc ls x, rs)+  | otherwise = (ls, Snoc rs x)+  where !(!ls,!rs) = partitionOL f xs+partitionOL f (Many xs) = (toOL ls, toOL rs)+  where !(!ls,!rs) = NE.partition f xs  toOL :: [a] -> OrdList a toOL [] = None
+ compiler/GHC/Data/OsPath.hs view
@@ -0,0 +1,29 @@+module GHC.Data.OsPath+  (+  -- * OsPath initialisation and transformation+    OsPath+  , OsString+  , encodeUtf+  , decodeUtf+  , unsafeDecodeUtf+  , unsafeEncodeUtf+  , os+  -- * Common utility functions+  , (</>)+  , (<.>)+  )+  where++import GHC.Prelude++import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Panic (panic)++import System.OsPath+import System.Directory.Internal (os)++-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.+-- Prefer 'decodeUtf' and gracious error handling.+unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath+unsafeDecodeUtf p =+  either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
compiler/GHC/Data/Pair.hs view
@@ -11,8 +11,8 @@    , unPair    , toPair    , swap-   , pLiftFst-   , pLiftSnd+   , pLiftFst, pLiftSnd+   , unzipPairs    ) where @@ -58,3 +58,14 @@  pLiftSnd :: (a -> a) -> Pair a -> Pair a pLiftSnd f (Pair a b) = Pair a (f b)++unzipPairs :: [Pair a] -> ([a], [a])+unzipPairs [] = ([], [])+unzipPairs (Pair a b : prs) = (a:as, b:bs)+  where+    !(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
@@ -11,18 +11,32 @@   , freezeSmallArray   , unsafeFreezeSmallArray   , indexSmallArray+  , sizeofSmallArray   , listToArray+  , 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  data SmallArray a = SmallArray (SmallArray# a)  data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) +type SmallMutableArrayIO a = SmallMutableArray RealWorld a+ newSmallArray   :: Int  -- ^ size   -> a    -- ^ initial contents@@ -32,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@@ -41,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@@ -64,16 +87,69 @@   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+  :: SmallArray a+  -> Int+{-# INLINE sizeofSmallArray #-}+sizeofSmallArray (SmallArray sa#) =+  case sizeofSmallArray# sa# of+    s -> I# s+ -- | Index a small-array (no bounds checking!) indexSmallArray   :: SmallArray a -- ^ array   -> Int          -- ^ index   -> a {-# INLINE indexSmallArray #-}-indexSmallArray (SmallArray sa#) (I# i) = case indexSmallArray# sa# i of-  (# v #) -> v+indexSmallArray (SmallArray sa#) (I# i) =+  case indexSmallArray# sa# i of+    (# v #) -> v +-- | Map a function over the elements of a 'SmallArray'+--+mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b+{-# INLINE mapSmallArray #-}+mapSmallArray f sa = runST $ ST $ \s ->+  let+    n = sizeofSmallArray sa+    go !i saMut# state#+      | i < n =+        let+          a = indexSmallArray sa i+          newState# = writeSmallArray saMut# i (f a) state#+        in+          go (i + 1) saMut# newState#+      | otherwise = state#+  in+  case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of+    (# s', mutArr #) ->+      case go 0 mutArr s' of+        s'' -> unsafeFreezeSmallArray mutArr s''++-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice+foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m+{-# INLINE foldMapSmallArray #-}+foldMapSmallArray f sa = go 0+  where+    n = sizeofSmallArray sa+    go i+      | i < n = f (indexSmallArray sa i) `mappend` go (i + 1)+      | otherwise = mempty++-- | Force the elements of the given 'SmallArray'+--+rnfSmallArray :: NFData a => SmallArray a -> ()+{-# INLINE rnfSmallArray #-}+rnfSmallArray sa = go 0+  where+    n = sizeofSmallArray sa+    go !i+      | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1)+      | otherwise = ()  -- | Convert a list into an array. listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a
compiler/GHC/Data/Stream.hs view
@@ -9,7 +9,7 @@  -- | Monadic streams module GHC.Data.Stream (-    Stream(..), StreamS(..), runStream, yield, liftIO,+    Stream(..), StreamS(..), runStream, yield, liftIO, liftEff, hoistEff,     collect,  consume, fromList,     map, mapM, mapAccumL_   ) where@@ -140,3 +140,22 @@     go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b                                            >>= \r' -> return $ Yield r' (go c' f1 h1 p)))     go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m)++-- | Lift an effect into the Stream+liftEff :: Monad m => m b -> Stream m a b+liftEff eff = Stream $ \_f g -> Effect (g <$> eff)++-- | Hoist the underlying Stream effect+-- Note this is not very efficience since, just like 'mapAccumL_', it also needs+-- to traverse and rebuild the whole stream.+hoistEff :: forall m n a b. (Applicative m, Monad n) => (forall x. m x -> n x) -> Stream m a b -> Stream n a b+hoistEff h s = Stream $ \f g -> hs f g (runStream s :: StreamS m a b) where+  hs :: (a -> n r')+     -> (b -> StreamS n r' r)+     -> StreamS m a b+     -> StreamS n r' r+  hs f g x = case x of+    Done d -> g d+    Yield a r -> Effect (f a >>= \r' -> return $ Yield r' (hs f g r))+    Effect e -> Effect (h (hs f g <$> e))+
compiler/GHC/Data/Strict.hs view
@@ -9,8 +9,8 @@ module GHC.Data.Strict (     Maybe(Nothing, Just),     fromMaybe,+    GHC.Data.Strict.maybe,     Pair(And),-     -- Not used at the moment:     --     -- Either(Left, Right),@@ -18,16 +18,26 @@   ) where  import GHC.Prelude hiding (Maybe(..), Either(..))+ 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 fromMaybe _ (Just x) = x++maybe :: b -> (a -> b) -> Maybe a -> b+maybe d _ Nothing = d+maybe _ f (Just x) = f x  apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b apMaybe (Just f) (Just x) = Just (f x)
compiler/GHC/Data/StringBuffer.hs view
@@ -6,10 +6,9 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised@@ -48,6 +47,7 @@           -- * Parsing integers         parseUnsignedInteger,+        findHashOffset,          -- * Checking for bi-directional format characters         containsBidirectionalFormatChar,@@ -76,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@@ -418,3 +413,15 @@                '_'  -> go (i + 1) x    -- skip "_" (#14473)                char -> go (i + 1) (x * radix + toInteger (char_to_int char))   in go 0 0++-- | Find the offset of the '#' character in the StringBuffer.+--+-- Make sure that it contains one before calling this function!+findHashOffset :: StringBuffer -> Int+findHashOffset (StringBuffer buf _ cur)+  = inlinePerformIO $ withForeignPtr buf $ \ptr -> do+      let+        go p = peek p >>= \case+          (0x23 :: Word8) -> pure $! ((p `minusPtr` ptr) - cur)+          _               -> go (p `plusPtr` 1)+      go (ptr `plusPtr` cur)
compiler/GHC/Data/TrieMap.hs view
@@ -13,8 +13,6 @@    MaybeMap,    -- * Maps over 'List' values    ListMap,-   -- * Maps over 'Literal's-   LiteralMap,    -- * 'TrieMap' class    TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM, @@ -30,7 +28,6 @@  import GHC.Prelude -import GHC.Types.Literal import GHC.Types.Unique.DFM import GHC.Types.Unique( Uniquable ) @@ -72,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;@@ -149,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@@ -160,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   {-@@ -236,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  {- ************************************************************************@@ -262,6 +262,7 @@    alterTM  = xtMaybe alterTM    foldTM   = fdMaybe    filterTM = ftMaybe+   mapMaybeTM = mpMaybe  instance TrieMap m => Foldable (MaybeMap m) where   foldMap = foldMapTM@@ -284,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@@ -317,6 +322,7 @@    alterTM  = xtList alterTM    foldTM   = fdList    filterTM = ftList+   mapMaybeTM = mpList  instance TrieMap m => Foldable (ListMap m) where   foldMap = foldMapTM@@ -343,15 +349,9 @@ ftList f (LM { lm_nil = mnil, lm_cons = mcons })   = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } -{--************************************************************************-*                                                                      *-                   Basic maps-*                                                                      *-************************************************************************--}--type LiteralMap  a = Map.Map Literal a+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 }  {- ************************************************************************@@ -408,6 +408,7 @@    alterTM  = xtG    foldTM   = fdG    filterTM = ftG+   mapMaybeTM = mpG  instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where   foldMap = foldMapTM@@ -470,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.hs view
@@ -1,13 +1,6 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-}-#endif-  ----------------------------------------------------------------------------- -- |
compiler/GHC/Data/Word64Map/Internal.hs view
@@ -1,15 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif  {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}@@ -312,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 @@ -490,7 +478,6 @@     rnf (Tip _ v) = rnf v     rnf (Bin _ _ l r) = rnf l `seq` rnf r -#if __GLASGOW_HASKELL__  {--------------------------------------------------------------------   A Data instance@@ -514,7 +501,6 @@ intMapDataType :: DataType intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr] -#endif  {--------------------------------------------------------------------   Query@@ -2403,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. --@@ -2423,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) =@@ -2433,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)@@@ -3102,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.@@ -3136,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@@ -3168,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.@@ -3358,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@@ -3384,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,9 +1,4 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif - ----------------------------------------------------------------------------- -- | -- Module      :  Data.Word64Map.Lazy@@ -66,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,7 +1,3 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif  ----------------------------------------------------------------------------- -- |@@ -83,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@@ -251,4 +243,3 @@     ) where  import GHC.Data.Word64Map.Strict.Internal-import Prelude ()
compiler/GHC/Data/Word64Map/Strict/Internal.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}  {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -84,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@@ -825,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. --@@ -845,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.@@ -873,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,7 +1,3 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif  ----------------------------------------------------------------------------- -- |@@ -63,11 +59,7 @@             -- $strictness              -- * Set type-#if !defined(TESTING)               Word64Set          -- instance Eq,Show-#else-              Word64Set(..)      -- instance Eq,Show-#endif             , Key              -- * Construction@@ -153,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,14 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif  {-# OPTIONS_HADDOCK not-home #-} @@ -203,17 +194,12 @@ 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 qualified Data.Foldable as Foldable import Data.Functor.Identity (Identity(..))  infixl 9 \\{-This comment teaches CPP correct behaviour -}@@ -277,7 +263,6 @@     (<>)    = union     stimes  = stimesIdempotentMonoid -#if __GLASGOW_HASKELL__  {--------------------------------------------------------------------   A Data instance@@ -300,7 +285,6 @@ intSetDataType :: DataType intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr] -#endif  {--------------------------------------------------------------------   Query@@ -511,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 #-} @@ -527,10 +507,10 @@   Union --------------------------------------------------------------------} -- | The union of a list of sets.-unions :: Foldable f => f Word64Set -> Word64Set-unions xs-  = Foldable.foldl' union empty xs +{-# INLINABLE unions #-}+unions :: [Word64Set] -> Word64Set+unions = List.foldl' union empty  -- | \(O(n+m)\). The union of two sets. union :: Word64Set -> Word64Set -> Word64Set@@ -1137,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]@@ -1161,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@@ -1187,13 +1164,12 @@ {-# 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.+{-# INLINABLE fromList #-} fromList :: [Key] -> Word64Set-fromList xs-  = Foldable.foldl' ins empty xs+fromList = List.foldl' ins empty   where     ins t x  = insert x t @@ -1311,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@@ -1545,7 +1514,6 @@ {-# INLINE foldr'Bits #-} {-# INLINE takeWhileAntitoneBits #-} -#if defined(__GLASGOW_HASKELL__) indexOfTheOnlyBit :: Nat -> Word64 {-# INLINE indexOfTheOnlyBit #-} indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask@@ -1612,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
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiWayIf, LambdaCase #-}  {-| Module      : GHC.Driver.Backend@@ -58,8 +58,6 @@    , DefunctionalizedCodeOutput(..)      -- *** Back-end functions for assembly    , DefunctionalizedPostHscPipeline(..)-   , DefunctionalizedAssemblerProg(..)-   , DefunctionalizedAssemblerInfoGetter(..)      -- *** Other back-end functions    , DefunctionalizedCDefs(..)      -- ** Names of back ends (for API clients of version 9.4 or earlier)@@ -87,15 +85,13 @@    , backendUnregisterisedAbiOnly    , backendGeneratesHc    , backendSptIsDynamic-   , backendWantsBreakpointTicks+   , backendSupportsBreakpoints    , backendForcesOptimization0    , backendNeedsFullWays    , backendSpecialModuleSource    , backendSupportsHpc    , backendSupportsCImport    , backendSupportsCExport-   , backendAssemblerProg-   , backendAssemblerInfoGetter    , backendCDefs    , backendCodeOutput    , backendUseJSLinker@@ -217,6 +213,8 @@          ArchPPC_64 {} -> True          ArchAArch64   -> True          ArchWasm32    -> True+         ArchRISCV64   -> True+         ArchLoongArch64 -> True          _             -> False  -- | Is the platform supported by the JS backend?@@ -348,40 +346,6 @@   deriving Show  --- | Names a function that runs the assembler, of this type:------ > Logger -> DynFlags -> Platform -> [Option] -> IO ()------ The functions so named are defined in "GHC.Driver.Pipeline.Execute".--data DefunctionalizedAssemblerProg-  = StandardAssemblerProg-       -- ^ Use the standard system assembler-  | JSAssemblerProg-       -- ^ JS Backend compile to JS via Stg, and so does not use any assembler-  | DarwinClangAssemblerProg-       -- ^ If running on Darwin, use the assembler from the @clang@-       -- toolchain.  Otherwise use the standard system assembler.------ | Names a function that discover from what toolchain the assembler--- is coming, of this type:------ > Logger -> DynFlags -> Platform -> IO CompilerInfo------ The functions so named are defined in "GHC.Driver.Pipeline.Execute".--data DefunctionalizedAssemblerInfoGetter-  = StandardAssemblerInfoGetter-       -- ^ Interrogate the standard system assembler-  | JSAssemblerInfoGetter-       -- ^ If using the JS backend; return 'Emscripten'-  | DarwinClangAssemblerInfoGetter-       -- ^ If running on Darwin, return `Clang`; otherwise-       -- interrogate the standard system assembler.-- -- | Names a function that generates code and writes the results to a --  file, of this type: --@@ -549,19 +513,16 @@ backendRespectsSpecialise (Named Interpreter) = False backendRespectsSpecialise (Named NoBackend)   = False --- | This back end wants the `mi_globals` field of a+-- | This back end wants the `mi_top_env` field of a -- `ModIface` to be populated (with the top-level bindings--- of the original source).  True for the interpreter, and--- also true for "no backend", which is used by Haddock.--- (After typechecking a module, Haddock wants access to--- the module's `GlobalRdrEnv`.)+-- of the original source).  Only true for the interpreter. backendWantsGlobalBindings :: Backend -> Bool backendWantsGlobalBindings (Named NCG)         = False backendWantsGlobalBindings (Named LLVM)        = False backendWantsGlobalBindings (Named ViaC)        = False backendWantsGlobalBindings (Named JavaScript)  = False+backendWantsGlobalBindings (Named NoBackend)   = False backendWantsGlobalBindings (Named Interpreter) = True-backendWantsGlobalBindings (Named NoBackend)   = True  -- | The back end targets a technology that implements -- `switch` natively.  (For example, LLVM or C.) Therefore@@ -595,12 +556,12 @@ -- `NotValid`, it carries a message that is shown to -- users. backendSimdValidity :: Backend -> Validity' String-backendSimdValidity (Named NCG)         = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]+backendSimdValidity (Named NCG)         = IsValid backendSimdValidity (Named LLVM)        = IsValid-backendSimdValidity (Named ViaC)        = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]-backendSimdValidity (Named JavaScript)  = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]-backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]-backendSimdValidity (Named NoBackend)   = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]+backendSimdValidity (Named ViaC)        = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named JavaScript)  = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named NoBackend)   = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]  -- | This flag says whether the back end supports large -- binary blobs.  See Note [Embedding large binary blobs]@@ -691,16 +652,16 @@ backendSptIsDynamic (Named Interpreter) = True backendSptIsDynamic (Named NoBackend)   = False --- | If this flag is set, then "GHC.HsToCore.Ticks"--- inserts `Breakpoint` ticks.  Used only for the--- interpreter.-backendWantsBreakpointTicks :: Backend -> Bool-backendWantsBreakpointTicks (Named NCG)         = False-backendWantsBreakpointTicks (Named LLVM)        = False-backendWantsBreakpointTicks (Named ViaC)        = False-backendWantsBreakpointTicks (Named JavaScript)  = False-backendWantsBreakpointTicks (Named Interpreter) = True-backendWantsBreakpointTicks (Named NoBackend)   = False+-- | If this flag is unset, then the driver ignores the flag @-fbreak-points@,+-- since backends other than the interpreter tend to panic on breakpoints.+backendSupportsBreakpoints :: Backend -> Bool+backendSupportsBreakpoints = \case+  Named NCG         -> False+  Named LLVM        -> False+  Named ViaC        -> False+  Named JavaScript  -> False+  Named Interpreter -> True+  Named NoBackend   -> False  -- | If this flag is set, then the driver forces the -- optimization level to 0, issuing a warning message if@@ -769,45 +730,6 @@ backendSupportsCExport (Named JavaScript)  = True backendSupportsCExport (Named Interpreter) = False backendSupportsCExport (Named NoBackend)   = True---- | This (defunctionalized) function runs the assembler--- used on the code that is written by this back end.  A--- program determined by a combination of back end,--- `DynFlags`, and `Platform` is run with the given--- `Option`s.------ The function's type is--- @--- Logger -> DynFlags -> Platform -> [Option] -> IO ()--- @------ This field is usually defaulted.-backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg-backendAssemblerProg (Named NCG)  = StandardAssemblerProg-backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg-backendAssemblerProg (Named ViaC) = StandardAssemblerProg-backendAssemblerProg (Named JavaScript)  = JSAssemblerProg-backendAssemblerProg (Named Interpreter) = StandardAssemblerProg-backendAssemblerProg (Named NoBackend)   = StandardAssemblerProg---- | This (defunctionalized) function is used to retrieve--- an enumeration value that characterizes the C/assembler--- part of a toolchain.  The function caches the info in a--- mutable variable that is part of the `DynFlags`.------ The function's type is--- @--- Logger -> DynFlags -> Platform -> IO CompilerInfo--- @------ This field is usually defaulted.-backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter-backendAssemblerInfoGetter (Named NCG)         = StandardAssemblerInfoGetter-backendAssemblerInfoGetter (Named LLVM)        = DarwinClangAssemblerInfoGetter-backendAssemblerInfoGetter (Named ViaC)        = StandardAssemblerInfoGetter-backendAssemblerInfoGetter (Named JavaScript)  = JSAssemblerInfoGetter-backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter-backendAssemblerInfoGetter (Named NoBackend)   = StandardAssemblerInfoGetter  -- | When using this back end, it may be necessary or -- advisable to pass some `-D` options to a C compiler.
compiler/GHC/Driver/CmdLine.hs view
@@ -17,7 +17,7 @@       Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,       errorsToGhcException, -      Err(..), Warn(..), WarnReason(..),+      Err(..), Warn, warnsToMessages,        EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM     ) where@@ -25,14 +25,14 @@ import GHC.Prelude  import GHC.Utils.Misc-import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc-import GHC.Utils.Json--import GHC.Types.Error ( DiagnosticReason(..) )+import GHC.Types.Error+import GHC.Utils.Error+import GHC.Driver.Errors.Types+import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage+import GHC.Utils.Outputable (text)  import Data.Function import Data.List (sortBy, intercalate, stripPrefix)@@ -108,32 +108,16 @@ --         The EwM monad -------------------------------------------------------- --- | Used when filtering warnings: if a reason is given--- it can be filtered out when displaying.-data WarnReason-  = NoReason-  | ReasonDeprecatedFlag-  | ReasonUnrecognisedFlag-  deriving (Eq, Show)--instance Outputable WarnReason where-  ppr = text . show--instance ToJson WarnReason where-  json NoReason = JSNull-  json reason   = JSString $ show reason- -- | A command-line error message newtype Err  = Err { errMsg :: Located String }  -- | A command-line warning message and the reason it arose-data Warn = Warn-  {   warnReason :: DiagnosticReason,-      warnMsg    :: Located String-  }+--+-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@.+type Warn = Located DriverMessage  type Errs  = Bag Err-type Warns = Bag Warn+type Warns = [Warn]  -- EwM ("errors and warnings monad") is a monad -- transformer for m that adds an (err, warn) state@@ -153,7 +137,7 @@     liftIO = liftEwM . liftIO  runEwM :: EwM m a -> m (Errs, Warns, a)-runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag+runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag mempty  setArg :: Located String -> EwM m () -> EwM m () setArg l (EwM f) = EwM (\_ es ws -> f l es ws)@@ -162,11 +146,12 @@ addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))  addWarn :: Monad m => String -> EwM m ()-addWarn = addFlagWarn WarningWithoutFlag+addWarn msg = addFlagWarn $ DriverUnknownMessage $ mkSimpleUnknownDiagnostic $+  mkPlainDiagnostic WarningWithoutFlag noHints $ text msg -addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m ()-addFlagWarn reason msg = EwM $-  (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))+addFlagWarn :: Monad m => DriverMessage -> EwM m ()+addFlagWarn msg = EwM+  (\(L loc _) es ws -> return (es, L loc msg : ws, ()))  getArg :: Monad m => EwM m String getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))@@ -177,6 +162,10 @@ liftEwM :: Monad m => m a -> EwM m a liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage+warnsToMessages diag_opts = foldr+  (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws)+  emptyMessages  -------------------------------------------------------- --         Processing arguments@@ -188,10 +177,10 @@             -> (FilePath -> EwM m [Located String]) -- ^ response file handler             -> m ( [Located String],  -- spare args                    [Err],  -- errors-                   [Warn] ) -- warnings+                   Warns ) -- warnings processArgs spec args handleRespFile = do     (errs, warns, spare) <- runEwM action-    return (spare, bagToList errs, bagToList warns)+    return (spare, bagToList errs, warns)   where     action = process args []
compiler/GHC/Driver/Config.hs view
@@ -2,22 +2,18 @@ module GHC.Driver.Config    ( initOptCoercionOpts    , initSimpleOpts-   , initBCOOpts    , initEvalOpts+   , EvalStep(..)    ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt-import GHC.Runtime.Interpreter (BCOOpts(..)) import GHCi.Message (EvalOpts(..)) -import GHC.Conc (getNumProcessors)-import Control.Monad.IO.Class- -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts initOptCoercionOpts dflags = OptCoercionOpts@@ -30,25 +26,32 @@    { so_uf_opts = unfoldingOpts dflags    , so_co_opts = initOptCoercionOpts dflags    , so_eta_red = gopt Opt_DoEtaReduction dflags+   , so_inline  = True    } --- | Extract BCO options from DynFlags-initBCOOpts :: DynFlags -> IO BCOOpts-initBCOOpts dflags = do-  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode-  -- (-j<n>) parallelise the serialization.-  n_jobs <- case parMakeCount dflags of-              Nothing -> liftIO getNumProcessors-              Just n  -> return n-  return $ BCOOpts n_jobs+-- | 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/Core/Lint.hs view
@@ -12,7 +12,7 @@ import qualified GHC.LanguageExtensions as LangExt  import GHC.Driver.Env-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Config.Diagnostic  import GHC.Core@@ -77,17 +77,17 @@ coreDumpFlag :: CoreToDo -> Maybe DumpFlag coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core-coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core-coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core-coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core-coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_dump_float_in+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_dump_float_out+coreDumpFlag CoreLiberateCase         = Just Opt_D_dump_liberate_case+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify-coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_stranal+coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr                = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec-coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec_constr coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds@@ -132,8 +132,7 @@     -- we have eta-expanded data constructors with representation-polymorphic     -- bindings; so we switch off the representation-polymorphism checks.     -- The very simple optimiser will beta-reduce them away.-    -- See Note [Checking for representation-polymorphic built-ins]-    -- in GHC.HsToCore.Expr.+    -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete     check_fixed_rep = case pass of                         CoreDesugar -> False                         _           -> True
compiler/GHC/Driver/Config/Diagnostic.hs view
@@ -8,20 +8,22 @@   , initDsMessageOpts   , initTcMessageOpts   , initDriverMessageOpts+  , initIfaceMessageOpts   ) where  import GHC.Driver.Flags-import GHC.Driver.Session+import GHC.Driver.DynFlags+import GHC.Prelude  import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..))-import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..))-import GHC.Driver.Errors.Ppr ()+import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage)+import GHC.Driver.Errors.Ppr () -- Diagnostic instances import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error-import GHC.Tc.Errors.Ppr+import GHC.Iface.Errors.Types  -- | Initialise the general configuration for printing diagnostic messages -- For example, this configuration controls things like whether warnings are@@ -30,6 +32,8 @@ initDiagOpts dflags = DiagOpts   { diag_warning_flags       = warningFlags dflags   , diag_fatal_warning_flags = fatalWarningFlags dflags+  , diag_custom_warning_categories = customWarningCategories dflags+  , diag_fatal_custom_warning_categories = fatalCustomWarningCategories dflags   , diag_warn_is_error       = gopt Opt_WarnIsError dflags   , diag_reverse_errors      = reverseErrors dflags   , diag_max_errors          = maxErrors dflags@@ -48,11 +52,18 @@ initPsMessageOpts _ = NoDiagnosticOpts  initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage-initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags }+initTcMessageOpts dflags =+  TcRnMessageOpts { tcOptsShowContext    = gopt Opt_ShowErrorContext dflags+                  , tcOptsIfaceOpts      = initIfaceMessageOpts dflags }  initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage initDsMessageOpts _ = NoDiagnosticOpts +initIfaceMessageOpts :: DynFlags -> DiagnosticOpts IfaceMessage+initIfaceMessageOpts dflags =+                  IfaceMessageOpts { ifaceShowTriedFiles = verbosity dflags >= 3+                                   , ifaceBuildingCabalPackage = checkBuildingCabalPackage dflags }+ initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage-initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags)+initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) (initIfaceMessageOpts dflags)
compiler/GHC/Driver/Config/Logger.hs view
@@ -5,7 +5,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Utils.Logger (LogFlags (..)) import GHC.Utils.Outputable@@ -17,6 +17,7 @@   , log_default_dump_context = initSDocContext dflags defaultDumpStyle   , log_dump_flags           = dumpFlags dflags   , log_show_caret           = gopt Opt_DiagnosticsShowCaret dflags+  , log_diagnostics_as_json  = gopt Opt_DiagnosticsAsJSON dflags   , log_show_warn_groups     = gopt Opt_ShowWarnGroups dflags   , log_enable_timestamps    = not (gopt Opt_SuppressTimestamps dflags)   , log_dump_to_file         = gopt Opt_DumpToFile dflags
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
@@ -0,0 +1,1581 @@+{-# LANGUAGE LambdaCase #-}+module GHC.Driver.DynFlags (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), DiagnosticReason(..),+        Language(..),+        FatalMessager, FlushOut(..),+        ProfAuto(..),+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset,+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        wopt_set_all_custom, wopt_unset_all_custom,+        wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,+        wopt_set_custom, wopt_unset_custom,+        wopt_set_fatal_custom, wopt_unset_fatal_custom,+        wopt_any_custom,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow,+        OnOff(..),+        DynFlags(..),+        ParMakeCount(..),+        ways,+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        positionIndependent,+        optimisationFlags,++        targetProfile,++        ReexportedModule(..),++        -- ** Manipulating DynFlags+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        optLevelFlags,+        languageExtensions,++        TurnOnFlag,+        turnOn,+        turnOff,++        -- ** System tool settings and locations+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir, toolDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,++        --+        baseUnitId,+++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+        initPromotionTickContext,++        -- * Platform features+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,+        isSse4_2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,+        isBmiEnabled,+        isBmi2Enabled+) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile++import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Unfold+import GHC.Data.Bool+import GHC.Data.EnumSet (EnumSet)+import GHC.Data.Maybe+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+import GHC.Settings.Constants+import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )+import GHC.Types.Error (DiagnosticReason(..))+import GHC.Types.ProfAuto+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Utils.CliOption+import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )+import GHC.UniqueSubdir (uniqueSubdir)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.TmpFs++import qualified GHC.Types.FieldLabel as FieldLabel+import qualified GHC.Utils.Ppr.Colour as Col+import qualified GHC.Data.EnumSet as EnumSet++import GHC.Core.Opt.CallerCC.Types++import Control.Monad (msum, (<=<))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Writer (WriterT)+import Data.Word+import System.IO+import System.IO.Error (catchIOError)+import System.Environment (lookupEnv)+import System.FilePath (normalise, (</>))+import System.Directory+import GHC.Foreign (withCString, peekCString)++import qualified Data.Set as Set++import qualified GHC.LanguageExtensions as LangExt++-- -----------------------------------------------------------------------------+-- DynFlags++-- | Contains not only a collection of 'GeneralFlag's but also a plethora of+-- information relating to the compilation of a single file or GHC session+data DynFlags = DynFlags {+  ghcMode               :: GhcMode,+  ghcLink               :: GhcLink,+  backend               :: !Backend,+   -- ^ The backend to use (if any).+   --+   -- Whenever you change the backend, also make sure to set 'ghcLink' to+   -- something sensible.+   --+   -- 'NoBackend' can be used to avoid generating any output, however, note that:+   --+   --  * If a program uses Template Haskell the typechecker may need to run code+   --    from an imported module.  To facilitate this, code generation is enabled+   --    for modules imported by modules that use template haskell, using the+   --    default backend for the platform.+   --    See Note [-fno-code mode].+++  -- formerly Settings+  ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,+  fileSettings      :: {-# UNPACK #-} !FileSettings,+  unitSettings      :: {-# UNPACK #-} !UnitSettings,++  targetPlatform    :: Platform,       -- Filled in by SysTools+  toolSettings      :: {-# UNPACK #-} !ToolSettings,+  platformMisc      :: {-# UNPACK #-} !PlatformMisc,+  rawSettings       :: [(String, String)],+  tmpDir            :: TempDir,++  llvmOptLevel          :: Int,         -- ^ LLVM optimisation level+  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]+  debugLevel            :: Int,         -- ^ How much debug information to produce+  simplPhases           :: Int,         -- ^ Number of simplifier phases+  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations+  ruleCheck             :: Maybe String,+  strictnessBefore      :: [Int],       -- ^ Additional demand analysis++  parMakeCount          :: Maybe ParMakeCount,+    -- ^ The number of modules to compile in parallel+    --   If unspecified, compile with a single job.++  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?+  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.++  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt+                                        --   to show in type error messages+  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show+                                        --   in typed hole error messages+  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole+                                        --   fits to show in typed hole error+                                        --   messages+  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for+                                        --   refinement hole fits in typed hole+                                        --   error messages+  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show+                                        --   in non-exhaustiveness warnings+  maxPmCheckModels      :: Int,         -- ^ Soft limit on the number of models+                                        --   the pattern match checker checks+                                        --   a pattern against. A safe guard+                                        --   against exponential blow-up.+  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks+  dmdUnboxWidth         :: !Int,        -- ^ Whether DmdAnal should optimistically put an+                                        --   Unboxed demand on returned products with at most+                                        --   this number of fields+  ifCompression         :: Int,+  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr+  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function+  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types+                                        --   Not optional; otherwise ForceSpecConstr can diverge.+  binBlobThreshold      :: Maybe Word,  -- ^ Binary literals (e.g. strings) whose size is above+                                        --   this threshold will be dumped in a binary file+                                        --   by the assembler code generator. 0 and Nothing disables+                                        --   this feature. See 'GHC.StgToCmm.Config'.+  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase+  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating+                                        --   See 'GHC.Core.Opt.Monad.FloatOutSwitches'++  liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   recursive function.+  liftLamsNonRecArgs    :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   non-recursive function.+  liftLamsKnown         :: Bool,        -- ^ Lambda lift even when this turns a known call+                                        --   into an unknown call.++  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.++  historySize           :: Int,         -- ^ Simplification history size++  importPaths           :: [FilePath],+  mainModuleNameIs      :: ModuleName,+  mainFunIs             :: Maybe String,+  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth+  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver+                                         --   Typically only 1 is needed+  givensFuel            :: Int,          -- ^ Number of layers of superclass expansion for givens+                                         --   Should be < solverIterations+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  wantedsFuel           :: Int,          -- ^ Number of layers of superclass expansion for wanteds+                                         --   Should be < givensFuel+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  qcsFuel                :: Int,          -- ^ Number of layers of superclass expansion for quantified constraints+                                         --   Should be < givensFuel+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  homeUnitId_             :: UnitId,                 -- ^ Target home unit-id+  homeUnitInstanceOf_     :: Maybe UnitId,           -- ^ Id of the unit to instantiate+  homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations++  -- Note [Filepaths and Multiple Home Units]+  workingDirectory      :: Maybe FilePath,+  thisPackageName       :: Maybe String, -- ^ What the package is called, use with multiple home units+  hiddenModules         :: Set.Set ModuleName,+  reexportedModules     :: [ReexportedModule],++  -- ways+  targetWays_           :: Ways,         -- ^ Target way flags from the command line++  -- For object splitting+  splitInfo             :: Maybe (String,Int),++  -- paths etc.+  objectDir             :: Maybe String,+  dylibInstallName      :: Maybe String,+  hiDir                 :: Maybe String,+  hieDir                :: Maybe String,+  stubDir               :: Maybe String,+  dumpDir               :: Maybe String,++  objectSuf_            :: String,+  hcSuf                 :: String,+  hiSuf_                :: String,+  hieSuf                :: String,++  dynObjectSuf_         :: String,+  dynHiSuf_             :: String,++  outputFile_           :: Maybe String,+  dynOutputFile_        :: Maybe String,+  outputHi              :: Maybe String,+  dynOutputHi           :: Maybe String,+  dynLibLoader          :: DynLibLoader,++  dynamicNow            :: !Bool, -- ^ Indicate if we are now generating dynamic output+                                  -- because of -dynamic-too. This predicate is+                                  -- used to query the appropriate fields+                                  -- (outputFile/dynOutputFile, ways, etc.)++  -- | This defaults to 'non-module'. It can be set by+  -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on+  -- where its output is going.+  dumpPrefix            :: FilePath,++  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix'+  --    or 'ghc.GHCi.UI.runStmt'.+  --    Set by @-ddump-file-prefix@+  dumpPrefixForce       :: Maybe FilePath,++  ldInputs              :: [Option],++  includePaths          :: IncludeSpecs,+  libraryPaths          :: [String],+  frameworkPaths        :: [String],    -- used on darwin only+  cmdlineFrameworks     :: [String],    -- ditto++  rtsOpts               :: Maybe String,+  rtsOptsEnabled        :: RtsOptsEnabled,+  rtsOptsSuggestions    :: Bool,++  hpcDir                :: String,      -- ^ Path to store the .mix files++  -- Plugins+  pluginModNames        :: [ModuleName],+    -- ^ the @-fplugin@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.+  pluginModNameOpts     :: [(ModuleName,String)],+  frontendPluginOpts    :: [String],+    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.++  externalPluginSpecs   :: [ExternalPluginSpec],+    -- ^ External plugins loaded from shared libraries++  --  For ghc -M+  depMakefile           :: FilePath,+  depIncludePkgDeps     :: Bool,+  depIncludeCppDeps     :: Bool,+  depExcludeMods        :: [ModuleName],+  depSuffixes           :: [String],++  --  Package flags+  packageDBFlags        :: [PackageDBFlag],+        -- ^ The @-package-db@ flags given on the command line, In+        -- *reverse* order that they're specified on the command line.+        -- This is intended to be applied with the list of "initial"+        -- package databases derived from @GHC_PACKAGE_PATH@; see+        -- 'getUnitDbRefs'.++  ignorePackageFlags    :: [IgnorePackageFlag],+        -- ^ The @-ignore-package@ flags from the command line.+        -- In *reverse* order that they're specified on the command line.+  packageFlags          :: [PackageFlag],+        -- ^ The @-package@ and @-hide-package@ flags from the command-line.+        -- In *reverse* order that they're specified on the command line.+  pluginPackageFlags    :: [PackageFlag],+        -- ^ The @-plugin-package-id@ flags from command line.+        -- In *reverse* order that they're specified on the command line.+  trustFlags            :: [TrustFlag],+        -- ^ The @-trust@ and @-distrust@ flags.+        -- In *reverse* order that they're specified on the command line.+  packageEnv            :: Maybe FilePath,+        -- ^ Filepath to the package environment file (if overriding default)+++  -- hsc dynamic flags+  dumpFlags             :: EnumSet DumpFlag,+  generalFlags          :: EnumSet GeneralFlag,+  warningFlags          :: EnumSet WarningFlag,+  fatalWarningFlags     :: EnumSet WarningFlag,+  customWarningCategories      :: WarningCategorySet, -- See Note [Warning categories]+  fatalCustomWarningCategories :: WarningCategorySet, -- in GHC.Unit.Module.Warnings+  -- Don't change this without updating extensionFlags:+  language              :: Maybe Language,+  -- | Safe Haskell mode+  safeHaskell           :: SafeHaskellMode,+  safeInfer             :: Bool,+  safeInferred          :: Bool,+  -- We store the location of where some extension and flags were turned on so+  -- we can produce accurate error messages when Safe Haskell fails due to+  -- them.+  thOnLoc               :: SrcSpan,+  newDerivOnLoc         :: SrcSpan,+  deriveViaOnLoc        :: SrcSpan,+  overlapInstLoc        :: SrcSpan,+  incoherentOnLoc       :: SrcSpan,+  pkgTrustOnLoc         :: SrcSpan,+  warnSafeOnLoc         :: SrcSpan,+  warnUnsafeOnLoc       :: SrcSpan,+  trustworthyOnLoc      :: SrcSpan,+  -- Don't change this without updating extensionFlags:+  -- Here we collect the settings of the language extensions+  -- from the command line, the ghci config file and+  -- from interactive :set / :seti commands.+  extensions            :: [OnOff LangExt.Extension],+  -- extensionFlags should always be equal to+  --     flattenExtensionFlags language extensions+  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used+  -- by template-haskell+  extensionFlags        :: EnumSet LangExt.Extension,++  -- | Unfolding control+  -- See Note [Discounts and thresholds] in GHC.Core.Unfold+  unfoldingOpts         :: !UnfoldingOpts,++  maxWorkerArgs         :: Int,+  maxForcedSpecArgs     :: Int,++  ghciHistSize          :: Int,++  -- wasm ghci browser mode+  ghciBrowserHost                  :: !String,+  ghciBrowserPort                  :: !Int,+  ghciBrowserPuppeteerLaunchOpts   :: !(Maybe String),+  ghciBrowserPlaywrightBrowserType :: !(Maybe String),+  ghciBrowserPlaywrightLaunchOpts  :: !(Maybe String),++  flushOut              :: FlushOut,++  ghcVersionFile        :: Maybe FilePath,+  haddockOptions        :: Maybe String,++  -- | GHCi scripts specified by -ghci-script, in reverse order+  ghciScripts           :: [String],++  -- Output style options+  pprUserLength         :: Int,+  pprCols               :: Int,++  useUnicode            :: Bool,+  useColor              :: OverridingBool,+  canUseColor           :: Bool,+  useErrorLinks         :: OverridingBool,+  canUseErrorLinks      :: Bool,+  colScheme             :: Col.Scheme,++  -- | what kind of {-# SCC #-} to add automatically+  profAuto              :: ProfAuto,+  callerCcFilters       :: [CallerCcFilter],++  interactivePrint      :: Maybe String,++  -- | Machine dependent flags (-m\<blah> stuff)+  sseVersion            :: Maybe SseVersion,+  bmiVersion            :: Maybe BmiVersion,+  avx                   :: Bool,+  avx2                  :: Bool,+  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.+  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.+  avx512f               :: Bool, -- Enable AVX-512 instructions.+  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.+  fma                   :: Bool, -- ^ Enable FMA instructions.++  -- Constants used to control the amount of optimization done.++  -- | Max size, in bytes, of inline array allocations.+  maxInlineAllocSize    :: Int,++  -- | Only inline memcpy if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemcpyInsns  :: Int,++  -- | Only inline memset if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemsetInsns  :: Int,++  -- | Reverse the order of error messages in GHC/GHCi+  reverseErrors         :: Bool,++  -- | Limit the maximum number of errors to show+  maxErrors             :: Maybe Int,++  -- | Unique supply configuration for testing build determinism+  initialUnique         :: Word64,+  uniqueIncrement       :: Int,+    -- 'Int' because it can be used to test uniques in decreasing order.++  -- | Temporary: CFG Edge weights for fast iterations+  cfgWeights            :: Weights+}++class HasDynFlags m where+    getDynFlags :: m DynFlags++{- It would be desirable to have the more generalised++  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where+      getDynFlags = lift getDynFlags++instance definition. However, that definition would overlap with the+`HasDynFlags (GhcT m)` instance. Instead we define instances for a+couple of common Monad transformers explicitly. -}++instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where+    getDynFlags = lift getDynFlags++class ContainsDynFlags t where+    extractDynFlags :: t -> DynFlags++-----------------------------------------------------------------------------++-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value+initDynFlags :: DynFlags -> IO DynFlags+initDynFlags dflags = do+ let+ -- This is not bulletproof: we test that 'localeEncoding' is Unicode-capable,+ -- but potentially 'hGetEncoding' 'stdout' might be different. Still good enough.+ canUseUnicode <- do let enc = localeEncoding+                         str = "‘’"+                     (withCString enc str $ \cstr ->+                          do str' <- peekCString enc cstr+                             return (str == str'))+                         `catchIOError` \_ -> return False+ ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"+ let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode+ maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"+ maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"+ let adjustCols (Just env) = Col.parseScheme env+     adjustCols Nothing    = id+ let (useColor', colScheme') =+       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)+       (useColor dflags, colScheme dflags)+ tmp_dir <- normalise <$> getTemporaryDirectory+ return dflags{+        useUnicode    = useUnicode',+        useColor      = useColor',+        canUseColor   = stderrSupportsAnsiColors,+        -- if the terminal supports color, we assume it supports links as well+        canUseErrorLinks = stderrSupportsAnsiColors,+        colScheme     = colScheme',+        tmpDir        = TempDir tmp_dir+        }++-- | The normal 'DynFlags'. Note that they are not suitable for use in this form+-- and must be fully initialized by 'GHC.runGhc' first.+defaultDynFlags :: Settings -> DynFlags+defaultDynFlags mySettings =+-- See Note [Updating flag description in the User's Guide]+     DynFlags {+        ghcMode                 = CompManager,+        ghcLink                 = LinkBinary,+        backend                 = platformDefaultBackend (sTargetPlatform mySettings),+        verbosity               = 0,+        debugLevel              = 0,+        simplPhases             = 2,+        maxSimplIterations      = 4,+        ruleCheck               = Nothing,+        binBlobThreshold        = Just 500000, -- 500K is a good default (see #16190)+        maxRelevantBinds        = Just 6,+        maxValidHoleFits   = Just 6,+        maxRefHoleFits     = Just 6,+        refLevelHoleFits   = Nothing,+        maxUncoveredPatterns    = 4,+        maxPmCheckModels        = 30,+        simplTickFactor         = 100,+        dmdUnboxWidth           = 3,      -- Default: Assume an unboxed demand on function bodies returning a triple+        ifCompression           = 2,      -- Default: Apply safe compressions+        specConstrThreshold     = Just 2000,+        specConstrCount         = Just 3,+        specConstrRecursive     = 3,+        liberateCaseThreshold   = Just 2000,+        floatLamArgs            = Just 0, -- Default: float only if no fvs+        liftLamsRecArgs         = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsNonRecArgs      = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsKnown           = False,  -- Default: don't turn known calls into unknown ones+        cmmProcAlignment        = Nothing,++        historySize             = 20,+        strictnessBefore        = [],++        parMakeCount            = Nothing,++        enableTimeStats         = False,+        ghcHeapSize             = Nothing,++        importPaths             = ["."],+        mainModuleNameIs        = mAIN_NAME,+        mainFunIs               = Nothing,+        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,+        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,+        givensFuel              = mAX_GIVENS_FUEL,+        wantedsFuel             = mAX_WANTEDS_FUEL,+        qcsFuel                 = mAX_QC_FUEL,++        homeUnitId_             = mainUnitId,+        homeUnitInstanceOf_     = Nothing,+        homeUnitInstantiations_ = [],++        workingDirectory        = Nothing,+        thisPackageName         = Nothing,+        hiddenModules           = Set.empty,+        reexportedModules       = [],++        objectDir               = Nothing,+        dylibInstallName        = Nothing,+        hiDir                   = Nothing,+        hieDir                  = Nothing,+        stubDir                 = Nothing,+        dumpDir                 = Nothing,++        objectSuf_              = phaseInputExt StopLn,+        hcSuf                   = phaseInputExt HCc,+        hiSuf_                  = "hi",+        hieSuf                  = "hie",++        dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,+        dynHiSuf_               = "dyn_hi",+        dynamicNow              = False,++        pluginModNames          = [],+        pluginModNameOpts       = [],+        frontendPluginOpts      = [],++        externalPluginSpecs     = [],++        outputFile_             = Nothing,+        dynOutputFile_          = Nothing,+        outputHi                = Nothing,+        dynOutputHi             = Nothing,+        dynLibLoader            = SystemDependent,+        dumpPrefix              = "non-module.",+        dumpPrefixForce         = Nothing,+        ldInputs                = [],+        includePaths            = IncludeSpecs [] [] [],+        libraryPaths            = [],+        frameworkPaths          = [],+        cmdlineFrameworks       = [],+        rtsOpts                 = Nothing,+        rtsOptsEnabled          = RtsOptsSafeOnly,+        rtsOptsSuggestions      = True,++        hpcDir                  = ".hpc",++        packageDBFlags          = [],+        packageFlags            = [],+        pluginPackageFlags      = [],+        ignorePackageFlags      = [],+        trustFlags              = [],+        packageEnv              = Nothing,+        targetWays_             = Set.empty,+        splitInfo               = Nothing,++        ghcNameVersion = sGhcNameVersion mySettings,+        unitSettings   = sUnitSettings mySettings,+        fileSettings = sFileSettings mySettings,+        toolSettings = sToolSettings mySettings,+        targetPlatform = sTargetPlatform mySettings,+        platformMisc = sPlatformMisc mySettings,+        rawSettings = sRawSettings mySettings,++        tmpDir                  = panic "defaultDynFlags: uninitialized tmpDir",++        llvmOptLevel            = 0,++        -- ghc -M values+        depMakefile       = "Makefile",+        depIncludePkgDeps = False,+        depIncludeCppDeps = False,+        depExcludeMods    = [],+        depSuffixes       = [],+        -- end of ghc -M values+        ghcVersionFile = Nothing,+        haddockOptions = Nothing,+        dumpFlags = EnumSet.empty,+        generalFlags = EnumSet.fromList (defaultFlags mySettings),+        warningFlags = EnumSet.fromList standardWarnings,+        fatalWarningFlags = EnumSet.empty,+        customWarningCategories = completeWarningCategorySet,+        fatalCustomWarningCategories = emptyWarningCategorySet,+        ghciScripts = [],+        language = Nothing,+        safeHaskell = Sf_None,+        safeInfer   = True,+        safeInferred = True,+        thOnLoc = noSrcSpan,+        newDerivOnLoc = noSrcSpan,+        deriveViaOnLoc = noSrcSpan,+        overlapInstLoc = noSrcSpan,+        incoherentOnLoc = noSrcSpan,+        pkgTrustOnLoc = noSrcSpan,+        warnSafeOnLoc = noSrcSpan,+        warnUnsafeOnLoc = noSrcSpan,+        trustworthyOnLoc = noSrcSpan,+        extensions = [],+        extensionFlags = flattenExtensionFlags Nothing [],++        unfoldingOpts = defaultUnfoldingOpts,+        maxWorkerArgs = 10,+        maxForcedSpecArgs = 333,+        -- 333 is fairly arbitrary, see Note [Forcing specialisation]:FS5++        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,+        useUnicode = False,+        useColor = Auto,+        canUseColor = False,+        useErrorLinks = Auto,+        canUseErrorLinks = False,+        colScheme = Col.defaultScheme,+        profAuto = NoProfAuto,+        callerCcFilters = [],+        interactivePrint = Nothing,+        sseVersion = Nothing,+        bmiVersion = Nothing,+        avx = False,+        avx2 = False,+        avx512cd = False,+        avx512er = False,+        avx512f = False,+        avx512pf = False,+        -- Use FMA by default on AArch64+        fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64,++        maxInlineAllocSize = 128,+        maxInlineMemcpyInsns = 32,+        maxInlineMemsetInsns = 32,++        initialUnique = 0,+        uniqueIncrement = 1,++        reverseErrors = False,+        maxErrors     = Nothing,+        cfgWeights    = defaultWeights+      }++type FatalMessager = String -> IO ()++defaultFatalMessager :: FatalMessager+defaultFatalMessager = hPutStrLn stderr+++newtype FlushOut = FlushOut (IO ())++defaultFlushOut :: FlushOut+defaultFlushOut = FlushOut $ hFlush stdout++-- 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+flattenExtensionFlags ml = foldr g defaultExtensionFlags+    where g (On f)  flags = EnumSet.insert f flags+          g (Off f) flags = EnumSet.delete f flags+          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)++-- -----------------------------------------------------------------------------+-- -jN++-- | The type for the -jN argument, specifying that -j on its own represents+-- using the number of machine processors.+data ParMakeCount+  -- | Use this many processors (@-j<n>@ flag).+  = ParMakeThisMany Int+  -- | Use parallelism with as many processors as possible (@-j@ flag without an argument).+  | ParMakeNumProcessors+  -- | Use the specific semaphore @<sem>@ to control parallelism (@-jsem <sem>@ flag).+  | ParMakeSemaphore FilePath++-- | The 'GhcMode' tells us whether we're doing multi-module+-- compilation (controlled via the "GHC" API) or one-shot+-- (single-module) compilation.  This makes a difference primarily to+-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for+-- imported modules, but in multi-module mode we look for source files+-- in order to check whether they need to be recompiled.+data GhcMode+  = CompManager         -- ^ @\-\-make@, GHCi, etc.+  | OneShot             -- ^ @ghc -c Foo.hs@+  | MkDepend            -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this+  deriving Eq++instance Outputable GhcMode where+  ppr CompManager = text "CompManager"+  ppr OneShot     = text "OneShot"+  ppr MkDepend    = text "MkDepend"++isOneShot :: GhcMode -> Bool+isOneShot OneShot = True+isOneShot _other  = False++-- | What to do in the link step, if there is one.+data GhcLink+  = NoLink              -- ^ Don't link at all+  | LinkBinary          -- ^ Link object code into a binary+  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both+                        --   bytecode and object code).+  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)+  | LinkStaticLib       -- ^ Link objects into a static lib+  | LinkMergedObj       -- ^ Link objects into a merged "GHCi object"+  deriving (Eq, Show)++isNoLink :: GhcLink -> Bool+isNoLink NoLink = True+isNoLink _      = False++-- | We accept flags which make packages visible, but how they select+-- the package varies; this data type reflects what selection criterion+-- is used.+data PackageArg =+      PackageArg String    -- ^ @-package@, by 'PackageName'+    | UnitIdArg Unit       -- ^ @-package-id@, by 'Unit'+  deriving (Eq, Show)++instance Outputable PackageArg where+    ppr (PackageArg pn) = text "package" <+> text pn+    ppr (UnitIdArg uid) = text "unit" <+> ppr uid++-- | Represents the renaming that may be associated with an exposed+-- package, e.g. the @rns@ part of @-package "foo (rns)"@.+--+-- Here are some example parsings of the package flags (where+-- a string literal is punned to be a 'ModuleName':+--+--      * @-package foo@ is @ModRenaming True []@+--      * @-package foo ()@ is @ModRenaming False []@+--      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@+--      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@+--      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@+data ModRenaming = ModRenaming {+    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?+    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope+                                               --   under name @n@.+  } deriving (Eq)+instance Outputable ModRenaming where+    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)++-- | Flags for manipulating the set of non-broken packages.+newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@+  deriving (Eq)++-- | Flags for manipulating package trust.+data TrustFlag+  = TrustPackage    String -- ^ @-trust@+  | DistrustPackage String -- ^ @-distrust@+  deriving (Eq)++-- | Flags for manipulating packages visibility.+data PackageFlag+  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@+  | HidePackage     String -- ^ @-hide-package@+  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged++data PackageDBFlag+  = PackageDB PkgDbRef+  | NoUserPackageDB+  | NoGlobalPackageDB+  | ClearPackageDBs+  deriving (Eq)++packageFlagsChanged :: DynFlags -> DynFlags -> Bool+packageFlagsChanged idflags1 idflags0 =+  packageFlags idflags1 /= packageFlags idflags0 ||+  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||+  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||+  trustFlags idflags1 /= trustFlags idflags0 ||+  packageDBFlags idflags1 /= packageDBFlags idflags0 ||+  packageGFlags idflags1 /= packageGFlags idflags0+ where+   packageGFlags dflags = map (`gopt` dflags)+     [ Opt_HideAllPackages+     , Opt_HideAllPluginPackages+     , Opt_AutoLinkPackages ]++instance Outputable PackageFlag where+    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)+    ppr (HidePackage str) = text "-hide-package" <+> text str++data DynLibLoader+  = Deployable+  | SystemDependent+  deriving Eq++data RtsOptsEnabled+  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly+  | RtsOptsAll+  deriving (Show)++-- | Are we building with @-fPIE@ or @-fPIC@ enabled?+positionIndependent :: DynFlags -> Bool+positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags++-- Note [-dynamic-too business]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic+-- objects in a single run of the compiler: the pipeline is the same down to+-- Core optimisation, then the backend (from Core to object code) is executed+-- twice.+--+-- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic+-- and dynamic loaded interfaces (#9176).+--+-- To make matters worse, we automatically enable -dynamic-too when some modules+-- need Template-Haskell and GHC is dynamically linked (cf+-- GHC.Driver.Pipeline.compileOne').+--+-- We used to try and fall back from a dynamic-too failure but this feature+-- didn't work as expected (#20446) so it was removed to simplify the+-- implementation and not obscure latent bugs.++data DynamicTooState+   = DT_Dont    -- ^ Don't try to build dynamic objects too+   | DT_OK      -- ^ Will still try to generate dynamic objects+   | DT_Dyn     -- ^ Currently generating dynamic objects (in the backend)+   deriving (Eq,Show,Ord)++dynamicTooState :: DynFlags -> DynamicTooState+dynamicTooState dflags+   | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont+   | dynamicNow dflags = DT_Dyn+   | otherwise = DT_OK++setDynamicNow :: DynFlags -> DynFlags+setDynamicNow dflags0 =+   dflags0+      { dynamicNow = True+      }++data PkgDbRef+  = GlobalPkgDb+  | UserPkgDb+  | PkgDbPath FilePath+  deriving Eq++++-- An argument to --reexported-module which can optionally specify a module renaming.+data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName+                                         , reexportTo   :: ModuleName+                                         }++instance Outputable ReexportedModule where+  ppr (ReexportedModule from to) =+    if from == to then ppr from+                  else ppr from <+> text "as" <+> ppr to++{- Note [Implicit include paths]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  The compile driver adds the path to the folder containing the source file being+  compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'+  that are used later to compute the interface file. Because of this,+  the flags fingerprint derived from these 'DynFlags' and recorded in the+  interface file will end up containing the absolute path to the source folder.++  Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)+  store the build artifacts produced by a build BA for reuse in subsequent builds.++  Embedding source paths in interface fingerprints will thwart these attempts and+  lead to unnecessary recompilations when the source paths in BA differ from the+  source paths in subsequent builds.+ -}++hasPprDebug :: DynFlags -> Bool+hasPprDebug = dopt Opt_D_ppr_debug++hasNoDebugOutput :: DynFlags -> Bool+hasNoDebugOutput = dopt Opt_D_no_debug_output++hasNoStateHack :: DynFlags -> Bool+hasNoStateHack = gopt Opt_G_NoStateHack++hasNoOptCoercion :: DynFlags -> Bool+hasNoOptCoercion = gopt Opt_G_NoOptCoercion++-- | Test whether a 'DumpFlag' is set+dopt :: DumpFlag -> DynFlags -> Bool+dopt = getDumpFlagFrom verbosity dumpFlags++-- | Set a 'DumpFlag'+dopt_set :: DynFlags -> DumpFlag -> DynFlags+dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) }++-- | Unset a 'DumpFlag'+dopt_unset :: DynFlags -> DumpFlag -> DynFlags+dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }++-- | Test whether a 'GeneralFlag' is set+--+-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`)+-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables+-- Opt_SplitSections.+--+gopt :: GeneralFlag -> DynFlags -> Bool+gopt Opt_PIC dflags+   | dynamicNow dflags = True+gopt Opt_ExternalDynamicRefs dflags+   | dynamicNow dflags = True+gopt Opt_SplitSections dflags+   | dynamicNow dflags = False+gopt f dflags = f `EnumSet.member` generalFlags dflags++-- | Set a 'GeneralFlag'+gopt_set :: DynFlags -> GeneralFlag -> DynFlags+gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) }++-- | Unset a 'GeneralFlag'+gopt_unset :: DynFlags -> GeneralFlag -> DynFlags+gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) }++-- | Test whether a 'WarningFlag' is set+wopt :: WarningFlag -> DynFlags -> Bool+wopt f dflags  = f `EnumSet.member` warningFlags dflags++-- | Set a 'WarningFlag'+wopt_set :: DynFlags -> WarningFlag -> DynFlags+wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) }++-- | Unset a 'WarningFlag'+wopt_unset :: DynFlags -> WarningFlag -> DynFlags+wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) }++-- | Test whether a 'WarningFlag' is set as fatal+wopt_fatal :: WarningFlag -> DynFlags -> Bool+wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags++-- | Mark a 'WarningFlag' as fatal (do not set the flag)+wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_set_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) }++-- | Mark a 'WarningFlag' as not fatal+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }+++-- | Enable all custom warning categories.+wopt_set_all_custom :: DynFlags -> DynFlags+wopt_set_all_custom dfs+    = dfs{ customWarningCategories = completeWarningCategorySet }++-- | Disable all custom warning categories.+wopt_unset_all_custom :: DynFlags -> DynFlags+wopt_unset_all_custom dfs+    = dfs{ customWarningCategories = emptyWarningCategorySet }++-- | Mark all custom warning categories as fatal (do not set the flags).+wopt_set_all_fatal_custom :: DynFlags -> DynFlags+wopt_set_all_fatal_custom dfs+    = dfs { fatalCustomWarningCategories = completeWarningCategorySet }++-- | Mark all custom warning categories as non-fatal.+wopt_unset_all_fatal_custom :: DynFlags -> DynFlags+wopt_unset_all_fatal_custom dfs+    = dfs { fatalCustomWarningCategories = emptyWarningCategorySet }++-- | Set a custom 'WarningCategory'+wopt_set_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_set_custom dfs f = dfs{ customWarningCategories = insertWarningCategorySet f (customWarningCategories dfs) }++-- | Unset a custom 'WarningCategory'+wopt_unset_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_unset_custom dfs f = dfs{ customWarningCategories = deleteWarningCategorySet f (customWarningCategories dfs) }++-- | Mark a custom 'WarningCategory' as fatal (do not set the flag)+wopt_set_fatal_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_set_fatal_custom dfs f+    = dfs { fatalCustomWarningCategories = insertWarningCategorySet f (fatalCustomWarningCategories dfs) }++-- | Mark a custom 'WarningCategory' as not fatal+wopt_unset_fatal_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_unset_fatal_custom dfs f+    = dfs { fatalCustomWarningCategories = deleteWarningCategorySet f (fatalCustomWarningCategories dfs) }++-- | Are there any custom warning categories enabled?+wopt_any_custom :: DynFlags -> Bool+wopt_any_custom dfs = not (nullWarningCategorySet (customWarningCategories dfs))+++-- | Test whether a 'LangExt.Extension' is set+xopt :: LangExt.Extension -> DynFlags -> Bool+xopt f dflags = f `EnumSet.member` extensionFlags dflags++-- | Set a 'LangExt.Extension'+xopt_set :: DynFlags -> LangExt.Extension -> DynFlags+xopt_set dfs f+    = let onoffs = On f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Unset a 'LangExt.Extension'+xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags+xopt_unset dfs f+    = let onoffs = Off f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Set or unset a 'LangExt.Extension', unless it has been explicitly+--   set or unset before.+xopt_set_unlessExplSpec+        :: LangExt.Extension+        -> (DynFlags -> LangExt.Extension -> DynFlags)+        -> DynFlags -> DynFlags+xopt_set_unlessExplSpec ext setUnset dflags =+    let referedExts = stripOnOff <$> extensions dflags+        stripOnOff (On x)  = x+        stripOnOff (Off x) = x+    in+        if ext `elem` referedExts then dflags else setUnset dflags ext++xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields+xopt_DuplicateRecordFields dfs+  | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields+  | otherwise                              = FieldLabel.NoDuplicateRecordFields++xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors+xopt_FieldSelectors dfs+  | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors+  | otherwise                       = FieldLabel.NoFieldSelectors++lang_set :: DynFlags -> Maybe Language -> DynFlags+lang_set dflags lang =+   dflags {+            language = lang,+            extensionFlags = flattenExtensionFlags lang (extensions dflags)+          }++defaultFlags :: Settings -> [GeneralFlag]+defaultFlags settings+-- See Note [Updating flag description in the User's Guide]+  = [ Opt_AutoLinkPackages,+      Opt_DiagnosticsShowCaret,+      Opt_EmbedManifest,+      Opt_FamAppCache,+      Opt_GenManifest,+      Opt_GhciHistory,+      Opt_GhciSandbox,+      Opt_GhciDoLoadTargets,+      Opt_HelpfulErrors,+      Opt_KeepHiFiles,+      Opt_KeepOFiles,+      Opt_OmitYields,+      Opt_PrintBindContents,+      Opt_ProfCountEntries,+      Opt_SharedImplib,+      Opt_SimplPreInlining,+      Opt_VersionMacros,+      Opt_RPath,+      Opt_DumpWithWays,+      Opt_CompactUnwind,+      Opt_ShowErrorContext,+      Opt_SuppressStgReps,+      Opt_UnoptimizedCoreForInterpreter,+      Opt_SpecialiseIncoherents,+      Opt_WriteSelfRecompInfo+    ]++    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]+             -- The default -O0 options++    -- Default floating flags (see Note [RHS Floating])+    ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ]++    ++ default_PIC platform++    ++ validHoleFitDefaults++    where platform = sTargetPlatform settings++-- | These are the default settings for the display and sorting of valid hole+--  fits in typed-hole error messages. See Note [Valid hole fits include ...]+ -- in the "GHC.Tc.Errors.Hole" module.+validHoleFitDefaults :: [GeneralFlag]+validHoleFitDefaults+  =  [ Opt_ShowTypeAppOfHoleFits+     , Opt_ShowTypeOfHoleFits+     , Opt_ShowProvOfHoleFits+     , Opt_ShowMatchesOfHoleFits+     , Opt_ShowValidHoleFits+     , Opt_SortValidHoleFits+     , Opt_SortBySizeHoleFits+     , Opt_ShowHoleConstraints ]++-- Note [When is StarIsType enabled]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The StarIsType extension determines whether to treat '*' as a regular type+-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType+-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is+-- enabled.+--+-- Programs that use TypeOperators might expect to repurpose '*' for+-- multiplication or another binary operation, but making TypeOperators imply+-- NoStarIsType caused too much breakage on Hackage.+--++--+-- Note [Documenting optimisation flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of flags enabled for particular optimisation levels+-- please remember to update the User's Guide. The relevant file is:+--+--   docs/users_guide/using-optimisation.rst+--+-- Make sure to note whether a flag is implied by -O0, -O or -O2.++optLevelFlags :: [([Int], GeneralFlag)]+-- Default settings of flags, before any command-line overrides+optLevelFlags -- see Note [Documenting optimisation flags]+  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)+    , ([1,2],   Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep]+    , ([0,1,2], Opt_DoEtaReduction)          -- See Note [Eta-reduction in -O0]+    , ([0,1,2], Opt_ProfManualCcs )+    , ([2], Opt_DictsStrict)++    , ([0],     Opt_IgnoreInterfacePragmas)+    , ([0],     Opt_OmitInterfacePragmas)++    , ([1,2],   Opt_CoreConstantFolding)++    , ([1,2],   Opt_CallArity)+    , ([1,2],   Opt_Exitification)+    , ([1,2],   Opt_CaseMerge)+    , ([1,2],   Opt_CaseFolding)+    , ([1,2],   Opt_CmmElimCommonBlocks)+    , ([2],     Opt_AsmShortcutting)+    , ([1,2],   Opt_CmmSink)+    , ([1,2],   Opt_CmmStaticPred)+    , ([1,2],   Opt_CSE)+    , ([1,2],   Opt_StgCSE)+    , ([2],     Opt_StgLiftLams)+    , ([1,2],   Opt_CmmControlFlow)++    , ([1,2],   Opt_EnableRewriteRules)+          -- Off for -O0.   Otherwise we desugar list literals+          -- to 'build' but don't run the simplifier passes that+          -- would rewrite them back to cons cells!  This seems+          -- silly, and matters for the GHCi debugger.++    , ([1,2],   Opt_FloatIn)+    , ([1,2],   Opt_FullLaziness)+    , ([1,2],   Opt_IgnoreAsserts)+    , ([1,2],   Opt_Loopification)+    , ([1,2],   Opt_CfgBlocklayout)      -- Experimental++    , ([1,2],   Opt_Specialise)+    , ([1,2],   Opt_CrossModuleSpecialise)+    , ([1,2],   Opt_InlineGenerics)+    , ([1,2],   Opt_Strictness)+    , ([1,2],   Opt_UnboxSmallStrictFields)+    , ([1,2],   Opt_CprAnal)+    , ([1,2],   Opt_WorkerWrapper)+    , ([1,2],   Opt_SolveConstantDicts)+    , ([1,2],   Opt_NumConstantFolding)++    , ([2],     Opt_LiberateCase)+    , ([2],     Opt_SpecConstr)+    , ([2],     Opt_FastPAPCalls)+--  , ([2],     Opt_RegsGraph)+--   RegsGraph suffers performance regression. See #7679+--  , ([2],     Opt_StaticArgumentTransformation)+--   Static Argument Transformation needs investigation. See #9374+    , ([0,1,2], Opt_SpecEval)+    , ([],      Opt_SpecEvalDictFun)+    ]+++default_PIC :: Platform -> [GeneralFlag]+default_PIC platform =+  case (platformOS platform, platformArch platform) of+    -- Darwin always requires PIC.  Especially on more recent macOS releases+    -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses+    -- while we could work around this on x86_64 (like WINE does), we won't be+    -- able on aarch64, where this is enforced.+    (OSDarwin,  ArchX86_64)  -> [Opt_PIC]+    -- For AArch64, we need to always have PIC enabled.  The relocation model+    -- on AArch64 does not permit arbitrary relocations.  Under ASLR, we can't+    -- control much how far apart symbols are in memory for our in-memory static+    -- linker;  and thus need to ensure we get sufficiently capable relocations.+    -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top+    -- of that.  Subsequently we expect all code on aarch64/linux (and macOS) to+    -- be built with -fPIC.+    (OSDarwin,  ArchAArch64) -> [Opt_PIC]+    (OSLinux,   ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchARM {})  -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchRISCV64 {}) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSOpenBSD, ArchX86_64)  -> [Opt_PIC] -- Due to PIE support in+                                         -- OpenBSD since 5.3 release+                                         -- (1 May 2013) we need to+                                         -- always generate PIC. See+                                         -- #10597 for more+                                         -- information.+    (OSLinux,   ArchLoongArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    _                      -> []++-- | The language extensions implied by the various language variants.+-- When updating this be sure to update the flag documentation in+-- @docs/users_guide/exts@.+languageExtensions :: Maybe Language -> [LangExt.Extension]++-- Nothing: the default case+languageExtensions Nothing = languageExtensions (Just defaultLanguage)++languageExtensions (Just Haskell98)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.NPlusKPatterns,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.FieldSelectors,+       LangExt.NondecreasingIndentation,+           -- strictly speaking non-standard, but we always had this+           -- on implicitly before the option was added in 7.1, and+           -- turning it off breaks code, so we're keeping it on for+           -- backwards compatibility.  Cabal uses -XHaskell98 by+           -- default unless you specify another language.+       LangExt.DeepSubsumption,+       -- Non-standard but enabled for backwards compatability (see GHC proposal #511)+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+      ]++languageExtensions (Just Haskell2010)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       LangExt.DeepSubsumption,+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+       ]++languageExtensions (Just GHC2021)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.MonomorphismRestriction,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       LangExt.ListTuplePuns,+       -- Now the new extensions (not in Haskell2010)+       LangExt.BangPatterns,+       LangExt.BinaryLiterals,+       LangExt.ConstrainedClassMethods,+       LangExt.ConstraintKinds,+       LangExt.DeriveDataTypeable,+       LangExt.DeriveFoldable,+       LangExt.DeriveFunctor,+       LangExt.DeriveGeneric,+       LangExt.DeriveLift,+       LangExt.DeriveTraversable,+       LangExt.EmptyCase,+       LangExt.EmptyDataDeriving,+       LangExt.ExistentialQuantification,+       LangExt.ExplicitForAll,+       LangExt.FlexibleContexts,+       LangExt.FlexibleInstances,+       LangExt.GADTSyntax,+       LangExt.GeneralizedNewtypeDeriving,+       LangExt.HexFloatLiterals,+       LangExt.ImportQualifiedPost,+       LangExt.InstanceSigs,+       LangExt.KindSignatures,+       LangExt.MultiParamTypeClasses,+       LangExt.NamedFieldPuns,+       LangExt.NamedWildCards,+       LangExt.NumericUnderscores,+       LangExt.PolyKinds,+       LangExt.PostfixOperators,+       LangExt.RankNTypes,+       LangExt.ScopedTypeVariables,+       LangExt.StandaloneDeriving,+       LangExt.StandaloneKindSignatures,+       LangExt.TupleSections,+       LangExt.TypeApplications,+       LangExt.TypeOperators,+       LangExt.TypeSynonymInstances,+       LangExt.ImplicitStagePersistence+       ]++languageExtensions (Just GHC2024)+    = languageExtensions (Just GHC2021) +++      [LangExt.DataKinds,+       LangExt.DerivingStrategies,+       LangExt.DisambiguateRecordFields,+       LangExt.ExplicitNamespaces,+       LangExt.GADTs,+       LangExt.MonoLocalBinds,+       LangExt.LambdaCase,+       LangExt.RoleAnnotations]++ways :: DynFlags -> Ways+ways dflags+   | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)+   | otherwise         = targetWays_ dflags++-- | Get target profile+targetProfile :: DynFlags -> Profile+targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)++--+-- System tool settings and locations++programName :: DynFlags -> String+programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags+projectVersion :: DynFlags -> String+projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags)+ghcUsagePath          :: DynFlags -> FilePath+ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags+ghciUsagePath         :: DynFlags -> FilePath+ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags+topDir                :: DynFlags -> FilePath+topDir dflags = fileSettings_topDir $ fileSettings dflags+toolDir               :: DynFlags -> Maybe FilePath+toolDir dflags = fileSettings_toolDir $ fileSettings dflags+extraGccViaCFlags     :: DynFlags -> [String]+extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags+globalPackageDatabasePath   :: DynFlags -> FilePath+globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags++-- | The directory for this version of ghc in the user's app directory+-- The appdir used to be in ~/.ghc but to respect the XDG specification+-- we want to move it under $XDG_DATA_HOME/+-- However, old tooling (like cabal) might still write package environments+-- to the old directory, so we prefer that if a subdirectory of ~/.ghc+-- with the correct target and GHC version suffix exists.+--+-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that+-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR+--+-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version+versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath+versionedAppDir appname platform = do+  -- Make sure we handle the case the HOME isn't set (see #11678)+  -- We need to fallback to the old scheme if the subdirectory exists.+  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))+       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/+       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/+       ]+  where+    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case+      True -> pure dir+      False -> MaybeT (pure Nothing)++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+initSDocContext :: DynFlags -> PprStyle -> SDocContext+initSDocContext dflags style = SDC+  { sdocStyle                       = style+  , sdocColScheme                   = colScheme dflags+  , sdocLastColour                  = Col.colReset+  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)+  , sdocDefaultDepth                = pprUserLength dflags+  , sdocLineLength                  = pprCols dflags+  , sdocCanUseUnicode               = useUnicode dflags+  , sdocPrintErrIndexLinks          = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags)+  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags+  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags+  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags+  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags+  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags+  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags+  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags+  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags+  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags+  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags+  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags+  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags+  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags+  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags+  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags+  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags+  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags+  , sdocSuppressCoercionTypes       = gopt Opt_SuppressCoercionTypes dflags+  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags+  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags+  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags+  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags+  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags+  , sdocSuppressStgReps             = gopt Opt_SuppressStgReps dflags+  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags+  , sdocStarIsType                  = xopt LangExt.StarIsType dflags+  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags+  , sdocListTuplePuns               = xopt LangExt.ListTuplePuns dflags+  , sdocPrintTypeAbbreviations      = True+  , sdocUnitIdForUser               = ftext+  }++-- | Initialize the pretty-printing options using the default user style+initDefaultSDocContext :: DynFlags -> SDocContext+initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle++initPromotionTickContext :: DynFlags -> PromotionTickContext+initPromotionTickContext dflags =+  PromTickCtx {+    ptcListTuplePuns = xopt LangExt.ListTuplePuns dflags,+    ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags+  }++-- -----------------------------------------------------------------------------+-- 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++isSse4_2Enabled :: DynFlags -> Bool+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42++isAvxEnabled :: DynFlags -> Bool+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags++isAvx2Enabled :: DynFlags -> Bool+isAvx2Enabled dflags = avx2 dflags || avx512f dflags++isAvx512cdEnabled :: DynFlags -> Bool+isAvx512cdEnabled dflags = avx512cd dflags++isAvx512erEnabled :: DynFlags -> Bool+isAvx512erEnabled dflags = avx512er dflags++isAvx512fEnabled :: DynFlags -> Bool+isAvx512fEnabled dflags = avx512f dflags++isAvx512pfEnabled :: DynFlags -> Bool+isAvx512pfEnabled dflags = avx512pf dflags++isFmaEnabled :: DynFlags -> Bool+isFmaEnabled dflags = fma dflags++-- -----------------------------------------------------------------------------+-- BMI2++isBmiEnabled :: DynFlags -> Bool+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI1+    ArchX86    -> bmiVersion dflags >= Just BMI1+    _          -> False++isBmi2Enabled :: DynFlags -> Bool+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI2+    ArchX86    -> bmiVersion dflags >= Just BMI2+    _          -> False
compiler/GHC/Driver/Env.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-}- module GHC.Driver.Env    ( Hsc(..)    , HscEnv (..)+   , hsc_mod_graph+   , setModuleGraph    , hscUpdateFlags    , hscSetFlags    , hsc_home_unit@@ -14,8 +15,7 @@    , hsc_all_home_unit_ids    , hscUpdateLoggerFlags    , hscUpdateHUG-   , hscUpdateHPT_lazy-   , hscUpdateHPT+   , hscInsertHPT    , hscSetActiveHomeUnit    , hscSetActiveUnitId    , hscActiveUnitId@@ -25,24 +25,26 @@    , runInteractiveHsc    , hscEPS    , hscInterp-   , hptCompleteSigs-   , hptAllInstances-   , hptInstancesBelow-   , hptAnns-   , hptAllThings-   , hptSomeThingsBelowUs-   , hptRules    , prepareAnnotations    , discardIC    , lookupType    , lookupIfaceByModule+   , lookupIfaceByModuleHsc    , mainModIs++   , hugRulesBelow+   , hugInstancesBelow+   , hugAnnsBelow+   , hugCompleteSigsBelow++    -- * Legacy API+   , hscUpdateHPT    ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Driver.Config.Logger (initLogFlags)@@ -57,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@@ -82,16 +80,19 @@ 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 Data.Set (Set)-import GHC.Unit.Module.Graph-import Data.List (sort)-import qualified Data.Map as Map  runHsc :: HscEnv -> Hsc a -> IO a-runHsc hsc_env (Hsc hsc) = do-    (a, w) <- hsc hsc_env emptyMessages+runHsc hsc_env hsc = do+    (a, w) <- runHsc' hsc_env hsc     let dflags = hsc_dflags hsc_env     let !diag_opts = initDiagOpts dflags         !print_config = initPrintConfig dflags@@ -114,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@@ -131,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]@@ -170,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`).   -}@@ -221,94 +221,68 @@ hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -hptCompleteSigs :: HscEnv -> [CompleteMatch]-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----- | 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--hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]-hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)-                                (hugElts (hsc_HUG hsc_env))---- | 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.-hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid-hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <- modules_below]-  where-    td_map = mgTransDeps (hsc_mod_graph hsc_env)--    modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map--    filtered_mods = Set.fromDistinctAscList . filter_mods . sort+--------------------------------------------------------------------------------+-- * Queries on Transitive Closure+-------------------------------------------------------------------------------- -    -- 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+-- | 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 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 +-- | 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 (hptModulesBelow hsc_env 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@@ -318,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 (hptModulesBelow hsc_env uid 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@@ -343,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@@ -359,20 +332,23 @@ lookupType hsc_env name = do    eps <- liftIO $ hscEPS hsc_env    let pte = eps_PTE eps-       hpt = hsc_HUG hsc_env+   lookupTypeInPTE hsc_env pte name -       mod = assertPpr (isExternalName name) (ppr name) $-             if isHoleName name-               then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))-               else nameModule name+lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing)+lookupTypeInPTE hsc_env pte name = ty+  where+    hpt = hsc_HUG hsc_env+    mod = assertPpr (isExternalName name) (ppr name) $+          if isHoleName name+            then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))+            else nameModule name -       !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-   pure ty+    ty = if isOneShot (ghcMode (hsc_dflags hsc_env))+            -- in one-shot, we don't use the HPT+            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@@ -380,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?@@ -392,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 --@@ -454,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
@@ -7,7 +7,7 @@  import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks-import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags )+import GHC.Driver.DynFlags ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) import GHC.Driver.LlvmConfigCache (LlvmConfigCache)  import GHC.Prelude@@ -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
@@ -2,54 +2,41 @@ module GHC.Driver.Errors (     printOrThrowDiagnostics   , printMessages-  , handleFlagWarnings   , mkDriverPsHeaderMessage   ) where  import GHC.Driver.Errors.Types-import GHC.Data.Bag import GHC.Prelude-import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error-import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle )+import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger-import qualified GHC.Driver.CmdLine as CmdLine -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 }-                in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $-                   withPprStyle style (messageWithHints ctx dia)-              | MsgEnvelope { errMsgSpan       = s,-                              errMsgDiagnostic = dia,-                              errMsgSeverity   = sev,-                              errMsgContext    = name_ppr_ctx }+                in (if log_diags_as_json+                    then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg+                    else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $+                  updSDocContext (\_ -> ctx) (messageWithHints dia))+              | msg@MsgEnvelope { errMsgSpan       = s,+                                  errMsgDiagnostic = dia,+                                  errMsgSeverity   = sev,+                                  errMsgReason     = reason,+                                  errMsgContext    = name_ppr_ctx }                   <- sortMsgBag (Just opts) (getMessages msgs) ]   where-    messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc-    messageWithHints ctx e =-      let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e+    messageWithHints :: a -> SDoc+    messageWithHints e =+      let main_msg = formatBulleted $ diagnosticMessage msg_opts e           in case diagnosticHints e of                []  -> main_msg                [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)                hs  -> main_msg $$ hang (text "Suggested fixes:") 2-                                       (formatBulleted ctx . mkDecorated . map ppr $ hs)--handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO ()-handleFlagWarnings logger print_config opts warns = do-  let -- It would be nicer if warns :: [Located SDoc], but that-      -- has circular import problems.-      bag = listToBag [ mkPlainMsgEnvelope opts loc $-                        GhcDriverMessage $-                        DriverUnknownMessage $-                        UnknownDiagnostic $-                        mkPlainDiagnostic reason noHints $ text warn-                      | CmdLine.Warn reason (L loc warn) <- warns ]--  printOrThrowDiagnostics logger print_config opts (mkMessages bag)+                                       (formatBulleted  $ mkDecorated . map ppr $ hs)+    log_diags_as_json = log_diagnostics_as_json (logFlags logger)  -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise.
compiler/GHC/Driver/Errors/Ppr.hs view
@@ -13,15 +13,16 @@  import GHC.Driver.Errors.Types import GHC.Driver.Flags-import GHC.Driver.Session-import GHC.HsToCore.Errors.Ppr ()-import GHC.Parser.Errors.Ppr ()-import GHC.Tc.Errors.Ppr ()+import GHC.Driver.DynFlags+import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage+import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage import GHC.Types.Error-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Unit.Types import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Unit.Module+import GHC.Unit.Module.Graph import GHC.Unit.State import GHC.Types.Hint import GHC.Types.SrcLoc@@ -30,6 +31,10 @@ import Language.Haskell.Syntax.Decls (RuleDecl(..)) import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage)+import GHC.Iface.Errors.Types+import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage+import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage+import GHC.CmmToLlvm.Version (llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound)  -- -- Suggestions@@ -40,12 +45,14 @@ suggestInstantiatedWith pi_mod_name insts =   [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ] -instance Diagnostic GhcMessage where-  type DiagnosticOpts GhcMessage = GhcMessageOpts-  defaultDiagnosticOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage)+instance HasDefaultDiagnosticOpts GhcMessageOpts where+  defaultOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage)                                          (defaultDiagnosticOpts @TcRnMessage)                                          (defaultDiagnosticOpts @DsMessage)                                          (defaultDiagnosticOpts @DriverMessage)++instance Diagnostic GhcMessage where+  type DiagnosticOpts GhcMessage = GhcMessageOpts   diagnosticMessage opts = \case     GhcPsMessage m       -> diagnosticMessage (psMessageOpts opts) m@@ -55,8 +62,8 @@       -> diagnosticMessage (dsMessageOpts opts) m     GhcDriverMessage m       -> diagnosticMessage (driverMessageOpts opts) m-    GhcUnknownMessage (UnknownDiagnostic @e m)-      -> diagnosticMessage (defaultDiagnosticOpts @e) m+    GhcUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m    diagnosticReason = \case     GhcPsMessage m@@ -82,14 +89,16 @@     GhcUnknownMessage m       -> diagnosticHints m -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC +instance HasDefaultDiagnosticOpts DriverMessageOpts where+  defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)+ instance Diagnostic DriverMessage where   type DiagnosticOpts DriverMessage = DriverMessageOpts-  defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage)   diagnosticMessage opts = \case-    DriverUnknownMessage (UnknownDiagnostic @e m)-      -> diagnosticMessage (defaultDiagnosticOpts @e) m+    DriverUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m     DriverPsHeaderMessage m       -> diagnosticMessage (psDiagnosticOpts opts) m     DriverMissingHomeModules uid missing buildingCabalPackage@@ -146,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 $@@ -218,7 +227,62 @@       -> mkSimpleDecorated $ vcat ([text "Home units are not closed."                                   , text "It is necessary to also load the following units:" ]                                   ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)+    DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason +    DriverInconsistentDynFlags msg+      -> mkSimpleDecorated $ text msg+    DriverSafeHaskellIgnoredExtension ext+      -> let arg = text "-X" <> ppr ext+         in mkSimpleDecorated $ arg <+> text "is not allowed in Safe Haskell; ignoring" <+> arg+    DriverPackageTrustIgnored+      -> mkSimpleDecorated $ text "-fpackage-trust ignored; must be specified with a Safe Haskell flag"++    DriverUnrecognisedFlag arg+      -> mkSimpleDecorated $ text $ "unrecognised warning flag: -" ++ arg+    DriverDeprecatedFlag arg msg+      -> mkSimpleDecorated $ text $ arg ++ " is deprecated: " ++ msg+    DriverModuleGraphCycle path+      -> mkSimpleDecorated $ vcat+        [ text "Module graph contains a cycle:"+        , nest 2 (show_path path) ]+      where+        show_path :: [ModuleGraphNode] -> SDoc+        show_path []  = panic "show_path"+        show_path [m] = ppr_node m <+> text "imports itself"+        show_path (m1:m2:ms) = vcat ( nest 14 (ppr_node m1)+                                    : nest 6 (text "imports" <+> ppr_node m2)+                                    : go ms )+           where+             go []     = [text "which imports" <+> ppr_node m1]+             go (m:ms) = (text "which imports" <+> ppr_node m) : go ms++        ppr_node :: ModuleGraphNode -> SDoc+        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 :: 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:"+             , nest 2 $ ppr node ]+    DriverNoConfiguredLLVMToolchain ->+      mkSimpleDecorated $+        text "GHC was not configured with a supported LLVM toolchain" $$+          text ("Make sure you have installed LLVM between ["+            ++ llvmVersionStr supportedLlvmVersionLowerBound+            ++ " and "+            ++ llvmVersionStr supportedLlvmVersionUpperBound+            ++ ") and reinstall GHC to ensure -fllvm works")+   diagnosticReason = \case     DriverUnknownMessage m       -> diagnosticReason m@@ -272,6 +336,23 @@       -> ErrorWithoutFlag     DriverHomePackagesNotClosed {}       -> ErrorWithoutFlag+    DriverInterfaceError reason -> diagnosticReason reason+    DriverInconsistentDynFlags {}+      -> WarningWithFlag Opt_WarnInconsistentFlags+    DriverSafeHaskellIgnoredExtension {}+      -> WarningWithoutFlag+    DriverPackageTrustIgnored {}+      -> WarningWithoutFlag+    DriverUnrecognisedFlag {}+      -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags+    DriverDeprecatedFlag {}+      -> WarningWithFlag Opt_WarnDeprecatedFlags+    DriverModuleGraphCycle {}+      -> ErrorWithoutFlag+    DriverInstantiationNodeInDependencyGeneration {}+      -> ErrorWithoutFlag+    DriverNoConfiguredLLVMToolchain+      -> WarningWithoutFlag    diagnosticHints = \case     DriverUnknownMessage m@@ -328,5 +409,22 @@       -> noHints     DriverHomePackagesNotClosed {}       -> noHints+    DriverInterfaceError reason -> diagnosticHints reason+    DriverInconsistentDynFlags {}+      -> noHints+    DriverSafeHaskellIgnoredExtension {}+      -> noHints+    DriverPackageTrustIgnored {}+      -> noHints+    DriverUnrecognisedFlag {}+      -> noHints+    DriverDeprecatedFlag {}+      -> noHints+    DriverModuleGraphCycle {}+      -> noHints+    DriverInstantiationNodeInDependencyGeneration {}+      -> noHints+    DriverNoConfiguredLLVMToolchain+      -> noHints -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC
compiler/GHC/Driver/Errors/Types.hs view
@@ -4,11 +4,11 @@  module GHC.Driver.Errors.Types (     GhcMessage(..)+  , AnyGhcDiagnostic   , GhcMessageOpts(..)   , DriverMessage(..)   , DriverMessageOpts(..)   , DriverMessages, PsMessage(PsHeaderMessage)-  , BuildingCabalPackage(..)   , WarningMessages   , ErrorMessages   , WarnMsg@@ -25,20 +25,25 @@ import Data.Bifunctor import Data.Typeable -import GHC.Driver.Session+import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt, ReexportedModule)+import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage)) import GHC.Types.Error import GHC.Unit.Module+import GHC.Unit.Module.Graph import GHC.Unit.State  import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) )-import GHC.Tc.Errors.Types     ( TcRnMessage ) import GHC.HsToCore.Errors.Types ( DsMessage ) import GHC.Hs.Extension          (GhcTc)  import Language.Haskell.Syntax.Decls (RuleDecl)+import qualified GHC.LanguageExtensions as LangExt  import GHC.Generics ( Generic ) +import GHC.Tc.Errors.Types+import GHC.Iface.Errors.Types+ -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage@@ -90,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 -> GhcMessage+  GhcUnknownMessage :: (UnknownDiagnosticFor GhcMessage) -> GhcMessage    deriving Generic +type AnyGhcDiagnostic = UnknownDiagnosticFor GhcMessage  data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage                                      , tcMessageOpts :: DiagnosticOpts TcRnMessage@@ -107,8 +113,8 @@ -- 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 = GhcUnknownMessage . UnknownDiagnostic+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 -- the result of 'IO (Messages TcRnMessage, a)'.@@ -126,7 +132,7 @@ -- | A message from the driver. data DriverMessage where   -- | Simply wraps a generic 'Diagnostic' message @a@.-  DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage+  DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage    -- | A parse error in parsing a Haskell file header during dependency   -- analysis@@ -148,7 +154,7 @@   {-| DriverUnknown is a warning that arises when a user tries to       reexport a module which isn't part of that unit.   -}-  DriverUnknownReexportedModules :: UnitId -> [ModuleName] -> DriverMessage+  DriverUnknownReexportedModules :: UnitId -> [ReexportedModule] -> DriverMessage    {-| DriverUnknownHiddenModules is a warning that arises when a user tries to       hide a module which isn't part of that unit.@@ -181,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@@ -368,17 +374,50 @@    DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage +  DriverInterfaceError :: !IfaceMessage -> DriverMessage++  -- TODO: Add structure messages rather than a String+  DriverInconsistentDynFlags :: String -> DriverMessage++  DriverSafeHaskellIgnoredExtension :: !LangExt.Extension -> DriverMessage++  DriverPackageTrustIgnored :: DriverMessage++  DriverUnrecognisedFlag :: String -> DriverMessage++  DriverDeprecatedFlag :: String -> String -> DriverMessage++  {-| DriverModuleGraphCycle is an error that occurs if the module graph+       contains cyclic imports.++  Test cases:+    tests/backpack/should_fail/bkpfail51+    tests/driver/T20459+    tests/driver/T24196/T24196+    tests/driver/T24275/T24275++  -}+  DriverModuleGraphCycle :: [ModuleGraphNode] -> DriverMessage++  {- | DriverInstantiationNodeInDependencyGeneration is an error that occurs+       if the module graph used for dependency generation contains+       Backpack 'InstantiationNode's. -}+  DriverInstantiationNodeInDependencyGeneration :: InstantiatedUnit -> DriverMessage++  {-| DriverNoConfiguredLLVMToolchain is an error that occurs if there is no+     LLVM toolchain configured but -fllvm is passed as an option to the compiler.++    Test cases: None.++  -}+  DriverNoConfiguredLLVMToolchain :: DriverMessage+ deriving instance Generic DriverMessage  data DriverMessageOpts =-  DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage }+  DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage+                    , ifaceDiagnosticOpts :: DiagnosticOpts IfaceMessage } --- | Pass to a 'DriverMessage' the information whether or not the--- '-fbuilding-cabal-package' flag is set.-data BuildingCabalPackage-  = YesBuildingCabalPackage-  | NoBuildingCabalPackage-  deriving Eq  -- | Checks if we are building a cabal package by consulting the 'DynFlags'. checkBuildingCabalPackage :: DynFlags -> BuildingCabalPackage
compiler/GHC/Driver/Flags.hs view
@@ -1,24 +1,50 @@+{-# LANGUAGE LambdaCase #-}+ module GHC.Driver.Flags    ( DumpFlag(..)    , getDumpFlagFrom    , enabledIfVerbose    , GeneralFlag(..)    , Language(..)+   , defaultLanguage    , optimisationFlags    , codeGenFlags     -- * Warnings+   , WarningGroup(..)+   , warningGroupName+   , warningGroupFlags+   , warningGroupIncludesExtendedWarnings    , WarningFlag(..)    , warnFlagNames    , warningGroups    , warningHierarchies    , smallestWarningGroups+   , smallestWarningGroupsForCategory+    , standardWarnings    , minusWOpts    , minusWallOpts    , minusWeverythingOpts    , minusWcompatOpts    , unusedBindsFlags++   , OnOff(..)+   , TurnOnFlag+   , turnOn+   , turnOff+   , impliedXFlags+   , validHoleFitsImpliedGFlags+   , impliedGFlags+   , impliedOffGFlags+   , glasgowExtsFlags++   , ExtensionDeprecation(..)+   , Deprecation(..)+   , extensionDeprecation+   , deprecation+   , extensionNames+   , extensionName    ) where @@ -32,9 +58,16 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) -data Language = Haskell98 | Haskell2010 | GHC2021+import qualified GHC.LanguageExtensions as LangExt++data Language = Haskell98 | Haskell2010 | GHC2021 | GHC2024    deriving (Eq, Enum, Show, Bounded) +-- | The default Language is used if one is not specified explicitly, by both+-- GHC and GHCi.+defaultLanguage :: Language+defaultLanguage = GHC2021+ instance Outputable Language where     ppr = text . show @@ -43,11 +76,353 @@   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+turnOff :: TurnOnFlag; turnOff = False++data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord)++data ExtensionDeprecation+  = ExtensionNotDeprecated+  | ExtensionDeprecatedFor [LangExt.Extension]+  | ExtensionFlagDeprecatedCond TurnOnFlag String+  | ExtensionFlagDeprecated String+  deriving Eq++-- | Always returns 'Deprecated' even when the flag is+-- only conditionally deprecated.+deprecation :: ExtensionDeprecation -> Deprecation+deprecation ExtensionNotDeprecated = NotDeprecated+deprecation _ = Deprecated++extensionDeprecation :: LangExt.Extension -> ExtensionDeprecation+extensionDeprecation = \case+  LangExt.TypeInType           -> ExtensionDeprecatedFor [LangExt.DataKinds, LangExt.PolyKinds]+  LangExt.NullaryTypeClasses   -> ExtensionDeprecatedFor [LangExt.MultiParamTypeClasses]+  LangExt.RelaxedPolyRec       -> ExtensionFlagDeprecatedCond turnOff+                                    "You can't turn off RelaxedPolyRec any more"+  LangExt.DatatypeContexts     -> ExtensionFlagDeprecatedCond turnOn+                                    "It was widely considered a misfeature, and has been removed from the Haskell language."+  LangExt.AutoDeriveTypeable   -> ExtensionFlagDeprecatedCond turnOn+                                    "Typeable instances are created automatically for all types since GHC 8.2."+  LangExt.OverlappingInstances -> ExtensionFlagDeprecated+                                    "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS"+  _                            -> ExtensionNotDeprecated+++extensionName :: LangExt.Extension -> String+extensionName = \case+  LangExt.Cpp -> "CPP"+  LangExt.OverlappingInstances -> "OverlappingInstances"+  LangExt.UndecidableInstances -> "UndecidableInstances"+  LangExt.IncoherentInstances -> "IncoherentInstances"+  LangExt.UndecidableSuperClasses -> "UndecidableSuperClasses"+  LangExt.MonomorphismRestriction -> "MonomorphismRestriction"+  LangExt.MonoLocalBinds -> "MonoLocalBinds"+  LangExt.DeepSubsumption -> "DeepSubsumption"+  LangExt.RelaxedPolyRec -> "RelaxedPolyRec"           -- Deprecated+  LangExt.ExtendedDefaultRules -> "ExtendedDefaultRules"     -- Use GHC's extended rules for defaulting+  LangExt.NamedDefaults -> "NamedDefaults"+  LangExt.ForeignFunctionInterface -> "ForeignFunctionInterface"+  LangExt.UnliftedFFITypes -> "UnliftedFFITypes"+  LangExt.InterruptibleFFI -> "InterruptibleFFI"+  LangExt.CApiFFI -> "CApiFFI"+  LangExt.GHCForeignImportPrim -> "GHCForeignImportPrim"+  LangExt.JavaScriptFFI -> "JavaScriptFFI"+  LangExt.ParallelArrays -> "ParallelArrays"           -- Syntactic support for parallel arrays+  LangExt.Arrows -> "Arrows"                   -- Arrow-notation syntax+  LangExt.TemplateHaskell -> "TemplateHaskell"+  LangExt.TemplateHaskellQuotes -> "TemplateHaskellQuotes"    -- subset of TH supported by stage1, no splice+  LangExt.QualifiedDo -> "QualifiedDo"+  LangExt.QuasiQuotes -> "QuasiQuotes"+  LangExt.ImplicitParams -> "ImplicitParams"+  LangExt.ImplicitPrelude -> "ImplicitPrelude"+  LangExt.ScopedTypeVariables -> "ScopedTypeVariables"+  LangExt.AllowAmbiguousTypes -> "AllowAmbiguousTypes"+  LangExt.UnboxedTuples -> "UnboxedTuples"+  LangExt.UnboxedSums -> "UnboxedSums"+  LangExt.UnliftedNewtypes -> "UnliftedNewtypes"+  LangExt.UnliftedDatatypes -> "UnliftedDatatypes"+  LangExt.BangPatterns -> "BangPatterns"+  LangExt.TypeFamilies -> "TypeFamilies"+  LangExt.TypeFamilyDependencies -> "TypeFamilyDependencies"+  LangExt.TypeInType -> "TypeInType"               -- Deprecated+  LangExt.OverloadedStrings -> "OverloadedStrings"+  LangExt.OverloadedLists -> "OverloadedLists"+  LangExt.NumDecimals -> "NumDecimals"+  LangExt.OrPatterns -> "OrPatterns"+  LangExt.DisambiguateRecordFields -> "DisambiguateRecordFields"+  LangExt.RecordWildCards -> "RecordWildCards"+  LangExt.NamedFieldPuns -> "NamedFieldPuns"+  LangExt.ViewPatterns -> "ViewPatterns"+  LangExt.GADTs -> "GADTs"+  LangExt.GADTSyntax -> "GADTSyntax"+  LangExt.NPlusKPatterns -> "NPlusKPatterns"+  LangExt.DoAndIfThenElse -> "DoAndIfThenElse"+  LangExt.BlockArguments -> "BlockArguments"+  LangExt.RebindableSyntax -> "RebindableSyntax"+  LangExt.ConstraintKinds -> "ConstraintKinds"+  LangExt.PolyKinds -> "PolyKinds"                -- Kind polymorphism+  LangExt.DataKinds -> "DataKinds"                -- Datatype promotion+  LangExt.TypeData -> "TypeData"                 -- allow @type data@ definitions+  LangExt.InstanceSigs -> "InstanceSigs"+  LangExt.ApplicativeDo -> "ApplicativeDo"+  LangExt.LinearTypes -> "LinearTypes"+  LangExt.RequiredTypeArguments -> "RequiredTypeArguments"    -- Visible forall (VDQ) in types of terms+  LangExt.StandaloneDeriving -> "StandaloneDeriving"+  LangExt.DeriveDataTypeable -> "DeriveDataTypeable"+  LangExt.AutoDeriveTypeable -> "AutoDeriveTypeable"       -- Automatic derivation of Typeable+  LangExt.DeriveFunctor -> "DeriveFunctor"+  LangExt.DeriveTraversable -> "DeriveTraversable"+  LangExt.DeriveFoldable -> "DeriveFoldable"+  LangExt.DeriveGeneric -> "DeriveGeneric"            -- Allow deriving Generic/1+  LangExt.DefaultSignatures -> "DefaultSignatures"        -- Allow extra signatures for defmeths+  LangExt.DeriveAnyClass -> "DeriveAnyClass"           -- Allow deriving any class+  LangExt.DeriveLift -> "DeriveLift"               -- Allow deriving Lift+  LangExt.DerivingStrategies -> "DerivingStrategies"+  LangExt.DerivingVia -> "DerivingVia"              -- Derive through equal representation+  LangExt.TypeSynonymInstances -> "TypeSynonymInstances"+  LangExt.FlexibleContexts -> "FlexibleContexts"+  LangExt.FlexibleInstances -> "FlexibleInstances"+  LangExt.ConstrainedClassMethods -> "ConstrainedClassMethods"+  LangExt.MultiParamTypeClasses -> "MultiParamTypeClasses"+  LangExt.NullaryTypeClasses -> "NullaryTypeClasses"+  LangExt.FunctionalDependencies -> "FunctionalDependencies"+  LangExt.UnicodeSyntax -> "UnicodeSyntax"+  LangExt.ExistentialQuantification -> "ExistentialQuantification"+  LangExt.MagicHash -> "MagicHash"+  LangExt.EmptyDataDecls -> "EmptyDataDecls"+  LangExt.KindSignatures -> "KindSignatures"+  LangExt.RoleAnnotations -> "RoleAnnotations"+  LangExt.ParallelListComp -> "ParallelListComp"+  LangExt.TransformListComp -> "TransformListComp"+  LangExt.MonadComprehensions -> "MonadComprehensions"+  LangExt.GeneralizedNewtypeDeriving -> "GeneralizedNewtypeDeriving"+  LangExt.RecursiveDo -> "RecursiveDo"+  LangExt.PostfixOperators -> "PostfixOperators"+  LangExt.TupleSections -> "TupleSections"+  LangExt.PatternGuards -> "PatternGuards"+  LangExt.LiberalTypeSynonyms -> "LiberalTypeSynonyms"+  LangExt.RankNTypes -> "RankNTypes"+  LangExt.ImpredicativeTypes -> "ImpredicativeTypes"+  LangExt.TypeOperators -> "TypeOperators"+  LangExt.ExplicitNamespaces -> "ExplicitNamespaces"+  LangExt.PackageImports -> "PackageImports"+  LangExt.ExplicitForAll -> "ExplicitForAll"+  LangExt.AlternativeLayoutRule -> "AlternativeLayoutRule"+  LangExt.AlternativeLayoutRuleTransitional -> "AlternativeLayoutRuleTransitional"+  LangExt.DatatypeContexts -> "DatatypeContexts"+  LangExt.NondecreasingIndentation -> "NondecreasingIndentation"+  LangExt.RelaxedLayout -> "RelaxedLayout"+  LangExt.TraditionalRecordSyntax -> "TraditionalRecordSyntax"+  LangExt.LambdaCase -> "LambdaCase"+  LangExt.MultiWayIf -> "MultiWayIf"+  LangExt.BinaryLiterals -> "BinaryLiterals"+  LangExt.NegativeLiterals -> "NegativeLiterals"+  LangExt.HexFloatLiterals -> "HexFloatLiterals"+  LangExt.DuplicateRecordFields -> "DuplicateRecordFields"+  LangExt.OverloadedLabels -> "OverloadedLabels"+  LangExt.EmptyCase -> "EmptyCase"+  LangExt.PatternSynonyms -> "PatternSynonyms"+  LangExt.PartialTypeSignatures -> "PartialTypeSignatures"+  LangExt.NamedWildCards -> "NamedWildCards"+  LangExt.StaticPointers -> "StaticPointers"+  LangExt.TypeApplications -> "TypeApplications"+  LangExt.Strict -> "Strict"+  LangExt.StrictData -> "StrictData"+  LangExt.EmptyDataDeriving -> "EmptyDataDeriving"+  LangExt.NumericUnderscores -> "NumericUnderscores"+  LangExt.QuantifiedConstraints -> "QuantifiedConstraints"+  LangExt.StarIsType -> "StarIsType"+  LangExt.ImportQualifiedPost -> "ImportQualifiedPost"+  LangExt.CUSKs -> "CUSKs"+  LangExt.StandaloneKindSignatures -> "StandaloneKindSignatures"+  LangExt.LexicalNegation -> "LexicalNegation"+  LangExt.FieldSelectors -> "FieldSelectors"+  LangExt.OverloadedRecordDot -> "OverloadedRecordDot"+  LangExt.OverloadedRecordUpdate -> "OverloadedRecordUpdate"+  LangExt.TypeAbstractions -> "TypeAbstractions"+  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+extensionAlternateNames :: LangExt.Extension -> [String]+extensionAlternateNames = \case+  LangExt.GeneralizedNewtypeDeriving -> ["GeneralisedNewtypeDeriving"]+  LangExt.RankNTypes                 -> ["Rank2Types", "PolymorphicComponents"]+  _ -> []++extensionDeprecatedNames :: LangExt.Extension -> [String]+extensionDeprecatedNames = \case+  LangExt.RecursiveDo         -> ["DoRec"]+  LangExt.NamedFieldPuns      -> ["RecordPuns"]+  LangExt.ScopedTypeVariables -> ["PatternSignatures"]+  _ -> []++-- | All the names by which an extension is known.+extensionNames :: LangExt.Extension -> [ (ExtensionDeprecation, String) ]+extensionNames ext = mk (extensionDeprecation ext)     (extensionName ext : extensionAlternateNames ext)+                  ++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext)+  where mk depr = map (\name -> (depr, name))++impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)]+impliedXFlags+-- See Note [Updating flag description in the User's Guide]+  = [ (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, Off LangExt.ImplicitPrelude)      -- NB: turn off!++    , (LangExt.DerivingVia, On LangExt.DerivingStrategies)++    , (LangExt.GADTs,            On LangExt.GADTSyntax)+    , (LangExt.GADTs,            On LangExt.MonoLocalBinds)+    , (LangExt.TypeFamilies,     On LangExt.MonoLocalBinds)++    , (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,       On LangExt.DataKinds)+    , (LangExt.TypeInType,       On LangExt.PolyKinds)+    , (LangExt.TypeInType,       On LangExt.KindSignatures)++    -- Standalone kind signatures are a replacement for CUSKs.+    , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs)++    -- AutoDeriveTypeable is not very useful without 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,     On LangExt.ExplicitNamespaces)+    , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces)++    , (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,     On LangExt.DisambiguateRecordFields)++    , (LangExt.ParallelArrays, On LangExt.ParallelListComp)+    , (LangExt.MonadComprehensions, On LangExt.ParallelListComp)+    , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI)++    , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor)+    , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable)++    -- Duplicate record fields require field disambiguation+    , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields)++    , (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, On LangExt.UnboxedSums)++    -- The extensions needed to declare an H98 unlifted data type+    , (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, On LangExt.MonoLocalBinds)++    , (LangExt.ExplicitLevelImports, Off LangExt.ImplicitStagePersistence)+  ]+++validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+validHoleFitsImpliedGFlags+  = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)+    , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]++-- | General flags that are switched on/off when other general flags are switched+-- on+impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)+                ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)+                ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)+                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)+                ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface)+                ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback)+                ] ++ validHoleFitsImpliedGFlags++-- | 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 @docs/users_guide/what_glasgow_exts_does.rst@ up to date with this list.+glasgowExtsFlags :: [LangExt.Extension]+glasgowExtsFlags = [+             LangExt.ConstrainedClassMethods+           , LangExt.DeriveDataTypeable+           , LangExt.DeriveFoldable+           , LangExt.DeriveFunctor+           , LangExt.DeriveGeneric+           , LangExt.DeriveTraversable+           , LangExt.EmptyDataDecls+           , LangExt.ExistentialQuantification+           , LangExt.ExplicitNamespaces+           , LangExt.FlexibleContexts+           , LangExt.FlexibleInstances+           , LangExt.ForeignFunctionInterface+           , LangExt.FunctionalDependencies+           , LangExt.GeneralizedNewtypeDeriving+           , LangExt.ImplicitParams+           , LangExt.KindSignatures+           , LangExt.LiberalTypeSynonyms+           , LangExt.MagicHash+           , LangExt.MultiParamTypeClasses+           , LangExt.ParallelListComp+           , LangExt.PatternGuards+           , LangExt.PostfixOperators+           , LangExt.RankNTypes+           , LangExt.RecursiveDo+           , LangExt.ScopedTypeVariables+           , LangExt.StandaloneDeriving+           , LangExt.TypeOperators+           , LangExt.TypeSynonymInstances+           , LangExt.UnboxedTuples+           , LangExt.UnicodeSyntax+           , LangExt.UnliftedFFITypes ]+ -- | Debugging flags data DumpFlag--- See Note [Updating flag description in the User's Guide]+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session     -- debugging flags    = Opt_D_dump_cmm@@ -58,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@@ -102,6 +477,7 @@    | Opt_D_dump_simpl    | Opt_D_dump_simpl_iterations    | Opt_D_dump_spec+   | Opt_D_dump_spec_constr    | Opt_D_dump_prep    | Opt_D_dump_late_cc    | Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output)@@ -109,10 +485,11 @@    | 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_stranal-   | Opt_D_dump_str_signatures+   | Opt_D_dump_dmdanal+   | Opt_D_dump_dmd_signatures    | Opt_D_dump_cpranal    | Opt_D_dump_cpr_signatures    | Opt_D_dump_tc@@ -121,14 +498,18 @@    | Opt_D_dump_types    | Opt_D_dump_rules    | Opt_D_dump_cse+   | Opt_D_dump_float_out+   | Opt_D_dump_float_in+   | Opt_D_dump_liberate_case+   | Opt_D_dump_static_argument_transformation    | Opt_D_dump_worker_wrapper    | Opt_D_dump_rn_trace    | 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@@ -195,7 +576,7 @@  -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag--- See Note [Updating flag description in the User's Guide]+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session     = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.    | Opt_DumpWithWays                   -- ^ Use foo.ways.<dumpFlag> instead of foo.<dumpFlag>@@ -207,6 +588,7 @@    | Opt_DoAsmLinting    | Opt_DoAnnotationLinting    | Opt_DoBoundsChecking+   | Opt_AddBcoName    | Opt_NoLlvmMangler                  -- hidden flag    | Opt_FastLlvm                       -- hidden flag    | Opt_NoTypeableBinds@@ -216,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@@ -260,20 +646,21 @@    | Opt_LiberateCase    | Opt_SpecConstr    | Opt_SpecConstrKeen+   | Opt_SpecialiseIncoherents    | Opt_DoLambdaEtaExpansion+   | Opt_DoCleverArgEtaExpansion        -- See Note [Eta expansion of arguments in CorePrep]    | 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_LlvmTBAA                       -- Use LLVM TBAA infrastructure for improving AA (hidden flag)+   | 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@@ -281,21 +668,22 @@    | Opt_CmmElimCommonBlocks    | Opt_CmmControlFlow    | 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@@ -305,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 @@ -313,14 +701,24 @@    | Opt_IgnoreInterfacePragmas    | Opt_OmitInterfacePragmas    | Opt_ExposeAllUnfoldings-   | Opt_WriteInterface -- forces .hi files to be written even with -fno-code-   | Opt_WriteHie -- generate .hie files+   | 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_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)+    -- profiling opts    | Opt_AutoSccsOnIndividualCafs    | Opt_ProfCountEntries    | Opt_ProfLateInlineCcs    | Opt_ProfLateCcs+   | Opt_ProfLateOverloadedCcs+   | Opt_ProfLateoverloadedCallsCCs    | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations     -- misc opts@@ -330,6 +728,7 @@    | Opt_IgnoreHpcChanges    | Opt_ExcessPrecision    | Opt_EagerBlackHoling+   | Opt_OrigThunkInfo    | Opt_NoHsMain    | Opt_SplitSections    | Opt_StgStats@@ -348,11 +747,20 @@    | Opt_BuildingCabalPackage    | Opt_IgnoreDotGhci    | Opt_GhciSandbox+   | Opt_InsertBreakpoints    | Opt_GhciHistory    | Opt_GhciLeakCheck    | 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@@ -389,13 +797,15 @@    | Opt_KeepGoing    | Opt_ByteCode    | Opt_ByteCodeAndObjectCode+   | Opt_UnoptimizedCoreForInterpreter    | 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_DiagnosticsShowCaret -- Show snippets of offending code+   | Opt_DiagnosticsAsJSON  -- ^ Dump diagnostics as JSON+   | Opt_DiagnosticsShowCaret -- ^ Show snippets of offending code    | Opt_PprCaseAsLet    | Opt_PprShowTicks    | Opt_ShowHoleConstraints@@ -418,35 +828,38 @@    | 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     -- Error message suppression    | Opt_ShowErrorContext +   -- Object code determinism+   | Opt_ObjectDeterminism+    -- temporary flags    | Opt_AutoLinkPackages    | Opt_ImplicitImportQualified@@ -511,11 +924,11 @@    , Opt_EnableRewriteRules    , Opt_RegsGraph    , Opt_RegsIterative-   , Opt_LlvmTBAA    , Opt_IrrefutableTuples    , Opt_CmmSink    , Opt_CmmElimCommonBlocks    , Opt_AsmShortcutting+   , Opt_InterModuleFarJumps    , Opt_FunToThunk    , Opt_DmdTxDictSel    , Opt_Loopification@@ -558,7 +971,10 @@       -- Flags that affect generated code    , Opt_ExposeAllUnfoldings+   , Opt_ExposeOverloadedUnfoldings    , Opt_NoTypeableBinds+   , Opt_ObjectDeterminism+   , Opt_Haddock       -- Flags that affect catching of runtime errors    , Opt_CatchNonexhaustiveCases@@ -570,10 +986,11 @@    , Opt_InfoTableMap    , Opt_InfoTableMapWithStack    , Opt_InfoTableMapWithFallback+   , Opt_OrigThunkInfo    ]  data WarningFlag =--- See Note [Updating flag description in the User's Guide]+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session      Opt_WarnDuplicateExports    | Opt_WarnDuplicateConstraints    | Opt_WarnRedundantConstraints@@ -603,10 +1020,9 @@    | Opt_WarnUnusedRecordWildcards    | Opt_WarnRedundantBangPatterns    | Opt_WarnRedundantRecordWildcards-   | Opt_WarnWarningsDeprecations    | Opt_WarnDeprecatedFlags    | Opt_WarnMissingMonadFailInstances               -- since 8.0, has no effect since 8.8-   | Opt_WarnSemigroup                               -- since 8.0+   | Opt_WarnSemigroup                               -- since 8.0, has no effect since 9.8    | Opt_WarnDodgyExports    | Opt_WarnDodgyImports    | Opt_WarnOrphans@@ -635,43 +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_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+   | 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@@ -683,11 +1118,11 @@   Opt_WarnAlternativeLayoutRuleTransitional       -> "alternative-layout-rule-transitional" :| []   Opt_WarnAmbiguousFields                         -> "ambiguous-fields" :| []   Opt_WarnAutoOrphans                             -> "auto-orphans" :| []+  Opt_WarnTermVariableCapture                     -> "term-variable-capture" :| []   Opt_WarnCPPUndef                                -> "cpp-undef" :| []   Opt_WarnUnbangedStrictPatterns                  -> "unbanged-strict-patterns" :| []   Opt_WarnDeferredTypeErrors                      -> "deferred-type-errors" :| []   Opt_WarnDeferredOutOfScopeVariables             -> "deferred-out-of-scope-variables" :| []-  Opt_WarnWarningsDeprecations                    -> "deprecations" :| ["warnings-deprecations"]   Opt_WarnDeprecatedFlags                         -> "deprecated-flags" :| []   Opt_WarnDerivingDefaults                        -> "deriving-defaults" :| []   Opt_WarnDerivingTypeable                        -> "deriving-typeable" :| []@@ -716,6 +1151,7 @@   Opt_WarnSemigroup                               -> "semigroup" :| []   Opt_WarnMissingSignatures                       -> "missing-signatures" :| []   Opt_WarnMissingKindSignatures                   -> "missing-kind-signatures" :| []+  Opt_WarnMissingPolyKindSignatures               -> "missing-poly-kind-signatures" :| []   Opt_WarnMissingExportedSignatures               -> "missing-exported-signatures" :| []   Opt_WarnMonomorphism                            -> "monomorphism-restriction" :| []   Opt_WarnNameShadowing                           -> "name-shadowing" :| []@@ -778,6 +1214,20 @@   Opt_WarnTypeEqualityOutOfScope                  -> "type-equality-out-of-scope" :| []   Opt_WarnLoopySuperclassSolve                    -> "loopy-superclass-solve" :| []   Opt_WarnTypeEqualityRequiresOperators           -> "type-equality-requires-operators" :| []+  Opt_WarnMissingRoleAnnotations                  -> "missing-role-annotations" :| []+  Opt_WarnImplicitRhsQuantification               -> "implicit-rhs-quantification" :| []+  Opt_WarnIncompleteExportWarnings                -> "incomplete-export-warnings" :| []+  Opt_WarnIncompleteRecordSelectors               -> "incomplete-record-selectors" :| []+  Opt_WarnBadlyLevelledTypes                      -> "badly-levelled-types" :| []+  Opt_WarnInconsistentFlags                       -> "inconsistent-flags" :| []+  Opt_WarnDataKindsTC                             -> "data-kinds-tc" :| []+  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@@ -785,24 +1235,62 @@ -- Note [Documenting warning flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ----- If you change the list of warning enabled by default+-- If you change the list of warnings enabled by default -- please remember to update the User's Guide. The relevant file is: -- --  docs/users_guide/using-warnings.rst ++-- | A group of warning flags that can be enabled or disabled collectively,+-- e.g. using @-Wcompat@ to enable all warnings in the 'W_compat' group.+data WarningGroup = W_compat+                  | W_unused_binds+                  | W_extended_warnings+                  | W_default+                  | W_extra+                  | W_all+                  | W_everything+  deriving (Bounded, Enum, Eq)++warningGroupName :: WarningGroup -> String+warningGroupName W_compat            = "compat"+warningGroupName W_unused_binds      = "unused-binds"+warningGroupName W_extended_warnings = "extended-warnings"+warningGroupName W_default           = "default"+warningGroupName W_extra             = "extra"+warningGroupName W_all               = "all"+warningGroupName W_everything        = "everything"++warningGroupFlags :: WarningGroup -> [WarningFlag]+warningGroupFlags W_compat            = minusWcompatOpts+warningGroupFlags W_unused_binds      = unusedBindsFlags+warningGroupFlags W_extended_warnings = []+warningGroupFlags W_default           = standardWarnings+warningGroupFlags W_extra             = minusWOpts+warningGroupFlags W_all               = minusWallOpts+warningGroupFlags W_everything        = minusWeverythingOpts++-- | Does this warning group contain (all) extended warning categories?  See+-- Note [Warning categories] in GHC.Unit.Module.Warnings.+--+-- The 'W_extended_warnings' group contains extended warnings but no+-- 'WarningFlag's, but extended warnings are also treated as part of 'W_default'+-- and every warning group that includes it.+warningGroupIncludesExtendedWarnings :: WarningGroup -> Bool+warningGroupIncludesExtendedWarnings W_compat            = False+warningGroupIncludesExtendedWarnings W_unused_binds      = False+warningGroupIncludesExtendedWarnings W_extended_warnings = True+warningGroupIncludesExtendedWarnings W_default           = True+warningGroupIncludesExtendedWarnings W_extra             = True+warningGroupIncludesExtendedWarnings W_all               = True+warningGroupIncludesExtendedWarnings W_everything        = True+ -- | 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 :: [(String, [WarningFlag])]-warningGroups =-    [ ("compat",       minusWcompatOpts)-    , ("unused-binds", unusedBindsFlags)-    , ("default",      standardWarnings)-    , ("extra",        minusWOpts)-    , ("all",          minusWallOpts)-    , ("everything",   minusWeverythingOpts)-    ]+warningGroups :: [WarningGroup]+warningGroups = [minBound..maxBound]  -- | Warning group hierarchies, where there is an explicit inclusion -- relation.@@ -814,32 +1302,35 @@ -- Separating this from 'warningGroups' allows for multiple -- hierarchies with no inherent relation to be defined. ----- The special-case Weverything group is not included.-warningHierarchies :: [[String]]+-- The special-case 'W_everything' group is not included.+warningHierarchies :: [[WarningGroup]] warningHierarchies = hierarchies ++ map (:[]) rest   where-    hierarchies = [["default", "extra", "all"]]-    rest = filter (`notElem` "everything" : concat hierarchies) $-           map fst warningGroups+    hierarchies = [[W_default, W_extra, W_all]]+    rest = filter (`notElem` W_everything : concat hierarchies) warningGroups  -- | Find the smallest group in every hierarchy which a warning -- belongs to, excluding Weverything.-smallestWarningGroups :: WarningFlag -> [String]+smallestWarningGroups :: WarningFlag -> [WarningGroup] smallestWarningGroups flag = mapMaybe go warningHierarchies where     -- Because each hierarchy is arranged from smallest to largest,     -- the first group we find in a hierarchy which contains the flag     -- is the smallest.     go (group:rest) = fromMaybe (go rest) $ do-        flags <- lookup group warningGroups-        guard (flag `elem` flags)+        guard (flag `elem` warningGroupFlags group)         pure (Just group)     go [] = Nothing +-- | The smallest group in every hierarchy to which a custom warning+-- category belongs is currently always @-Wextended-warnings@.+-- See Note [Warning categories] in "GHC.Unit.Module.Warnings".+smallestWarningGroupsForCategory :: [WarningGroup]+smallestWarningGroupsForCategory = [W_extended_warnings]+ -- | Warnings enabled unless specified otherwise standardWarnings :: [WarningFlag] standardWarnings -- see Note [Documenting warning flags]     = [ Opt_WarnOverlappingPatterns,-        Opt_WarnWarningsDeprecations,         Opt_WarnDeprecatedFlags,         Opt_WarnDeferredTypeErrors,         Opt_WarnTypedHoles,@@ -871,14 +1362,21 @@         Opt_WarnNonCanonicalMonadInstances,         Opt_WarnNonCanonicalMonoidInstances,         Opt_WarnOperatorWhitespaceExtConflict,-        Opt_WarnForallIdentifier,         Opt_WarnUnicodeBidirectionalFormatCharacters,         Opt_WarnGADTMonoLocalBinds,-        Opt_WarnLoopySuperclassSolve,-        Opt_WarnTypeEqualityRequiresOperators+        Opt_WarnBadlyLevelledTypes,+        Opt_WarnTypeEqualityRequiresOperators,+        Opt_WarnInconsistentFlags,+        Opt_WarnTypeEqualityOutOfScope,+        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 ++@@ -894,7 +1392,7 @@         Opt_WarnUnbangedStrictPatterns       ] --- | Things you get with -Wall+-- | Things you get with @-Wall@. minusWallOpts :: [WarningFlag] minusWallOpts     = minusWOpts ++@@ -909,27 +1407,27 @@         Opt_WarnUnusedRecordWildcards,         Opt_WarnRedundantRecordWildcards,         Opt_WarnIncompleteUniPatterns,-        Opt_WarnIncompletePatternsRecUpd+        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_WarnSemigroup-      , Opt_WarnNonCanonicalMonoidInstances-      , Opt_WarnCompatUnqualifiedImports-      , Opt_WarnTypeEqualityOutOfScope+    = [ 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
@@ -32,7 +32,7 @@ import GHC.Prelude  import GHC.Driver.Env-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Pipeline.Phases  import GHC.Hs.Decls@@ -48,12 +48,11 @@ import GHC.Types.CostCentre import GHC.Types.IPE import GHC.Types.Meta-import GHC.Types.HpcInfo  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@@ -61,13 +60,13 @@  import GHC.Tc.Types import GHC.Stg.Syntax+import GHC.StgToCmm.CgUtils (CgStream) import GHC.StgToCmm.Types (ModuleLFInfos) import GHC.StgToCmm.Config import GHC.Cmm  import GHCi.RemoteTypes -import GHC.Data.Stream import GHC.Data.Bag  import qualified Data.Kind@@ -121,6 +120,9 @@ be decoupled from its use of the DsM definition in GHC.HsToCore.Types. Since both DsM and the definition of @ForeignsHook@ live in the same module, there is virtually no difference for plugin authors that want to write a foreign hook.++An awkward consequences is that the `type instance DsForeignsHook`, in+GHC.HsToCore.Types is an orphan instance. -}  -- See Note [The Decoupling Abstract Data Hack]@@ -146,9 +148,9 @@                                          -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))   , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))   , stgToCmmHook           :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))-  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a-                                 -> IO (Stream IO RawCmmGroup a)))+                                 -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))+  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a+                                 -> IO (CgStream RawCmmGroup a)))   }  class HasHooks m where
+ 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/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-}+{-# LANGUAGE DerivingVia, NoPolyKinds #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- --@@ -23,6 +23,8 @@         modifyLogger,         pushLogHookM,         popLogHookM,+        pushJsonLogHookM,+        popJsonLogHookM,         putLogMsgM,         putMsgM,         withTimingM,@@ -34,7 +36,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages ) import GHC.Driver.Errors.Types@@ -120,6 +122,12 @@ -- | Pop a log hook from the stack popLogHookM :: GhcMonad m => m () popLogHookM  = modifyLogger popLogHook++pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()+pushJsonLogHookM = modifyLogger . pushJsonLogHook++popJsonLogHookM :: GhcMonad m => m ()+popJsonLogHookM = modifyLogger popJsonLogHook  -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m ()
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/Pipeline/Phases.hs view
@@ -6,8 +6,7 @@ import GHC.Prelude import GHC.Driver.Pipeline.Monad import GHC.Driver.Env.Types-import GHC.Driver.Session-import GHC.Driver.CmdLine+import GHC.Driver.DynFlags import GHC.Types.SourceFile import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Status@@ -29,7 +28,7 @@ -- phase if the inputs have been modified. data TPhase res where   T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath-  T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn])+  T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage)   T_Cpp   :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath   T_HsPp  :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath   T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus)@@ -48,6 +47,7 @@   T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath   T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath   T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_LlvmAs :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath   T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath   T_MergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath
compiler/GHC/Driver/Plugins.hs view
@@ -58,6 +58,10 @@       -- | hole fit plugins allow plugins to change the behavior of valid hole       -- fit suggestions     , HoleFitPluginR+      -- ** Late plugins+      -- | Late plugins can access and modify the core of a module after+      -- optimizations have been applied and after interface creation.+    , LatePlugin        -- * Internal     , PluginWithArgs(..), pluginsWithArgs, pluginRecompile'@@ -82,15 +86,17 @@  import qualified GHC.Tc.Types import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports  )-import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )+import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR )  import GHC.Core.Opt.Monad ( CoreM ) import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types+import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic@@ -157,6 +163,13 @@     --     --   @since 8.10.1 +  , latePlugin :: LatePlugin+    -- ^ A plugin that runs after interface creation and after late cost centre+    -- insertion. Useful for transformations that should not impact interfaces+    -- or optimization at all.+    --+    -- @since 9.10.1+   , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile     -- ^ Specify how the plugin should affect recompilation.   , parsedResultAction :: [CommandLineOption] -> ModSummary@@ -231,6 +244,8 @@ data StaticPlugin = StaticPlugin   { spPlugin :: PluginWithArgs   -- ^ the actual plugin together with its commandline arguments+  , spInitialised :: Bool+  -- ^ has this plugin been initialised (i.e. driverPlugin has been run)   }  lpModuleName :: LoadedPlugin -> ModuleName@@ -260,6 +275,7 @@ type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR+type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState)  purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile@@ -280,6 +296,7 @@       , defaultingPlugin      = const Nothing       , holeFitPlugin         = const Nothing       , driverPlugin          = const return+      , latePlugin            = \_ -> const return       , pluginRecompile       = impurePlugin       , renamedResultAction   = \_ env grp -> return (env, grp)       , parsedResultAction    = \_ _ -> return@@ -405,12 +422,12 @@ loadExternalPluginLib path = do   -- load library   loadDLL path >>= \case-    Just errmsg -> pprPanic "loadExternalPluginLib"-                    (vcat [ text "Can't load plugin library"-                          , text "  Library path: " <> text path-                          , text "  Error       : " <> text errmsg-                          ])-    Nothing -> do+    Left errmsg -> pprPanic "loadExternalPluginLib"+                     (vcat [ text "Can't load plugin library"+                           , text "  Library path: " <> text path+                           , text "  Error       : " <> text errmsg+                           ])+    Right _ -> do       -- resolve objects       resolveObjs >>= \case         True -> return ()
compiler/GHC/Driver/Ppr.hs view
@@ -6,12 +6,13 @@    , showPpr    , showPprUnsafe    , printForUser+   , printForUserColoured    ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Unit.State  import GHC.Utils.Outputable@@ -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,5072 +18,3805 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Driver.Session (-        -- * Dynamic flags and associated configuration types-        DumpFlag(..),-        GeneralFlag(..),-        WarningFlag(..), DiagnosticReason(..),-        Language(..),-        FatalMessager, FlushOut(..),-        ProfAuto(..),-        glasgowExtsFlags,-        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,-        dopt, dopt_set, dopt_unset,-        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',-        wopt, wopt_set, wopt_unset,-        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,-        xopt, xopt_set, xopt_unset,-        xopt_set_unlessExplSpec,-        xopt_DuplicateRecordFields,-        xopt_FieldSelectors,-        lang_set,-        DynamicTooState(..), dynamicTooState, setDynamicNow,-        sccProfilingEnabled,-        needSourceNotes,-        OnOff(..),-        DynFlags(..),-        outputFile, objectSuf, ways,-        FlagSpec(..),-        HasDynFlags(..), ContainsDynFlags(..),-        RtsOptsEnabled(..),-        GhcMode(..), isOneShot,-        GhcLink(..), isNoLink,-        PackageFlag(..), PackageArg(..), ModRenaming(..),-        packageFlagsChanged,-        IgnorePackageFlag(..), TrustFlag(..),-        PackageDBFlag(..), PkgDbRef(..),-        Option(..), showOpt,-        DynLibLoader(..),-        fFlags, fLangFlags, xFlags,-        wWarningFlags,-        makeDynFlagsConsistent,-        positionIndependent,-        optimisationFlags,-        codeGenFlags,-        setFlagsFromEnvFile,-        pprDynFlagsDiff,-        flagSpecOf,--        targetProfile,--        -- ** Safe Haskell-        safeHaskellOn, safeHaskellModeEnabled,-        safeImportsOn, safeLanguageOn, safeInferOn,-        packageTrustOn,-        safeDirectImpsReq, safeImplicitImpsReq,-        unsafeFlags, unsafeFlagsForInfer,--        -- ** System tool settings and locations-        Settings(..),-        sProgramName,-        sProjectVersion,-        sGhcUsagePath,-        sGhciUsagePath,-        sToolDir,-        sTopDir,-        sGlobalPackageDatabasePath,-        sLdSupportsCompactUnwind,-        sLdSupportsFilelist,-        sLdIsGnuLd,-        sGccSupportsNoPie,-        sPgm_L,-        sPgm_P,-        sPgm_F,-        sPgm_c,-        sPgm_cxx,-        sPgm_a,-        sPgm_l,-        sPgm_lm,-        sPgm_dll,-        sPgm_T,-        sPgm_windres,-        sPgm_ar,-        sPgm_ranlib,-        sPgm_lo,-        sPgm_lc,-        sPgm_lcc,-        sPgm_i,-        sOpt_L,-        sOpt_P,-        sOpt_P_fingerprint,-        sOpt_F,-        sOpt_c,-        sOpt_cxx,-        sOpt_a,-        sOpt_l,-        sOpt_lm,-        sOpt_windres,-        sOpt_lo,-        sOpt_lc,-        sOpt_lcc,-        sOpt_i,-        sExtraGccViaCFlags,-        sTargetPlatformString,-        sGhcWithInterpreter,-        sLibFFI,-        GhcNameVersion(..),-        FileSettings(..),-        PlatformMisc(..),-        settings,-        programName, projectVersion,-        ghcUsagePath, ghciUsagePath, topDir,-        versionedAppDir, versionedFilePath,-        extraGccViaCFlags, globalPackageDatabasePath,-        pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,-        pgm_windres, pgm_ar,-        pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,-        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,-        opt_P_signature,-        opt_windres, opt_lo, opt_lc, opt_lcc,-        updatePlatformConstants,--        -- ** Manipulating DynFlags-        addPluginModuleName,-        defaultDynFlags,                -- Settings -> DynFlags-        initDynFlags,                   -- DynFlags -> IO DynFlags-        defaultFatalMessager,-        defaultFlushOut,-        setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,-        augmentByWorkingDirectory,--        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]-        getVerbFlags,-        updOptLevel,-        setTmpDir,-        setUnitId,--        TurnOnFlag,-        turnOn,-        turnOff,-        impliedGFlags,-        impliedOffGFlags,-        impliedXFlags,--        -- ** State-        CmdLineP(..), runCmdLineP,-        getCmdLineState, putCmdLineState,-        processCmdLineP,--        -- ** Parsing DynFlags-        parseDynamicFlagsCmdLine,-        parseDynamicFilePragma,-        parseDynamicFlagsFull,--        -- ** Available DynFlags-        allNonDeprecatedFlags,-        flagsAll,-        flagsDynamic,-        flagsPackage,-        flagsForCompletion,--        supportedLanguagesAndExtensions,-        languageExtensions,--        -- ** DynFlags C compiler options-        picCCOpts, picPOpts,--        -- ** DynFlags C linker options-        pieCCLDOpts,--        -- * Compiler configuration suitable for display to the user-        compilerInfo,--        wordAlignment,--        setUnsafeGlobalDynFlags,--        -- * SSE and AVX-        isSse4_2Enabled,-        isBmiEnabled,-        isBmi2Enabled,-        isAvxEnabled,-        isAvx2Enabled,-        isAvx512cdEnabled,-        isAvx512erEnabled,-        isAvx512fEnabled,-        isAvx512pfEnabled,--        -- * Linker/compiler information-        LinkerInfo(..),-        CompilerInfo(..),-        useXLinkerRPath,--        -- * Include specifications-        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,-        addImplicitQuoteInclude,--        -- * SDoc-        initSDocContext, initDefaultSDocContext,-        initPromotionTickContext,-  ) where--import GHC.Prelude--import GHC.Platform-import GHC.Platform.Ways-import GHC.Platform.Profile--import GHC.UniqueSubdir (uniqueSubdir)-import GHC.Unit.Types-import GHC.Unit.Parser-import GHC.Unit.Module-import GHC.Builtin.Names ( mAIN_NAME )-import GHC.Driver.Phases ( Phase(..), phaseInputExt )-import GHC.Driver.Flags-import GHC.Driver.Backend-import GHC.Driver.Plugins.External-import GHC.Settings.Config-import GHC.Utils.CliOption-import GHC.Core.Unfold-import GHC.Driver.CmdLine-import GHC.Settings.Constants-import GHC.Utils.Panic-import qualified GHC.Utils.Ppr.Colour as Col-import GHC.Utils.Misc-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.GlobalVars-import GHC.Data.Maybe-import GHC.Data.Bool-import GHC.Utils.Monad-import GHC.Types.Error (DiagnosticReason(..))-import GHC.Types.SrcLoc-import GHC.Types.SafeHaskell-import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )-import GHC.Types.ProfAuto-import qualified GHC.Types.FieldLabel as FieldLabel-import GHC.Data.FastString-import GHC.Utils.TmpFs-import GHC.Utils.Fingerprint-import GHC.Utils.Outputable-import GHC.Settings-import GHC.CmmToAsm.CFG.Weight-import {-# SOURCE #-} GHC.Core.Opt.CallerCC--import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )-import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )--import Data.IORef-import Control.Arrow ((&&&))-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Except-import Control.Monad.Trans.State as State-import Data.Functor.Identity--import Data.Ord-import Data.Char-import Data.List (intercalate, sortBy)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Word-import System.FilePath-import System.Directory-import System.Environment (lookupEnv)-import System.IO-import System.IO.Error-import Text.ParserCombinators.ReadP hiding (char)-import Text.ParserCombinators.ReadP as R--import GHC.Data.EnumSet (EnumSet)-import qualified GHC.Data.EnumSet as EnumSet--import GHC.Foreign (withCString, peekCString)-import qualified GHC.LanguageExtensions as LangExt---- Note [Updating flag description in the User's Guide]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you modify anything in this file please make sure that your changes are--- described in the User's Guide. Please update the flag description in the--- users guide (docs/users_guide) whenever you add or change a flag.--- Please make sure you add ":since:" information to new flags.---- Note [Supporting CLI completion]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ The command line interface completion (in for example bash) is an easy way--- for the developer to learn what flags are available from GHC.--- GHC helps by separating which flags are available when compiling with GHC,--- and which flags are available when using GHCi.--- A flag is assumed to either work in both these modes, or only in one of them.--- When adding or changing a flag, please consider for which mode the flag will--- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,--- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.---- Note [Adding a language extension]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ There are a few steps to adding (or removing) a language extension,------  * Adding the extension to GHC.LanguageExtensions------    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs---    is the canonical list of language extensions known by GHC.------  * Adding a flag to DynFlags.xFlags------    This is fairly self-explanatory. The name should be concise, memorable,---    and consistent with any previous implementations of the similar idea in---    other Haskell compilers.------  * Adding the flag to the documentation------    This is the same as any other flag. See---    Note [Updating flag description in the User's Guide]------  * Adding the flag to Cabal------    The Cabal library has its own list of all language extensions supported---    by all major compilers. This is the list that user code being uploaded---    to Hackage is checked against to ensure language extension validity.---    Consequently, it is very important that this list remains up-to-date.------    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)---    whose job it is to ensure these GHC's extensions are consistent with---    Cabal.------    The recommended workflow is,------     1. Temporarily add your new language extension to the---        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't---        break while Cabal is updated.------     2. After your GHC change is accepted, submit a Cabal pull request adding---        your new extension to Cabal's list (found in---        Cabal/Language/Haskell/Extension.hs).------     3. After your Cabal change is accepted, let the GHC developers know so---        they can update the Cabal submodule and remove the extensions from---        expectedGhcOnlyExtensions.------  * Adding the flag to the GHC Wiki------    There is a change log tracking language extension additions and removals---    on the GHC wiki:  https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history------  See #4437 and #8176.---- -------------------------------------------------------------------------------- DynFlags---- | 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--{- Note [Implicit include paths]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  The compile driver adds the path to the folder containing the source file being-  compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'-  that are used later to compute the interface file. Because of this,-  the flags fingerprint derived from these 'DynFlags' and recorded in the-  interface file will end up containing the absolute path to the source folder.--  Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)-  store the build artifacts produced by a build BA for reuse in subsequent builds.--  Embedding source paths in interface fingerprints will thwart these attempts and-  lead to unnecessary recompilations when the source paths in BA differ from the-  source paths in subsequent builds.- -}----- | Contains not only a collection of 'GeneralFlag's but also a plethora of--- information relating to the compilation of a single file or GHC session-data DynFlags = DynFlags {-  ghcMode               :: GhcMode,-  ghcLink               :: GhcLink,-  backend               :: !Backend,-   -- ^ The backend to use (if any).-   ---   -- Whenever you change the backend, also make sure to set 'ghcLink' to-   -- something sensible.-   ---   -- 'NoBackend' can be used to avoid generating any output, however, note that:-   ---   --  * If a program uses Template Haskell the typechecker may need to run code-   --    from an imported module.  To facilitate this, code generation is enabled-   --    for modules imported by modules that use template haskell, using the-   --    default backend for the platform.-   --    See Note [-fno-code mode].---  -- formerly Settings-  ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,-  fileSettings      :: {-# UNPACK #-} !FileSettings,-  targetPlatform    :: Platform,       -- Filled in by SysTools-  toolSettings      :: {-# UNPACK #-} !ToolSettings,-  platformMisc      :: {-# UNPACK #-} !PlatformMisc,-  rawSettings       :: [(String, String)],-  tmpDir            :: TempDir,--  llvmOptLevel          :: Int,         -- ^ LLVM optimisation level-  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]-  debugLevel            :: Int,         -- ^ How much debug information to produce-  simplPhases           :: Int,         -- ^ Number of simplifier phases-  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations-  ruleCheck             :: Maybe String,-  strictnessBefore      :: [Int],       -- ^ Additional demand analysis--  parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel-                                        --   in --make mode, where Nothing ==> compile as-                                        --   many in parallel as there are CPUs.--  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?-  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.--  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt-                                        --   to show in type error messages-  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show-                                        --   in typed hole error messages-  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole-                                        --   fits to show in typed hole error-                                        --   messages-  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for-                                        --   refinement hole fits in typed hole-                                        --   error messages-  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show-                                        --   in non-exhaustiveness warnings-  maxPmCheckModels      :: Int,         -- ^ Soft limit on the number of models-                                        --   the pattern match checker checks-                                        --   a pattern against. A safe guard-                                        --   against exponential blow-up.-  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks-  dmdUnboxWidth         :: !Int,        -- ^ Whether DmdAnal should optimistically put an-                                        --   Unboxed demand on returned products with at most-                                        --   this number of fields-  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr-  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function-  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types-                                        --   Not optional; otherwise ForceSpecConstr can diverge.-  binBlobThreshold      :: Maybe Word,  -- ^ Binary literals (e.g. strings) whose size is above-                                        --   this threshold will be dumped in a binary file-                                        --   by the assembler code generator. 0 and Nothing disables-                                        --   this feature. See 'GHC.StgToCmm.Config'.-  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase-  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating-                                        --   See 'GHC.Core.Opt.Monad.FloatOutSwitches'--  liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a-                                        --   recursive function.-  liftLamsNonRecArgs    :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a-                                        --   non-recursive function.-  liftLamsKnown         :: Bool,        -- ^ Lambda lift even when this turns a known call-                                        --   into an unknown call.--  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.--  historySize           :: Int,         -- ^ Simplification history size--  importPaths           :: [FilePath],-  mainModuleNameIs      :: ModuleName,-  mainFunIs             :: Maybe String,-  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth-  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver-                                         --   Typically only 1 is needed--  homeUnitId_             :: UnitId,                 -- ^ Target home unit-id-  homeUnitInstanceOf_     :: Maybe UnitId,           -- ^ Id of the unit to instantiate-  homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations--  -- Note [Filepaths and Multiple Home Units]-  workingDirectory      :: Maybe FilePath,-  thisPackageName       :: Maybe String, -- ^ What the package is called, use with multiple home units-  hiddenModules         :: Set.Set ModuleName,-  reexportedModules     :: Set.Set ModuleName,--  -- ways-  targetWays_           :: Ways,         -- ^ Target way flags from the command line--  -- For object splitting-  splitInfo             :: Maybe (String,Int),--  -- paths etc.-  objectDir             :: Maybe String,-  dylibInstallName      :: Maybe String,-  hiDir                 :: Maybe String,-  hieDir                :: Maybe String,-  stubDir               :: Maybe String,-  dumpDir               :: Maybe String,--  objectSuf_            :: String,-  hcSuf                 :: String,-  hiSuf_                :: String,-  hieSuf                :: String,--  dynObjectSuf_         :: String,-  dynHiSuf_             :: String,--  outputFile_           :: Maybe String,-  dynOutputFile_        :: Maybe String,-  outputHi              :: Maybe String,-  dynOutputHi           :: Maybe String,-  dynLibLoader          :: DynLibLoader,--  dynamicNow            :: !Bool, -- ^ Indicate if we are now generating dynamic output-                                  -- because of -dynamic-too. This predicate is-                                  -- used to query the appropriate fields-                                  -- (outputFile/dynOutputFile, ways, etc.)--  -- | This defaults to 'non-module'. It can be set by-  -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on-  -- where its output is going.-  dumpPrefix            :: FilePath,--  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix'-  --    or 'ghc.GHCi.UI.runStmt'.-  --    Set by @-ddump-file-prefix@-  dumpPrefixForce       :: Maybe FilePath,--  ldInputs              :: [Option],--  includePaths          :: IncludeSpecs,-  libraryPaths          :: [String],-  frameworkPaths        :: [String],    -- used on darwin only-  cmdlineFrameworks     :: [String],    -- ditto--  rtsOpts               :: Maybe String,-  rtsOptsEnabled        :: RtsOptsEnabled,-  rtsOptsSuggestions    :: Bool,--  hpcDir                :: String,      -- ^ Path to store the .mix files--  -- Plugins-  pluginModNames        :: [ModuleName],-    -- ^ the @-fplugin@ flags given on the command line, in *reverse*-    -- order that they're specified on the command line.-  pluginModNameOpts     :: [(ModuleName,String)],-  frontendPluginOpts    :: [String],-    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*-    -- order that they're specified on the command line.--  externalPluginSpecs   :: [ExternalPluginSpec],-    -- ^ External plugins loaded from shared libraries--  --  For ghc -M-  depMakefile           :: FilePath,-  depIncludePkgDeps     :: Bool,-  depIncludeCppDeps     :: Bool,-  depExcludeMods        :: [ModuleName],-  depSuffixes           :: [String],--  --  Package flags-  packageDBFlags        :: [PackageDBFlag],-        -- ^ The @-package-db@ flags given on the command line, In-        -- *reverse* order that they're specified on the command line.-        -- This is intended to be applied with the list of "initial"-        -- package databases derived from @GHC_PACKAGE_PATH@; see-        -- 'getUnitDbRefs'.--  ignorePackageFlags    :: [IgnorePackageFlag],-        -- ^ The @-ignore-package@ flags from the command line.-        -- In *reverse* order that they're specified on the command line.-  packageFlags          :: [PackageFlag],-        -- ^ The @-package@ and @-hide-package@ flags from the command-line.-        -- In *reverse* order that they're specified on the command line.-  pluginPackageFlags    :: [PackageFlag],-        -- ^ The @-plugin-package-id@ flags from command line.-        -- In *reverse* order that they're specified on the command line.-  trustFlags            :: [TrustFlag],-        -- ^ The @-trust@ and @-distrust@ flags.-        -- In *reverse* order that they're specified on the command line.-  packageEnv            :: Maybe FilePath,-        -- ^ Filepath to the package environment file (if overriding default)---  -- hsc dynamic flags-  dumpFlags             :: EnumSet DumpFlag,-  generalFlags          :: EnumSet GeneralFlag,-  warningFlags          :: EnumSet WarningFlag,-  fatalWarningFlags     :: EnumSet WarningFlag,-  -- Don't change this without updating extensionFlags:-  language              :: Maybe Language,-  -- | Safe Haskell mode-  safeHaskell           :: SafeHaskellMode,-  safeInfer             :: Bool,-  safeInferred          :: Bool,-  -- We store the location of where some extension and flags were turned on so-  -- we can produce accurate error messages when Safe Haskell fails due to-  -- them.-  thOnLoc               :: SrcSpan,-  newDerivOnLoc         :: SrcSpan,-  deriveViaOnLoc        :: SrcSpan,-  overlapInstLoc        :: SrcSpan,-  incoherentOnLoc       :: SrcSpan,-  pkgTrustOnLoc         :: SrcSpan,-  warnSafeOnLoc         :: SrcSpan,-  warnUnsafeOnLoc       :: SrcSpan,-  trustworthyOnLoc      :: SrcSpan,-  -- Don't change this without updating extensionFlags:-  -- Here we collect the settings of the language extensions-  -- from the command line, the ghci config file and-  -- from interactive :set / :seti commands.-  extensions            :: [OnOff LangExt.Extension],-  -- extensionFlags should always be equal to-  --     flattenExtensionFlags language extensions-  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used-  -- by template-haskell-  extensionFlags        :: EnumSet LangExt.Extension,--  -- | Unfolding control-  -- See Note [Discounts and thresholds] in GHC.Core.Unfold-  unfoldingOpts         :: !UnfoldingOpts,--  maxWorkerArgs         :: Int,--  ghciHistSize          :: Int,--  flushOut              :: FlushOut,--  ghcVersionFile        :: Maybe FilePath,-  haddockOptions        :: Maybe String,--  -- | GHCi scripts specified by -ghci-script, in reverse order-  ghciScripts           :: [String],--  -- Output style options-  pprUserLength         :: Int,-  pprCols               :: Int,--  useUnicode            :: Bool,-  useColor              :: OverridingBool,-  canUseColor           :: Bool,-  colScheme             :: Col.Scheme,--  -- | what kind of {-# SCC #-} to add automatically-  profAuto              :: ProfAuto,-  callerCcFilters       :: [CallerCcFilter],--  interactivePrint      :: Maybe String,--  -- | Machine dependent flags (-m\<blah> stuff)-  sseVersion            :: Maybe SseVersion,-  bmiVersion            :: Maybe BmiVersion,-  avx                   :: Bool,-  avx2                  :: Bool,-  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.-  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.-  avx512f               :: Bool, -- Enable AVX-512 instructions.-  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.--  -- | Run-time linker information (what options we need, etc.)-  rtldInfo              :: IORef (Maybe LinkerInfo),--  -- | Run-time C compiler information-  rtccInfo              :: IORef (Maybe CompilerInfo),--  -- | Run-time assembler information-  rtasmInfo              :: IORef (Maybe CompilerInfo),--  -- Constants used to control the amount of optimization done.--  -- | Max size, in bytes, of inline array allocations.-  maxInlineAllocSize    :: Int,--  -- | Only inline memcpy if it generates no more than this many-  -- pseudo (roughly: Cmm) instructions.-  maxInlineMemcpyInsns  :: Int,--  -- | Only inline memset if it generates no more than this many-  -- pseudo (roughly: Cmm) instructions.-  maxInlineMemsetInsns  :: Int,--  -- | Reverse the order of error messages in GHC/GHCi-  reverseErrors         :: Bool,--  -- | Limit the maximum number of errors to show-  maxErrors             :: Maybe Int,--  -- | Unique supply configuration for testing build determinism-  initialUnique         :: Word64,-  uniqueIncrement       :: Int,-    -- 'Int' because it can be used to test uniques in decreasing order.--  -- | Temporary: CFG Edge weights for fast iterations-  cfgWeights            :: Weights-}--{- Note [RHS Floating]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to-  'doFloatFromRhs'; with this we can control floating out with GHC flags.--  This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and-  allows for experimentation.--}--class HasDynFlags m where-    getDynFlags :: m DynFlags--{- It would be desirable to have the more generalised--  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where-      getDynFlags = lift getDynFlags--instance definition. However, that definition would overlap with the-`HasDynFlags (GhcT m)` instance. Instead we define instances for a-couple of common Monad transformers explicitly. -}--instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where-    getDynFlags = lift getDynFlags--instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where-    getDynFlags = lift getDynFlags--instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where-    getDynFlags = lift getDynFlags--instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where-    getDynFlags = lift getDynFlags--class ContainsDynFlags t where-    extractDynFlags :: t -> DynFlags---------------------------------------------------------------------------------- Accessors from 'DynFlags'---- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the--- vast majority of code. But GHCi questionably uses this to produce a default--- 'DynFlags' from which to compute a flags diff for printing.-settings :: DynFlags -> Settings-settings dflags = Settings-  { sGhcNameVersion = ghcNameVersion dflags-  , sFileSettings = fileSettings dflags-  , sTargetPlatform = targetPlatform dflags-  , sToolSettings = toolSettings dflags-  , sPlatformMisc = platformMisc dflags-  , sRawSettings = rawSettings dflags-  }--programName :: DynFlags -> String-programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags-projectVersion :: DynFlags -> String-projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags)-ghcUsagePath          :: DynFlags -> FilePath-ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags-ghciUsagePath         :: DynFlags -> FilePath-ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags-toolDir               :: DynFlags -> Maybe FilePath-toolDir dflags = fileSettings_toolDir $ fileSettings dflags-topDir                :: DynFlags -> FilePath-topDir dflags = fileSettings_topDir $ fileSettings dflags-extraGccViaCFlags     :: DynFlags -> [String]-extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags-globalPackageDatabasePath   :: DynFlags -> FilePath-globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags-pgm_L                 :: DynFlags -> String-pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags-pgm_P                 :: DynFlags -> (String,[Option])-pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags-pgm_F                 :: DynFlags -> String-pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags-pgm_c                 :: DynFlags -> String-pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags-pgm_cxx               :: DynFlags -> String-pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags-pgm_a                 :: DynFlags -> (String,[Option])-pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags-pgm_l                 :: DynFlags -> (String,[Option])-pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags-pgm_lm                 :: DynFlags -> Maybe (String,[Option])-pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags-pgm_dll               :: DynFlags -> (String,[Option])-pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags-pgm_T                 :: DynFlags -> String-pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags-pgm_windres           :: DynFlags -> String-pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags-pgm_lcc               :: DynFlags -> (String,[Option])-pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags-pgm_ar                :: DynFlags -> String-pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags-pgm_ranlib            :: DynFlags -> String-pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags-pgm_lo                :: DynFlags -> (String,[Option])-pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags-pgm_lc                :: DynFlags -> (String,[Option])-pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags-pgm_i                 :: DynFlags -> String-pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags-opt_L                 :: DynFlags -> [String]-opt_L dflags = toolSettings_opt_L $ toolSettings dflags-opt_P                 :: DynFlags -> [String]-opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)-            ++ toolSettings_opt_P (toolSettings dflags)---- This function packages everything that's needed to fingerprint opt_P--- flags. See Note [Repeated -optP hashing].-opt_P_signature       :: DynFlags -> ([String], Fingerprint)-opt_P_signature dflags =-  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)-  , toolSettings_opt_P_fingerprint $ toolSettings dflags-  )--opt_F                 :: DynFlags -> [String]-opt_F dflags= toolSettings_opt_F $ toolSettings dflags-opt_c                 :: DynFlags -> [String]-opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)-            ++ toolSettings_opt_c (toolSettings dflags)-opt_cxx               :: DynFlags -> [String]-opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags-opt_a                 :: DynFlags -> [String]-opt_a dflags= toolSettings_opt_a $ toolSettings dflags-opt_l                 :: DynFlags -> [String]-opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)-            ++ toolSettings_opt_l (toolSettings dflags)-opt_lm                :: DynFlags -> [String]-opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags-opt_windres           :: DynFlags -> [String]-opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags-opt_lcc                :: DynFlags -> [String]-opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags-opt_lo                :: DynFlags -> [String]-opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags-opt_lc                :: DynFlags -> [String]-opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags-opt_i                 :: DynFlags -> [String]-opt_i dflags= toolSettings_opt_i $ toolSettings dflags---- | The directory for this version of ghc in the user's app directory--- The appdir used to be in ~/.ghc but to respect the XDG specification--- we want to move it under $XDG_DATA_HOME/--- However, old tooling (like cabal) might still write package environments--- to the old directory, so we prefer that if a subdirectory of ~/.ghc--- with the correct target and GHC version suffix exists.------ i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that--- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR------ UNIQUE_SUBDIR is typically a combination of the target platform and GHC version-versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath-versionedAppDir appname platform = do-  -- Make sure we handle the case the HOME isn't set (see #11678)-  -- We need to fallback to the old scheme if the subdirectory exists.-  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))-       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/-       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/-       ]-  where-    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case-      True -> pure dir-      False -> MaybeT (pure Nothing)--versionedFilePath :: ArchOS -> FilePath-versionedFilePath platform = uniqueSubdir platform---- | The 'GhcMode' tells us whether we're doing multi-module--- compilation (controlled via the "GHC" API) or one-shot--- (single-module) compilation.  This makes a difference primarily to--- the "GHC.Unit.Finder": in one-shot mode we look for interface files for--- imported modules, but in multi-module mode we look for source files--- in order to check whether they need to be recompiled.-data GhcMode-  = CompManager         -- ^ @\-\-make@, GHCi, etc.-  | OneShot             -- ^ @ghc -c Foo.hs@-  | MkDepend            -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this-  deriving Eq--instance Outputable GhcMode where-  ppr CompManager = text "CompManager"-  ppr OneShot     = text "OneShot"-  ppr MkDepend    = text "MkDepend"--isOneShot :: GhcMode -> Bool-isOneShot OneShot = True-isOneShot _other  = False---- | What to do in the link step, if there is one.-data GhcLink-  = NoLink              -- ^ Don't link at all-  | LinkBinary          -- ^ Link object code into a binary-  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both-                        --   bytecode and object code).-  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)-  | LinkStaticLib       -- ^ Link objects into a static lib-  | LinkMergedObj       -- ^ Link objects into a merged "GHCi object"-  deriving (Eq, Show)--isNoLink :: GhcLink -> Bool-isNoLink NoLink = True-isNoLink _      = False---- | We accept flags which make packages visible, but how they select--- the package varies; this data type reflects what selection criterion--- is used.-data PackageArg =-      PackageArg String    -- ^ @-package@, by 'PackageName'-    | UnitIdArg Unit       -- ^ @-package-id@, by 'Unit'-  deriving (Eq, Show)--instance Outputable PackageArg where-    ppr (PackageArg pn) = text "package" <+> text pn-    ppr (UnitIdArg uid) = text "unit" <+> ppr uid---- | Represents the renaming that may be associated with an exposed--- package, e.g. the @rns@ part of @-package "foo (rns)"@.------ Here are some example parsings of the package flags (where--- a string literal is punned to be a 'ModuleName':------      * @-package foo@ is @ModRenaming True []@---      * @-package foo ()@ is @ModRenaming False []@---      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@---      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@---      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@-data ModRenaming = ModRenaming {-    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?-    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope-                                               --   under name @n@.-  } deriving (Eq)-instance Outputable ModRenaming where-    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)---- | Flags for manipulating the set of non-broken packages.-newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@-  deriving (Eq)---- | Flags for manipulating package trust.-data TrustFlag-  = TrustPackage    String -- ^ @-trust@-  | DistrustPackage String -- ^ @-distrust@-  deriving (Eq)---- | Flags for manipulating packages visibility.-data PackageFlag-  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@-  | HidePackage     String -- ^ @-hide-package@-  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged--data PackageDBFlag-  = PackageDB PkgDbRef-  | NoUserPackageDB-  | NoGlobalPackageDB-  | ClearPackageDBs-  deriving (Eq)--packageFlagsChanged :: DynFlags -> DynFlags -> Bool-packageFlagsChanged idflags1 idflags0 =-  packageFlags idflags1 /= packageFlags idflags0 ||-  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||-  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||-  trustFlags idflags1 /= trustFlags idflags0 ||-  packageDBFlags idflags1 /= packageDBFlags idflags0 ||-  packageGFlags idflags1 /= packageGFlags idflags0- where-   packageGFlags dflags = map (`gopt` dflags)-     [ Opt_HideAllPackages-     , Opt_HideAllPluginPackages-     , Opt_AutoLinkPackages ]--instance Outputable PackageFlag where-    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)-    ppr (HidePackage str) = text "-hide-package" <+> text str--data DynLibLoader-  = Deployable-  | SystemDependent-  deriving Eq--data RtsOptsEnabled-  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly-  | RtsOptsAll-  deriving (Show)---- | Are we building with @-fPIE@ or @-fPIC@ enabled?-positionIndependent :: DynFlags -> Bool-positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags---- Note [-dynamic-too business]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ With -dynamic-too flag, we try to build both the non-dynamic and dynamic--- objects in a single run of the compiler: the pipeline is the same down to--- Core optimisation, then the backend (from Core to object code) is executed--- twice.------ The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic--- and dynamic loaded interfaces (#9176).------ To make matters worse, we automatically enable -dynamic-too when some modules--- need Template-Haskell and GHC is dynamically linked (cf--- GHC.Driver.Pipeline.compileOne').------ We used to try and fall back from a dynamic-too failure but this feature--- didn't work as expected (#20446) so it was removed to simplify the--- implementation and not obscure latent bugs.--data DynamicTooState-   = DT_Dont    -- ^ Don't try to build dynamic objects too-   | DT_OK      -- ^ Will still try to generate dynamic objects-   | DT_Dyn     -- ^ Currently generating dynamic objects (in the backend)-   deriving (Eq,Show,Ord)--dynamicTooState :: DynFlags -> DynamicTooState-dynamicTooState dflags-   | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont-   | dynamicNow dflags = DT_Dyn-   | otherwise = DT_OK--setDynamicNow :: DynFlags -> DynFlags-setDynamicNow dflags0 =-   dflags0-      { dynamicNow = True-      }----------------------------------------------------------------------------------- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value-initDynFlags :: DynFlags -> IO DynFlags-initDynFlags dflags = do- let- refRtldInfo <- newIORef Nothing- refRtccInfo <- newIORef Nothing- refRtasmInfo <- newIORef Nothing- canUseUnicode <- do let enc = localeEncoding-                         str = "‘’"-                     (withCString enc str $ \cstr ->-                          do str' <- peekCString enc cstr-                             return (str == str'))-                         `catchIOError` \_ -> return False- ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"- let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode- maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"- maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"- let adjustCols (Just env) = Col.parseScheme env-     adjustCols Nothing    = id- let (useColor', colScheme') =-       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)-       (useColor dflags, colScheme dflags)- tmp_dir <- normalise <$> getTemporaryDirectory- return dflags{-        useUnicode    = useUnicode',-        useColor      = useColor',-        canUseColor   = stderrSupportsAnsiColors,-        colScheme     = colScheme',-        rtldInfo      = refRtldInfo,-        rtccInfo      = refRtccInfo,-        rtasmInfo     = refRtasmInfo,-        tmpDir        = TempDir tmp_dir-        }---- | The normal 'DynFlags'. Note that they are not suitable for use in this form--- and must be fully initialized by 'GHC.runGhc' first.-defaultDynFlags :: Settings -> DynFlags-defaultDynFlags mySettings =--- See Note [Updating flag description in the User's Guide]-     DynFlags {-        ghcMode                 = CompManager,-        ghcLink                 = LinkBinary,-        backend                 = platformDefaultBackend (sTargetPlatform mySettings),-        verbosity               = 0,-        debugLevel              = 0,-        simplPhases             = 2,-        maxSimplIterations      = 4,-        ruleCheck               = Nothing,-        binBlobThreshold        = Just 500000, -- 500K is a good default (see #16190)-        maxRelevantBinds        = Just 6,-        maxValidHoleFits   = Just 6,-        maxRefHoleFits     = Just 6,-        refLevelHoleFits   = Nothing,-        maxUncoveredPatterns    = 4,-        maxPmCheckModels        = 30,-        simplTickFactor         = 100,-        dmdUnboxWidth           = 3,      -- Default: Assume an unboxed demand on function bodies returning a triple-        specConstrThreshold     = Just 2000,-        specConstrCount         = Just 3,-        specConstrRecursive     = 3,-        liberateCaseThreshold   = Just 2000,-        floatLamArgs            = Just 0, -- Default: float only if no fvs-        liftLamsRecArgs         = Just 5, -- Default: the number of available argument hardware registers on x86_64-        liftLamsNonRecArgs      = Just 5, -- Default: the number of available argument hardware registers on x86_64-        liftLamsKnown           = False,  -- Default: don't turn known calls into unknown ones-        cmmProcAlignment        = Nothing,--        historySize             = 20,-        strictnessBefore        = [],--        parMakeCount            = Just 1,--        enableTimeStats         = False,-        ghcHeapSize             = Nothing,--        importPaths             = ["."],-        mainModuleNameIs        = mAIN_NAME,-        mainFunIs               = Nothing,-        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,-        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,--        homeUnitId_             = mainUnitId,-        homeUnitInstanceOf_     = Nothing,-        homeUnitInstantiations_ = [],--        workingDirectory        = Nothing,-        thisPackageName         = Nothing,-        hiddenModules           = Set.empty,-        reexportedModules       = Set.empty,--        objectDir               = Nothing,-        dylibInstallName        = Nothing,-        hiDir                   = Nothing,-        hieDir                  = Nothing,-        stubDir                 = Nothing,-        dumpDir                 = Nothing,--        objectSuf_              = phaseInputExt StopLn,-        hcSuf                   = phaseInputExt HCc,-        hiSuf_                  = "hi",-        hieSuf                  = "hie",--        dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,-        dynHiSuf_               = "dyn_hi",-        dynamicNow              = False,--        pluginModNames          = [],-        pluginModNameOpts       = [],-        frontendPluginOpts      = [],--        externalPluginSpecs     = [],--        outputFile_             = Nothing,-        dynOutputFile_          = Nothing,-        outputHi                = Nothing,-        dynOutputHi             = Nothing,-        dynLibLoader            = SystemDependent,-        dumpPrefix              = "non-module.",-        dumpPrefixForce         = Nothing,-        ldInputs                = [],-        includePaths            = IncludeSpecs [] [] [],-        libraryPaths            = [],-        frameworkPaths          = [],-        cmdlineFrameworks       = [],-        rtsOpts                 = Nothing,-        rtsOptsEnabled          = RtsOptsSafeOnly,-        rtsOptsSuggestions      = True,--        hpcDir                  = ".hpc",--        packageDBFlags          = [],-        packageFlags            = [],-        pluginPackageFlags      = [],-        ignorePackageFlags      = [],-        trustFlags              = [],-        packageEnv              = Nothing,-        targetWays_             = Set.empty,-        splitInfo               = Nothing,--        ghcNameVersion = sGhcNameVersion mySettings,-        fileSettings = sFileSettings mySettings,-        toolSettings = sToolSettings mySettings,-        targetPlatform = sTargetPlatform mySettings,-        platformMisc = sPlatformMisc mySettings,-        rawSettings = sRawSettings mySettings,--        tmpDir                  = panic "defaultDynFlags: uninitialized tmpDir",--        llvmOptLevel            = 0,--        -- ghc -M values-        depMakefile       = "Makefile",-        depIncludePkgDeps = False,-        depIncludeCppDeps = False,-        depExcludeMods    = [],-        depSuffixes       = [],-        -- end of ghc -M values-        ghcVersionFile = Nothing,-        haddockOptions = Nothing,-        dumpFlags = EnumSet.empty,-        generalFlags = EnumSet.fromList (defaultFlags mySettings),-        warningFlags = EnumSet.fromList standardWarnings,-        fatalWarningFlags = EnumSet.empty,-        ghciScripts = [],-        language = Nothing,-        safeHaskell = Sf_None,-        safeInfer   = True,-        safeInferred = True,-        thOnLoc = noSrcSpan,-        newDerivOnLoc = noSrcSpan,-        deriveViaOnLoc = noSrcSpan,-        overlapInstLoc = noSrcSpan,-        incoherentOnLoc = noSrcSpan,-        pkgTrustOnLoc = noSrcSpan,-        warnSafeOnLoc = noSrcSpan,-        warnUnsafeOnLoc = noSrcSpan,-        trustworthyOnLoc = noSrcSpan,-        extensions = [],-        extensionFlags = flattenExtensionFlags Nothing [],--        unfoldingOpts = defaultUnfoldingOpts,-        maxWorkerArgs = 10,--        ghciHistSize = 50, -- keep a log of length 50 by default--        flushOut = defaultFlushOut,-        pprUserLength = 5,-        pprCols = 100,-        useUnicode = False,-        useColor = Auto,-        canUseColor = False,-        colScheme = Col.defaultScheme,-        profAuto = NoProfAuto,-        callerCcFilters = [],-        interactivePrint = Nothing,-        sseVersion = Nothing,-        bmiVersion = Nothing,-        avx = False,-        avx2 = False,-        avx512cd = False,-        avx512er = False,-        avx512f = False,-        avx512pf = False,-        rtldInfo = panic "defaultDynFlags: no rtldInfo",-        rtccInfo = panic "defaultDynFlags: no rtccInfo",-        rtasmInfo = panic "defaultDynFlags: no rtasmInfo",--        maxInlineAllocSize = 128,-        maxInlineMemcpyInsns = 32,-        maxInlineMemsetInsns = 32,--        initialUnique = 0,-        uniqueIncrement = 1,--        reverseErrors = False,-        maxErrors     = Nothing,-        cfgWeights    = defaultWeights-      }--type FatalMessager = String -> IO ()--defaultFatalMessager :: FatalMessager-defaultFatalMessager = hPutStrLn stderr---newtype FlushOut = FlushOut (IO ())--defaultFlushOut :: FlushOut-defaultFlushOut = FlushOut $ hFlush stdout--{--Note [Verbosity levels]-~~~~~~~~~~~~~~~~~~~~~~~-    0   |   print errors & warnings only-    1   |   minimal verbosity: print "compiling M ... done." for each module.-    2   |   equivalent to -dshow-passes-    3   |   equivalent to existing "ghc -v"-    4   |   "ghc -v -ddump-most"-    5   |   "ghc -v -ddump-all"--}--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-flattenExtensionFlags ml = foldr f defaultExtensionFlags-    where f (On f)  flags = EnumSet.insert f flags-          f (Off f) flags = EnumSet.delete f flags-          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)---- | The language extensions implied by the various language variants.--- When updating this be sure to update the flag documentation in--- @docs/users_guide/exts@.-languageExtensions :: Maybe Language -> [LangExt.Extension]---- Nothing: the default case-languageExtensions Nothing = languageExtensions (Just GHC2021)--languageExtensions (Just Haskell98)-    = [LangExt.ImplicitPrelude,-       -- See Note [When is StarIsType enabled]-       LangExt.StarIsType,-       LangExt.CUSKs,-       LangExt.MonomorphismRestriction,-       LangExt.NPlusKPatterns,-       LangExt.DatatypeContexts,-       LangExt.TraditionalRecordSyntax,-       LangExt.FieldSelectors,-       LangExt.NondecreasingIndentation,-           -- strictly speaking non-standard, but we always had this-           -- on implicitly before the option was added in 7.1, and-           -- turning it off breaks code, so we're keeping it on for-           -- backwards compatibility.  Cabal uses -XHaskell98 by-           -- default unless you specify another language.-       LangExt.DeepSubsumption-       -- Non-standard but enabled for backwards compatability (see GHC proposal #511)-      ]--languageExtensions (Just Haskell2010)-    = [LangExt.ImplicitPrelude,-       -- See Note [When is StarIsType enabled]-       LangExt.StarIsType,-       LangExt.CUSKs,-       LangExt.MonomorphismRestriction,-       LangExt.DatatypeContexts,-       LangExt.TraditionalRecordSyntax,-       LangExt.EmptyDataDecls,-       LangExt.ForeignFunctionInterface,-       LangExt.PatternGuards,-       LangExt.DoAndIfThenElse,-       LangExt.FieldSelectors,-       LangExt.RelaxedPolyRec,-       LangExt.DeepSubsumption ]--languageExtensions (Just GHC2021)-    = [LangExt.ImplicitPrelude,-       -- See Note [When is StarIsType enabled]-       LangExt.StarIsType,-       LangExt.MonomorphismRestriction,-       LangExt.TraditionalRecordSyntax,-       LangExt.EmptyDataDecls,-       LangExt.ForeignFunctionInterface,-       LangExt.PatternGuards,-       LangExt.DoAndIfThenElse,-       LangExt.FieldSelectors,-       LangExt.RelaxedPolyRec,-       -- Now the new extensions (not in Haskell2010)-       LangExt.BangPatterns,-       LangExt.BinaryLiterals,-       LangExt.ConstrainedClassMethods,-       LangExt.ConstraintKinds,-       LangExt.DeriveDataTypeable,-       LangExt.DeriveFoldable,-       LangExt.DeriveFunctor,-       LangExt.DeriveGeneric,-       LangExt.DeriveLift,-       LangExt.DeriveTraversable,-       LangExt.EmptyCase,-       LangExt.EmptyDataDeriving,-       LangExt.ExistentialQuantification,-       LangExt.ExplicitForAll,-       LangExt.FlexibleContexts,-       LangExt.FlexibleInstances,-       LangExt.GADTSyntax,-       LangExt.GeneralizedNewtypeDeriving,-       LangExt.HexFloatLiterals,-       LangExt.ImportQualifiedPost,-       LangExt.InstanceSigs,-       LangExt.KindSignatures,-       LangExt.MultiParamTypeClasses,-       LangExt.NamedFieldPuns,-       LangExt.NamedWildCards,-       LangExt.NumericUnderscores,-       LangExt.PolyKinds,-       LangExt.PostfixOperators,-       LangExt.RankNTypes,-       LangExt.ScopedTypeVariables,-       LangExt.StandaloneDeriving,-       LangExt.StandaloneKindSignatures,-       LangExt.TupleSections,-       LangExt.TypeApplications,-       LangExt.TypeOperators,-       LangExt.TypeSynonymInstances]--hasPprDebug :: DynFlags -> Bool-hasPprDebug = dopt Opt_D_ppr_debug--hasNoDebugOutput :: DynFlags -> Bool-hasNoDebugOutput = dopt Opt_D_no_debug_output--hasNoStateHack :: DynFlags -> Bool-hasNoStateHack = gopt Opt_G_NoStateHack--hasNoOptCoercion :: DynFlags -> Bool-hasNoOptCoercion = gopt Opt_G_NoOptCoercion----- | Test whether a 'DumpFlag' is set-dopt :: DumpFlag -> DynFlags -> Bool-dopt = getDumpFlagFrom verbosity dumpFlags---- | Set a 'DumpFlag'-dopt_set :: DynFlags -> DumpFlag -> DynFlags-dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) }---- | Unset a 'DumpFlag'-dopt_unset :: DynFlags -> DumpFlag -> DynFlags-dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }---- | Test whether a 'GeneralFlag' is set------ Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`)--- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables--- Opt_SplitSections.----gopt :: GeneralFlag -> DynFlags -> Bool-gopt Opt_PIC dflags-   | dynamicNow dflags = True-gopt Opt_ExternalDynamicRefs dflags-   | dynamicNow dflags = True-gopt Opt_SplitSections dflags-   | dynamicNow dflags = False-gopt f dflags = f `EnumSet.member` generalFlags dflags---- | Set a 'GeneralFlag'-gopt_set :: DynFlags -> GeneralFlag -> DynFlags-gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) }---- | Unset a 'GeneralFlag'-gopt_unset :: DynFlags -> GeneralFlag -> DynFlags-gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) }---- | Test whether a 'WarningFlag' is set-wopt :: WarningFlag -> DynFlags -> Bool-wopt f dflags  = f `EnumSet.member` warningFlags dflags---- | Set a 'WarningFlag'-wopt_set :: DynFlags -> WarningFlag -> DynFlags-wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) }---- | Unset a 'WarningFlag'-wopt_unset :: DynFlags -> WarningFlag -> DynFlags-wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) }---- | Test whether a 'WarningFlag' is set as fatal-wopt_fatal :: WarningFlag -> DynFlags -> Bool-wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags---- | Mark a 'WarningFlag' as fatal (do not set the flag)-wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags-wopt_set_fatal dfs f-    = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) }---- | Mark a 'WarningFlag' as not fatal-wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags-wopt_unset_fatal dfs f-    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }---- | Test whether a 'LangExt.Extension' is set-xopt :: LangExt.Extension -> DynFlags -> Bool-xopt f dflags = f `EnumSet.member` extensionFlags dflags---- | Set a 'LangExt.Extension'-xopt_set :: DynFlags -> LangExt.Extension -> DynFlags-xopt_set dfs f-    = let onoffs = On f : extensions dfs-      in dfs { extensions = onoffs,-               extensionFlags = flattenExtensionFlags (language dfs) onoffs }---- | Unset a 'LangExt.Extension'-xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags-xopt_unset dfs f-    = let onoffs = Off f : extensions dfs-      in dfs { extensions = onoffs,-               extensionFlags = flattenExtensionFlags (language dfs) onoffs }---- | Set or unset a 'LangExt.Extension', unless it has been explicitly---   set or unset before.-xopt_set_unlessExplSpec-        :: LangExt.Extension-        -> (DynFlags -> LangExt.Extension -> DynFlags)-        -> DynFlags -> DynFlags-xopt_set_unlessExplSpec ext setUnset dflags =-    let referedExts = stripOnOff <$> extensions dflags-        stripOnOff (On x)  = x-        stripOnOff (Off x) = x-    in-        if ext `elem` referedExts then dflags else setUnset dflags ext--xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields-xopt_DuplicateRecordFields dfs-  | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields-  | otherwise                              = FieldLabel.NoDuplicateRecordFields--xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors-xopt_FieldSelectors dfs-  | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors-  | otherwise                       = FieldLabel.NoFieldSelectors--lang_set :: DynFlags -> Maybe Language -> DynFlags-lang_set dflags lang =-   dflags {-            language = lang,-            extensionFlags = flattenExtensionFlags lang (extensions dflags)-          }---- | Set the Haskell language standard to use-setLanguage :: Language -> DynP ()-setLanguage l = upd (`lang_set` Just l)---- | Is the -fpackage-trust mode on-packageTrustOn :: DynFlags -> Bool-packageTrustOn = gopt Opt_PackageTrust---- | Is Safe Haskell on in some way (including inference mode)-safeHaskellOn :: DynFlags -> Bool-safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags--safeHaskellModeEnabled :: DynFlags -> Bool-safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy-                                                   , Sf_Safe ]----- | Is the Safe Haskell safe language in use-safeLanguageOn :: DynFlags -> Bool-safeLanguageOn dflags = safeHaskell dflags == Sf_Safe---- | Is the Safe Haskell safe inference mode active-safeInferOn :: DynFlags -> Bool-safeInferOn = safeInfer---- | Test if Safe Imports are on in some form-safeImportsOn :: DynFlags -> Bool-safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||-                       safeHaskell dflags == Sf_Trustworthy ||-                       safeHaskell dflags == Sf_Safe---- | Set a 'Safe Haskell' flag-setSafeHaskell :: SafeHaskellMode -> DynP ()-setSafeHaskell s = updM f-    where f dfs = do-              let sf = safeHaskell dfs-              safeM <- combineSafeFlags sf s-              case s of-                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }-                -- leave safe inference on in Trustworthy mode so we can warn-                -- if it could have been inferred safe.-                Sf_Trustworthy -> do-                  l <- getCurLoc-                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }-                -- leave safe inference on in Unsafe mode as well.-                _ -> return $ dfs { safeHaskell = safeM }---- | Are all direct imports required to be safe for this Safe Haskell mode?--- Direct imports are when the code explicitly imports a module-safeDirectImpsReq :: DynFlags -> Bool-safeDirectImpsReq d = safeLanguageOn d---- | Are all implicit imports required to be safe for this Safe Haskell mode?--- Implicit imports are things in the prelude. e.g System.IO when print is used.-safeImplicitImpsReq :: DynFlags -> Bool-safeImplicitImpsReq d = safeLanguageOn d---- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.--- This makes Safe Haskell very much a monoid but for now I prefer this as I don't--- want to export this functionality from the module but do want to export the--- type constructors.-combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode-combineSafeFlags a b | a == Sf_None         = return b-                     | b == Sf_None         = return a-                     | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore-                     | a == b               = return a-                     | otherwise            = addErr errm >> pure a-    where errm = "Incompatible Safe Haskell flags! ("-                    ++ show a ++ ", " ++ show b ++ ")"---- | A list of unsafe flags under Safe Haskell. Tuple elements are:---     * name of the flag---     * function to get srcspan that enabled the flag---     * function to test if the flag is on---     * function to turn the flag off-unsafeFlags, unsafeFlagsForInfer-  :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]-unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,-                    xopt LangExt.GeneralizedNewtypeDeriving,-                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)-              , ("-XDerivingVia", deriveViaOnLoc,-                    xopt LangExt.DerivingVia,-                    flip xopt_unset LangExt.DerivingVia)-              , ("-XTemplateHaskell", thOnLoc,-                    xopt LangExt.TemplateHaskell,-                    flip xopt_unset LangExt.TemplateHaskell)-              ]-unsafeFlagsForInfer = unsafeFlags----- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order-getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from-        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors-        -> [a]                  -- ^ Correctly ordered extracted options-getOpts dflags opts = reverse (opts dflags)-        -- We add to the options from the front, so we need to reverse the list---- | Gets the verbosity flag for the current verbosity level. This is fed to--- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included-getVerbFlags :: DynFlags -> [String]-getVerbFlags dflags-  | verbosity dflags >= 4 = ["-v"]-  | otherwise             = []--setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,-         setDynObjectSuf, setDynHiSuf,-         setDylibInstallName,-         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,-         setPgmP, addOptl, addOptc, addOptcxx, addOptP,-         addCmdlineFramework, addHaddockOpts, addGhciScript,-         setInteractivePrint-   :: String -> DynFlags -> DynFlags-setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce-   :: Maybe String -> DynFlags -> DynFlags--setObjectDir  f d = d { objectDir  = Just f}-setHiDir      f d = d { hiDir      = Just f}-setHieDir     f d = d { hieDir     = Just f}-setStubDir    f d = d { stubDir    = Just f-                      , includePaths = addGlobalInclude (includePaths d) [f] }-  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file-  -- \#included from the .hc file when compiling via C (i.e. unregisterised-  -- builds).-setDumpDir    f d = d { dumpDir    = Just f}-setOutputDir  f = setObjectDir f-                . setHieDir f-                . setHiDir f-                . setStubDir f-                . setDumpDir f-setDylibInstallName  f d = d { dylibInstallName = Just f}--setObjectSuf    f d = d { objectSuf_    = f}-setDynObjectSuf f d = d { dynObjectSuf_ = f}-setHiSuf        f d = d { hiSuf_        = f}-setHieSuf       f d = d { hieSuf        = f}-setDynHiSuf     f d = d { dynHiSuf_     = f}-setHcSuf        f d = d { hcSuf         = f}--setOutputFile    f d = d { outputFile_    = f}-setDynOutputFile f d = d { dynOutputFile_ = f}-setOutputHi      f d = d { outputHi       = f}-setDynOutputHi   f d = d { dynOutputHi    = f}--parseUnitInsts :: String -> Instantiations-parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of-    [(r, "")] -> r-    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)-  where parse = sepBy parseEntry (R.char ',')-        parseEntry = do-            n <- parseModuleName-            _ <- R.char '='-            m <- parseHoleyModule-            return (n, m)--setUnitInstantiations :: String -> DynFlags -> DynFlags-setUnitInstantiations s d =-    d { homeUnitInstantiations_ = parseUnitInsts s }--setUnitInstanceOf :: String -> DynFlags -> DynFlags-setUnitInstanceOf s d =-    d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) }--addPluginModuleName :: String -> DynFlags -> DynFlags-addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }--clearPluginModuleNames :: DynFlags -> DynFlags-clearPluginModuleNames d =-    d { pluginModNames = []-      , pluginModNameOpts = []-      }--addPluginModuleNameOption :: String -> DynFlags -> DynFlags-addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }-  where (m, rest) = break (== ':') optflag-        option = case rest of-          [] -> "" -- should probably signal an error-          (_:plug_opt) -> plug_opt -- ignore the ':' from break--addExternalPlugin :: String -> DynFlags -> DynFlags-addExternalPlugin optflag d = case parseExternalPluginSpec optflag of-  Just r  -> d { externalPluginSpecs = r : externalPluginSpecs d }-  Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag--addFrontendPluginOption :: String -> DynFlags -> DynFlags-addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }--parseDynLibLoaderMode f d =- case splitAt 8 f of-   ("deploy", "")       -> d { dynLibLoader = Deployable }-   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }-   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))--setDumpPrefixForce f d = d { dumpPrefixForce = f}---- 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-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})-addOptP   f = alterToolSettings $ \s -> s-          { toolSettings_opt_P   = f : toolSettings_opt_P s-          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)-          }-          -- See Note [Repeated -optP hashing]-  where-  fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss---setDepMakefile :: FilePath -> DynFlags -> DynFlags-setDepMakefile f d = d { depMakefile = f }--setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags-setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }--setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags-setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }--addDepExcludeMod :: String -> DynFlags -> DynFlags-addDepExcludeMod m d-    = d { depExcludeMods = mkModuleName m : depExcludeMods d }--addDepSuffix :: FilePath -> DynFlags -> DynFlags-addDepSuffix s d = d { depSuffixes = s : depSuffixes d }--addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}--addGhcVersionFile :: FilePath -> DynFlags -> DynFlags-addGhcVersionFile f d = d { ghcVersionFile = Just f }--addHaddockOpts f d = d { haddockOptions = Just f}--addGhciScript f d = d { ghciScripts = f : ghciScripts d}--setInteractivePrint f d = d { interactivePrint = Just f}---------------------------------------------------------------------------------- Setting the optimisation level--updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool)--- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place-updOptLevelChanged n dfs-  = (dfs3, changed1 || changed2 || changed3)-  where-   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2-   (dfs1, changed1) = foldr unset (dfs , False) remove_gopts-   (dfs2, changed2) = foldr set   (dfs1, False) extra_gopts-   (dfs3, changed3) = setLlvmOptLevel dfs2--   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]-   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]--   set f (dfs, changed)-     | gopt f dfs = (dfs, changed)-     | otherwise = (gopt_set dfs f, True)--   unset f (dfs, changed)-     | not (gopt f dfs) = (dfs, changed)-     | otherwise = (gopt_unset dfs f, True)--   setLlvmOptLevel dfs-     | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True)-     | otherwise = (dfs, False)--updOptLevel :: Int -> DynFlags -> DynFlags--- ^ Sets the 'DynFlags' to be appropriate to the optimisation level-updOptLevel n = fst . updOptLevelChanged n--{- **********************************************************************-%*                                                                      *-                DynFlags parser-%*                                                                      *-%********************************************************************* -}---- -------------------------------------------------------------------------------- Parsing the dynamic flags.----- | Parse dynamic flags from a list of command line arguments.  Returns--- 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]-                         -> m (DynFlags, [Located String], [Warn])-                            -- ^ Updated 'DynFlags', left-over arguments, and-                            -- list of warnings.-parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True----- | 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]-                       -> m (DynFlags, [Located String], [Warn])-                          -- ^ Updated 'DynFlags', left-over arguments, and-                          -- list of warnings.-parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False--newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)-  deriving (Functor)--instance Monad (CmdLineP s) where-    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)-    return = pure--instance Applicative (CmdLineP s) where-    pure x = CmdLineP (pure x)-    (<*>) = ap--getCmdLineState :: CmdLineP s s-getCmdLineState = CmdLineP State.get--putCmdLineState :: s -> CmdLineP s ()-putCmdLineState x = CmdLineP (State.put x)--runCmdLineP :: CmdLineP s a -> s -> (a, s)-runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0---- | A helper to parse a set of flags from a list of command-line arguments, handling--- response files.-processCmdLineP-    :: forall s m. MonadIO m-    => [Flag (CmdLineP s)]  -- ^ valid flags to match against-    -> s                    -- ^ current state-    -> [Located String]     -- ^ arguments to parse-    -> m (([Located String], [Err], [Warn]), s)-                            -- ^ (leftovers, errors, warnings)-processCmdLineP activeFlags s0 args =-    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0-  where-    getCmdLineP :: CmdLineP s a -> StateT s m a-    getCmdLineP (CmdLineP k) = k---- | Parses the dynamically set flags for GHC. This is the most general form of--- the dynamic flag parser that the other methods simply wrap. It allows--- saying which flags are valid flags and indicating if we are parsing--- arguments from the command line or from a file pragma.-parseDynamicFlagsFull-    :: forall m. MonadIO m-    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against-    -> Bool                          -- ^ are the arguments from the command line?-    -> DynFlags                      -- ^ current dynamic flags-    -> [Located String]              -- ^ arguments to parse-    -> m (DynFlags, [Located String], [Warn])-parseDynamicFlagsFull activeFlags cmdline dflags0 args = do-  ((leftover, errs, warns), dflags1) <- processCmdLineP activeFlags dflags0 args--  -- See Note [Handling errors when parsing command-line flags]-  let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)-  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $-    map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs--  -- check for disabled flags in safe haskell-  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1-      theWays = ways dflags2--  unless (allowed_combination theWays) $ liftIO $-      throwGhcExceptionIO (CmdLineError ("combination not supported: " ++-                               intercalate "/" (map wayDesc (Set.toAscList theWays))))--  let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2--  -- Set timer stats & heap size-  when (enableTimeStats dflags3) $ liftIO enableTimingStats-  case (ghcHeapSize dflags3) of-    Just x -> liftIO (setHeapSize x)-    _      -> return ()--  liftIO $ setUnsafeGlobalDynFlags dflags3--  let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns)--  return (dflags3, leftover, warns' ++ warns)---- | Check (and potentially disable) any extensions that aren't allowed--- in safe mode.------ The bool is to indicate if we are parsing command line flags (false means--- file pragma). This allows us to generate better warnings.-safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])-safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)-  where-    -- Handle illegal flags under safe language.-    (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags--    check_method (df, warns) (str,loc,test,fix)-        | test df   = (fix df, warns ++ safeFailure (loc df) str)-        | otherwise = (df, warns)--    safeFailure loc str-       = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring "-           ++ str]--safeFlagCheck cmdl dflags =-  case safeInferOn dflags of-    True   -> (dflags' { safeInferred = safeFlags }, warn)-    False  -> (dflags', warn)--  where-    -- dynflags and warn for when -fpackage-trust by itself with no safe-    -- haskell flag-    (dflags', warn)-      | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags-      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)-      | otherwise = (dflags, [])--    pkgWarnMsg = [L (pkgTrustOnLoc dflags') $-                    "-fpackage-trust ignored;" ++-                    " must be specified with a Safe Haskell flag"]--    -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main-    -- Force this to avoid retaining reference to old DynFlags value-    !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer---{- **********************************************************************-%*                                                                      *-                DynFlags specifications-%*                                                                      *-%********************************************************************* -}---- | All dynamic flags option strings without the deprecated ones.--- These are the user facing strings for enabling and disabling options.-allNonDeprecatedFlags :: [String]-allNonDeprecatedFlags = allFlagsDeps False---- | All flags with possibility to filter deprecated ones-allFlagsDeps :: Bool -> [String]-allFlagsDeps keepDeprecated = [ '-':flagName flag-                              | (deprecated, flag) <- flagsAllDeps-                              , keepDeprecated || not (isDeprecated deprecated)]-  where isDeprecated Deprecated = True-        isDeprecated _ = False--{-- - Below we export user facing symbols for GHC dynamic flags for use with the- - GHC API.- -}---- All dynamic flags present in GHC.-flagsAll :: [Flag (CmdLineP DynFlags)]-flagsAll = map snd flagsAllDeps---- All dynamic flags present in GHC with deprecation information.-flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]-flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps----- All dynamic flags, minus package flags, present in GHC.-flagsDynamic :: [Flag (CmdLineP DynFlags)]-flagsDynamic = map snd dynamic_flags_deps---- ALl package flags present in GHC.-flagsPackage :: [Flag (CmdLineP DynFlags)]-flagsPackage = map snd package_flags_deps------------------Helpers to make flags and keep deprecation information------------type FlagMaker m = String -> OptKind m -> Flag m-type DynFlagMaker = FlagMaker (CmdLineP DynFlags)-data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord)---- Make a non-deprecated flag-make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)-              -> (Deprecation, Flag (CmdLineP DynFlags))-make_ord_flag fm name kind = (NotDeprecated, fm name kind)---- Make a deprecated flag-make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String-                 -> (Deprecation, Flag (CmdLineP DynFlags))-make_dep_flag fm name kind message = (Deprecated,-                                      fm name $ add_dep_message kind message)--add_dep_message :: OptKind (CmdLineP DynFlags) -> String-                -> OptKind (CmdLineP DynFlags)-add_dep_message (NoArg f) message = NoArg $ f >> deprecate message-add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message-add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message-add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message-add_dep_message (OptPrefix f) message =-                                  OptPrefix $ \s -> f s >> deprecate message-add_dep_message (OptIntSuffix f) message =-                               OptIntSuffix $ \oi -> f oi >> deprecate message-add_dep_message (IntSuffix f) message =-                                  IntSuffix $ \i -> f i >> deprecate message-add_dep_message (Word64Suffix f) message =-                                  Word64Suffix $ \i -> f i >> deprecate message-add_dep_message (FloatSuffix f) message =-                                FloatSuffix $ \fl -> f fl >> deprecate message-add_dep_message (PassFlag f) message =-                                   PassFlag $ \s -> f s >> deprecate message-add_dep_message (AnySuffix f) message =-                                  AnySuffix $ \s -> f s >> deprecate message------------------------- The main flags themselves --------------------------------- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]-dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]-dynamic_flags_deps = [-    make_dep_flag defFlag "n" (NoArg $ return ())-        "The -n flag is deprecated and no longer has any effect"-  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))-  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))-  , (Deprecated, defFlag "#include"-      (HasArg (\_s ->-         deprecate ("-#include and INCLUDE pragmas are " ++-                    "deprecated: They no longer have any effect"))))-  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)--  , make_ord_flag defGhcFlag "j"     (OptIntSuffix-        (\n -> case n of-                 Just n-                     | n > 0     -> upd (\d -> d { parMakeCount = Just n })-                     | otherwise -> addErr "Syntax: -j[n] where n > 0"-                 Nothing -> upd (\d -> d { parMakeCount = Nothing })))-                 -- When the number of parallel builds-                 -- is omitted, it is the same-                 -- as specifying that the number of-                 -- parallel builds is equal to the-                 -- result of getNumProcessors-  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)-  , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)--    -- RTS options --------------------------------------------------------------  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->-          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))--  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->-                                               d { enableTimeStats = True })))--    ------- ways ----------------------------------------------------------------  , make_ord_flag defGhcFlag "prof"           (NoArg (addWayDynP WayProf))-  , (Deprecated, defFlag     "eventlog"-     $ noArgM $ \d -> do-         deprecate "the eventlog is now enabled in all runtime system ways"-         return d)-  , make_ord_flag defGhcFlag "debug"          (NoArg (addWayDynP WayDebug))-  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWayDynP WayThreaded))--  , make_ord_flag defGhcFlag "ticky"-      (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))--    -- -ticky enables ticky-ticky code generation, and also implies -debug which-    -- is required to get the RTS ticky support.--        ----- Linker ---------------------------------------------------------  , make_ord_flag defGhcFlag "static"         (NoArg removeWayDyn)-  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWayDynP WayDyn))-  , make_ord_flag defGhcFlag "rdynamic" $ noArg $-#if defined(linux_HOST_OS)-                              addOptl "-rdynamic"-#elif defined(mingw32_HOST_OS)-                              addOptl "-Wl,--export-all-symbols"-#else-    -- ignored for compat w/ gcc:-                              id-#endif-  , make_ord_flag defGhcFlag "relative-dynlib-paths"-      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))-  , make_ord_flag defGhcFlag "copy-libs-when-linking"-      (NoArg (setGeneralFlag Opt_SingleLibFolder))-  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))-  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))--        ------- Specific phases  ---------------------------------------------    -- need to appear before -pgmL to be parsed as LLVM flags.-  , make_ord_flag defFlag "pgmlo"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }-  , make_ord_flag defFlag "pgmlc"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }-  , make_ord_flag defFlag "pgmlm"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  =-          if null f then Nothing else Just (f,[]) }-  , make_ord_flag defFlag "pgmi"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i   =  f }-  , make_ord_flag defFlag "pgmL"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L   = f }-  , make_ord_flag defFlag "pgmP"-      (hasArg setPgmP)-  , make_ord_flag defFlag "pgmF"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F   = f }-  , make_ord_flag defFlag "pgmc"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c   = f }-  , make_ord_flag defFlag "pgmcxx"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f }-  , (Deprecated, defFlag  "pgmc-supports-no-pie"-      $ noArgM  $ \d -> do-        deprecate $ "use -pgml-supports-no-pie instead"-        pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d)-  , make_ord_flag defFlag "pgms"-      (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8"))-  , make_ord_flag defFlag "pgma"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a   = (f,[]) }-  , make_ord_flag defFlag "pgml"-      $ hasArg $ \f -> alterToolSettings $ \s -> s-         { toolSettings_pgm_l   = (f,[])-         , -- Don't pass -no-pie with custom -pgml (see #15319). Note-           -- that this could break when -no-pie is actually needed.-           -- But the CC_SUPPORTS_NO_PIE check only happens at-           -- buildtime, and -pgml is a runtime option. A better-           -- solution would be running this check for each custom-           -- -pgml.-           toolSettings_ccSupportsNoPie = False-         }-  , make_ord_flag defFlag "pgml-supports-no-pie"-      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }-  , make_ord_flag defFlag "pgmdll"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) }-  , make_ord_flag defFlag "pgmwindres"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }-  , make_ord_flag defFlag "pgmar"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f }-  , make_ord_flag defFlag "pgmotool"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f}-  , make_ord_flag defFlag "pgminstall_name_tool"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f}-  , make_ord_flag defFlag "pgmranlib"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f }---    -- need to appear before -optl/-opta to be parsed as LLVM flags.-  , make_ord_flag defFlag "optlm"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm  = f : toolSettings_opt_lm s }-  , make_ord_flag defFlag "optlo"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }-  , make_ord_flag defFlag "optlc"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }-  , make_ord_flag defFlag "opti"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }-  , make_ord_flag defFlag "optL"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L   = f : toolSettings_opt_L s }-  , make_ord_flag defFlag "optP"-      (hasArg addOptP)-  , make_ord_flag defFlag "optF"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F   = f : toolSettings_opt_F s }-  , make_ord_flag defFlag "optc"-      (hasArg addOptc)-  , make_ord_flag defFlag "optcxx"-      (hasArg addOptcxx)-  , make_ord_flag defFlag "opta"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a   = f : toolSettings_opt_a s }-  , make_ord_flag defFlag "optl"-      (hasArg addOptl)-  , make_ord_flag defFlag "optwindres"-      $ hasArg $ \f ->-        alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s }--  , make_ord_flag defGhcFlag "split-objs"-      (NoArg $ addWarn "ignoring -split-objs")--    -- N.B. We may someday deprecate this in favor of -fsplit-sections,-    -- which has the benefit of also having a negating -fno-split-sections.-  , make_ord_flag defGhcFlag "split-sections"-      (NoArg $ setGeneralFlag Opt_SplitSections)--        -------- ghc -M ------------------------------------------------------  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)-  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)-  , make_ord_flag defGhcFlag "include-cpp-deps"-        (noArg (setDepIncludeCppDeps True))-  , make_ord_flag defGhcFlag "include-pkg-deps"-        (noArg (setDepIncludePkgDeps True))-  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)--        -------- Linking -----------------------------------------------------  , make_ord_flag defGhcFlag "no-link"-        (noArg (\d -> d { ghcLink=NoLink }))-  , make_ord_flag defGhcFlag "shared"-        (noArg (\d -> d { ghcLink=LinkDynLib }))-  , make_ord_flag defGhcFlag "staticlib"-        (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))-  , make_ord_flag defGhcFlag "-merge-objs"-        (noArg (\d -> d { ghcLink=LinkMergedObj }))-  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)-  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)--        ------- Libraries ----------------------------------------------------  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)-  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))--        ------- Frameworks ---------------------------------------------------        -- -framework-path should really be -F ...-  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)-  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)--        ------- Output Redirection -------------------------------------------  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)-  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))-  , make_ord_flag defGhcFlag "dyno"-        (sepArg (setDynOutputFile . Just))-  , make_ord_flag defGhcFlag "ohi"-        (hasArg (setOutputHi . Just ))-  , make_ord_flag defGhcFlag "dynohi"-        (hasArg (setDynOutputHi . Just ))-  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)-  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)-  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)-  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)-  , make_ord_flag defGhcFlag "hiesuf"            (hasArg setHieSuf)-  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)-  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)-  , make_ord_flag defGhcFlag "hiedir"            (hasArg setHieDir)-  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)-  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)-  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)-  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)-  , make_ord_flag defGhcFlag "ddump-file-prefix"-        (hasArg (setDumpPrefixForce . Just . flip (++) "."))--  , make_ord_flag defGhcFlag "dynamic-too"-        (NoArg (setGeneralFlag Opt_BuildDynamicToo))--        ------- Keeping temporary files --------------------------------------     -- These can be singular (think ghc -c) or plural (think ghc --make)-  , make_ord_flag defGhcFlag "keep-hc-file"-        (NoArg (setGeneralFlag Opt_KeepHcFiles))-  , make_ord_flag defGhcFlag "keep-hc-files"-        (NoArg (setGeneralFlag Opt_KeepHcFiles))-  , make_ord_flag defGhcFlag "keep-hscpp-file"-        (NoArg (setGeneralFlag Opt_KeepHscppFiles))-  , make_ord_flag defGhcFlag "keep-hscpp-files"-        (NoArg (setGeneralFlag Opt_KeepHscppFiles))-  , make_ord_flag defGhcFlag "keep-s-file"-        (NoArg (setGeneralFlag Opt_KeepSFiles))-  , make_ord_flag defGhcFlag "keep-s-files"-        (NoArg (setGeneralFlag Opt_KeepSFiles))-  , make_ord_flag defGhcFlag "keep-llvm-file"-        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)-  , make_ord_flag defGhcFlag "keep-llvm-files"-        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)-     -- This only makes sense as plural-  , make_ord_flag defGhcFlag "keep-tmp-files"-        (NoArg (setGeneralFlag Opt_KeepTmpFiles))-  , make_ord_flag defGhcFlag "keep-hi-file"-        (NoArg (setGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "no-keep-hi-file"-        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "keep-hi-files"-        (NoArg (setGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "no-keep-hi-files"-        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "keep-o-file"-        (NoArg (setGeneralFlag Opt_KeepOFiles))-  , make_ord_flag defGhcFlag "no-keep-o-file"-        (NoArg (unSetGeneralFlag Opt_KeepOFiles))-  , make_ord_flag defGhcFlag "keep-o-files"-        (NoArg (setGeneralFlag Opt_KeepOFiles))-  , make_ord_flag defGhcFlag "no-keep-o-files"-        (NoArg (unSetGeneralFlag Opt_KeepOFiles))--        ------- Miscellaneous -----------------------------------------------  , make_ord_flag defGhcFlag "no-auto-link-packages"-        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))-  , make_ord_flag defGhcFlag "no-hs-main"-        (NoArg (setGeneralFlag Opt_NoHsMain))-  , make_ord_flag defGhcFlag "fno-state-hack"-        (NoArg (setGeneralFlag Opt_G_NoStateHack))-  , make_ord_flag defGhcFlag "fno-opt-coercion"-        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))-  , make_ord_flag defGhcFlag "with-rtsopts"-        (HasArg setRtsOpts)-  , make_ord_flag defGhcFlag "rtsopts"-        (NoArg (setRtsOptsEnabled RtsOptsAll))-  , make_ord_flag defGhcFlag "rtsopts=all"-        (NoArg (setRtsOptsEnabled RtsOptsAll))-  , make_ord_flag defGhcFlag "rtsopts=some"-        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))-  , make_ord_flag defGhcFlag "rtsopts=none"-        (NoArg (setRtsOptsEnabled RtsOptsNone))-  , make_ord_flag defGhcFlag "rtsopts=ignore"-        (NoArg (setRtsOptsEnabled RtsOptsIgnore))-  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"-        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))-  , make_ord_flag defGhcFlag "no-rtsopts"-        (NoArg (setRtsOptsEnabled RtsOptsNone))-  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"-      (noArg (\d -> d {rtsOptsSuggestions = False}))-  , make_ord_flag defGhcFlag "dhex-word-literals"-        (NoArg (setGeneralFlag Opt_HexWordLiterals))--  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)-  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)-  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))-  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))-  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)-  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)-  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)-  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)-  , make_ord_flag defGhcFlag "ticky-allocd"-        (NoArg (setGeneralFlag Opt_Ticky_Allocd))-  , make_ord_flag defGhcFlag "ticky-LNE"-        (NoArg (setGeneralFlag Opt_Ticky_LNE))-  , make_ord_flag defGhcFlag "ticky-ap-thunk"-        (NoArg (setGeneralFlag Opt_Ticky_AP))-  , make_ord_flag defGhcFlag "ticky-dyn-thunk"-        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))-  , make_ord_flag defGhcFlag "ticky-tag-checks"-        (NoArg (setGeneralFlag Opt_Ticky_Tag))-        ------- recompilation checker ---------------------------------------  , make_dep_flag defGhcFlag "recomp"-        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)-             "Use -fno-force-recomp instead"-  , make_dep_flag defGhcFlag "no-recomp"-        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"-  , make_ord_flag defFlag "fmax-errors"-      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))-  , make_ord_flag defFlag "fno-max-errors"-      (noArg (\d -> d { maxErrors = Nothing }))-  , make_ord_flag defFlag "freverse-errors"-        (noArg (\d -> d {reverseErrors = True} ))-  , make_ord_flag defFlag "fno-reverse-errors"-        (noArg (\d -> d {reverseErrors = False} ))--        ------ HsCpp opts ----------------------------------------------------  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))-  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))--        ------- Include/Import Paths -----------------------------------------  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)-  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)--        ------ Output style options ------------------------------------------  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->-                                                       d { pprUserLength = n }))-  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->-                                                             d { pprCols = n }))-  , make_ord_flag defFlag "fdiagnostics-color=auto"-      (NoArg (upd (\d -> d { useColor = Auto })))-  , make_ord_flag defFlag "fdiagnostics-color=always"-      (NoArg (upd (\d -> d { useColor = Always })))-  , make_ord_flag defFlag "fdiagnostics-color=never"-      (NoArg (upd (\d -> d { useColor = Never })))--  -- Suppress all that is suppressible in core dumps.-  -- Except for uniques, as some simplifier phases introduce new variables that-  -- have otherwise identical names.-  , make_ord_flag defGhcFlag "dsuppress-all"-      (NoArg $ do setGeneralFlag Opt_SuppressCoercions-                  setGeneralFlag Opt_SuppressCoercionTypes-                  setGeneralFlag Opt_SuppressVarKinds-                  setGeneralFlag Opt_SuppressModulePrefixes-                  setGeneralFlag Opt_SuppressTypeApplications-                  setGeneralFlag Opt_SuppressIdInfo-                  setGeneralFlag Opt_SuppressTicks-                  setGeneralFlag Opt_SuppressStgExts-                  setGeneralFlag Opt_SuppressStgReps-                  setGeneralFlag Opt_SuppressTypeSignatures-                  setGeneralFlag Opt_SuppressCoreSizes-                  setGeneralFlag Opt_SuppressTimestamps)--        ------ Debugging -----------------------------------------------------  , make_ord_flag defGhcFlag "dstg-stats"-        (NoArg (setGeneralFlag Opt_StgStats))--  , make_ord_flag defGhcFlag "ddump-cmm"-        (setDumpFlag Opt_D_dump_cmm)-  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"-        (setDumpFlag Opt_D_dump_cmm_from_stg)-  , make_ord_flag defGhcFlag "ddump-cmm-raw"-        (setDumpFlag Opt_D_dump_cmm_raw)-  , make_ord_flag defGhcFlag "ddump-cmm-verbose"-        (setDumpFlag Opt_D_dump_cmm_verbose)-  , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc"-        (setDumpFlag Opt_D_dump_cmm_verbose_by_proc)-  , make_ord_flag defGhcFlag "ddump-cmm-cfg"-        (setDumpFlag Opt_D_dump_cmm_cfg)-  , make_ord_flag defGhcFlag "ddump-cmm-cbe"-        (setDumpFlag Opt_D_dump_cmm_cbe)-  , make_ord_flag defGhcFlag "ddump-cmm-switch"-        (setDumpFlag Opt_D_dump_cmm_switch)-  , make_ord_flag defGhcFlag "ddump-cmm-proc"-        (setDumpFlag Opt_D_dump_cmm_proc)-  , make_ord_flag defGhcFlag "ddump-cmm-sp"-        (setDumpFlag Opt_D_dump_cmm_sp)-  , make_ord_flag defGhcFlag "ddump-cmm-sink"-        (setDumpFlag Opt_D_dump_cmm_sink)-  , make_ord_flag defGhcFlag "ddump-cmm-caf"-        (setDumpFlag Opt_D_dump_cmm_caf)-  , make_ord_flag defGhcFlag "ddump-cmm-procmap"-        (setDumpFlag Opt_D_dump_cmm_procmap)-  , make_ord_flag defGhcFlag "ddump-cmm-split"-        (setDumpFlag Opt_D_dump_cmm_split)-  , make_ord_flag defGhcFlag "ddump-cmm-info"-        (setDumpFlag Opt_D_dump_cmm_info)-  , make_ord_flag defGhcFlag "ddump-cmm-cps"-        (setDumpFlag Opt_D_dump_cmm_cps)-  , make_ord_flag defGhcFlag "ddump-cmm-opt"-        (setDumpFlag Opt_D_dump_opt_cmm)-  , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer"-        (setDumpFlag Opt_D_dump_cmm_thread_sanitizer)-  , make_ord_flag defGhcFlag "ddump-cfg-weights"-        (setDumpFlag Opt_D_dump_cfg_weights)-  , make_ord_flag defGhcFlag "ddump-core-stats"-        (setDumpFlag Opt_D_dump_core_stats)-  , make_ord_flag defGhcFlag "ddump-asm"-        (setDumpFlag Opt_D_dump_asm)-  , make_ord_flag defGhcFlag "ddump-js"-        (setDumpFlag Opt_D_dump_js)-  , make_ord_flag defGhcFlag "ddump-asm-native"-        (setDumpFlag Opt_D_dump_asm_native)-  , make_ord_flag defGhcFlag "ddump-asm-liveness"-        (setDumpFlag Opt_D_dump_asm_liveness)-  , make_ord_flag defGhcFlag "ddump-asm-regalloc"-        (setDumpFlag Opt_D_dump_asm_regalloc)-  , make_ord_flag defGhcFlag "ddump-asm-conflicts"-        (setDumpFlag Opt_D_dump_asm_conflicts)-  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"-        (setDumpFlag Opt_D_dump_asm_regalloc_stages)-  , make_ord_flag defGhcFlag "ddump-asm-stats"-        (setDumpFlag Opt_D_dump_asm_stats)-  , make_ord_flag defGhcFlag "ddump-llvm"-        (NoArg $ setDumpFlag' Opt_D_dump_llvm)-  , make_ord_flag defGhcFlag "ddump-c-backend"-        (NoArg $ setDumpFlag' Opt_D_dump_c_backend)-  , make_ord_flag defGhcFlag "ddump-deriv"-        (setDumpFlag Opt_D_dump_deriv)-  , make_ord_flag defGhcFlag "ddump-ds"-        (setDumpFlag Opt_D_dump_ds)-  , make_ord_flag defGhcFlag "ddump-ds-preopt"-        (setDumpFlag Opt_D_dump_ds_preopt)-  , make_ord_flag defGhcFlag "ddump-foreign"-        (setDumpFlag Opt_D_dump_foreign)-  , make_ord_flag defGhcFlag "ddump-inlinings"-        (setDumpFlag Opt_D_dump_inlinings)-  , make_ord_flag defGhcFlag "ddump-verbose-inlinings"-        (setDumpFlag Opt_D_dump_verbose_inlinings)-  , make_ord_flag defGhcFlag "ddump-rule-firings"-        (setDumpFlag Opt_D_dump_rule_firings)-  , make_ord_flag defGhcFlag "ddump-rule-rewrites"-        (setDumpFlag Opt_D_dump_rule_rewrites)-  , make_ord_flag defGhcFlag "ddump-simpl-trace"-        (setDumpFlag Opt_D_dump_simpl_trace)-  , make_ord_flag defGhcFlag "ddump-occur-anal"-        (setDumpFlag Opt_D_dump_occur_anal)-  , make_ord_flag defGhcFlag "ddump-parsed"-        (setDumpFlag Opt_D_dump_parsed)-  , make_ord_flag defGhcFlag "ddump-parsed-ast"-        (setDumpFlag Opt_D_dump_parsed_ast)-  , make_ord_flag defGhcFlag "dkeep-comments"-        (NoArg (setGeneralFlag Opt_KeepRawTokenStream))-  , make_ord_flag defGhcFlag "ddump-rn"-        (setDumpFlag Opt_D_dump_rn)-  , make_ord_flag defGhcFlag "ddump-rn-ast"-        (setDumpFlag Opt_D_dump_rn_ast)-  , make_ord_flag defGhcFlag "ddump-simpl"-        (setDumpFlag Opt_D_dump_simpl)-  , make_ord_flag defGhcFlag "ddump-simpl-iterations"-      (setDumpFlag Opt_D_dump_simpl_iterations)-  , make_ord_flag defGhcFlag "ddump-spec"-        (setDumpFlag Opt_D_dump_spec)-  , make_ord_flag defGhcFlag "ddump-prep"-        (setDumpFlag Opt_D_dump_prep)-  , make_ord_flag defGhcFlag "ddump-late-cc"-        (setDumpFlag Opt_D_dump_late_cc)-  , make_ord_flag defGhcFlag "ddump-stg-from-core"-        (setDumpFlag Opt_D_dump_stg_from_core)-  , make_ord_flag defGhcFlag "ddump-stg-unarised"-        (setDumpFlag Opt_D_dump_stg_unarised)-  , make_ord_flag defGhcFlag "ddump-stg-final"-        (setDumpFlag Opt_D_dump_stg_final)-  , make_ord_flag defGhcFlag "ddump-stg-cg"-        (setDumpFlag Opt_D_dump_stg_cg)-  , make_dep_flag defGhcFlag "ddump-stg"-        (setDumpFlag Opt_D_dump_stg_from_core)-        "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-call-arity"-        (setDumpFlag Opt_D_dump_call_arity)-  , make_ord_flag defGhcFlag "ddump-exitify"-        (setDumpFlag Opt_D_dump_exitify)-  , make_ord_flag defGhcFlag "ddump-stranal"-        (setDumpFlag Opt_D_dump_stranal)-  , make_ord_flag defGhcFlag "ddump-str-signatures"-        (setDumpFlag Opt_D_dump_str_signatures)-  , make_ord_flag defGhcFlag "ddump-cpranal"-        (setDumpFlag Opt_D_dump_cpranal)-  , make_ord_flag defGhcFlag "ddump-cpr-signatures"-        (setDumpFlag Opt_D_dump_cpr_signatures)-  , make_ord_flag defGhcFlag "ddump-tc"-        (setDumpFlag Opt_D_dump_tc)-  , make_ord_flag defGhcFlag "ddump-tc-ast"-        (setDumpFlag Opt_D_dump_tc_ast)-  , make_ord_flag defGhcFlag "ddump-hie"-        (setDumpFlag Opt_D_dump_hie)-  , make_ord_flag defGhcFlag "ddump-types"-        (setDumpFlag Opt_D_dump_types)-  , make_ord_flag defGhcFlag "ddump-rules"-        (setDumpFlag Opt_D_dump_rules)-  , make_ord_flag defGhcFlag "ddump-cse"-        (setDumpFlag Opt_D_dump_cse)-  , make_ord_flag defGhcFlag "ddump-worker-wrapper"-        (setDumpFlag Opt_D_dump_worker_wrapper)-  , make_ord_flag defGhcFlag "ddump-rn-trace"-        (setDumpFlag Opt_D_dump_rn_trace)-  , make_ord_flag defGhcFlag "ddump-if-trace"-        (setDumpFlag Opt_D_dump_if_trace)-  , make_ord_flag defGhcFlag "ddump-cs-trace"-        (setDumpFlag Opt_D_dump_cs_trace)-  , make_ord_flag defGhcFlag "ddump-tc-trace"-        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace-                   setDumpFlag' Opt_D_dump_cs_trace))-  , make_ord_flag defGhcFlag "ddump-ec-trace"-        (setDumpFlag Opt_D_dump_ec_trace)-  , make_ord_flag defGhcFlag "ddump-splices"-        (setDumpFlag Opt_D_dump_splices)-  , make_ord_flag defGhcFlag "dth-dec-file"-        (setDumpFlag Opt_D_th_dec_file)--  , make_ord_flag defGhcFlag "ddump-rn-stats"-        (setDumpFlag Opt_D_dump_rn_stats)-  , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt-        (setDumpFlag Opt_D_dump_opt_cmm)-  , make_ord_flag defGhcFlag "ddump-simpl-stats"-        (setDumpFlag Opt_D_dump_simpl_stats)-  , make_ord_flag defGhcFlag "ddump-bcos"-        (setDumpFlag Opt_D_dump_BCOs)-  , make_ord_flag defGhcFlag "dsource-stats"-        (setDumpFlag Opt_D_source_stats)-  , make_ord_flag defGhcFlag "dverbose-core2core"-        (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core)-  , make_ord_flag defGhcFlag "dverbose-stg2stg"-        (setDumpFlag Opt_D_verbose_stg2stg)-  , make_ord_flag defGhcFlag "ddump-hi"-        (setDumpFlag Opt_D_dump_hi)-  , make_ord_flag defGhcFlag "ddump-minimal-imports"-        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))-  , make_ord_flag defGhcFlag "ddump-hpc"-        (setDumpFlag Opt_D_dump_ticked) -- back compat-  , make_ord_flag defGhcFlag "ddump-ticked"-        (setDumpFlag Opt_D_dump_ticked)-  , make_ord_flag defGhcFlag "ddump-mod-cycles"-        (setDumpFlag Opt_D_dump_mod_cycles)-  , make_ord_flag defGhcFlag "ddump-mod-map"-        (setDumpFlag Opt_D_dump_mod_map)-  , make_ord_flag defGhcFlag "ddump-timings"-        (setDumpFlag Opt_D_dump_timings)-  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"-        (setDumpFlag Opt_D_dump_view_pattern_commoning)-  , make_ord_flag defGhcFlag "ddump-to-file"-        (NoArg (setGeneralFlag Opt_DumpToFile))-  , make_ord_flag defGhcFlag "ddump-hi-diffs"-        (setDumpFlag Opt_D_dump_hi_diffs)-  , make_ord_flag defGhcFlag "ddump-rtti"-        (setDumpFlag Opt_D_dump_rtti)-  , make_ord_flag defGhcFlag "dlint"-        (NoArg enableDLint)-  , make_ord_flag defGhcFlag "dcore-lint"-        (NoArg (setGeneralFlag Opt_DoCoreLinting))-  , make_ord_flag defGhcFlag "dlinear-core-lint"-        (NoArg (setGeneralFlag Opt_DoLinearCoreLinting))-  , make_ord_flag defGhcFlag "dstg-lint"-        (NoArg (setGeneralFlag Opt_DoStgLinting))-  , make_ord_flag defGhcFlag "dcmm-lint"-        (NoArg (setGeneralFlag Opt_DoCmmLinting))-  , make_ord_flag defGhcFlag "dasm-lint"-        (NoArg (setGeneralFlag Opt_DoAsmLinting))-  , make_ord_flag defGhcFlag "dannot-lint"-        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))-  , make_ord_flag defGhcFlag "dtag-inference-checks"-        (NoArg (setGeneralFlag Opt_DoTagInferenceChecks))-  , make_ord_flag defGhcFlag "dshow-passes"-        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))-  , make_ord_flag defGhcFlag "dipe-stats"-        (setDumpFlag Opt_D_ipe_stats)-  , make_ord_flag defGhcFlag "dfaststring-stats"-        (setDumpFlag Opt_D_faststring_stats)-  , make_ord_flag defGhcFlag "dno-llvm-mangler"-        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag-  , make_ord_flag defGhcFlag "dno-typeable-binds"-        (NoArg (setGeneralFlag Opt_NoTypeableBinds))-  , make_ord_flag defGhcFlag "ddump-debug"-        (setDumpFlag Opt_D_dump_debug)-  , make_ord_flag defGhcFlag "ddump-json"-        (setDumpFlag Opt_D_dump_json )-  , make_ord_flag defGhcFlag "dppr-debug"-        (setDumpFlag Opt_D_ppr_debug)-  , make_ord_flag defGhcFlag "ddebug-output"-        (noArg (flip dopt_unset Opt_D_no_debug_output))-  , make_ord_flag defGhcFlag "dno-debug-output"-        (setDumpFlag Opt_D_no_debug_output)--  , make_ord_flag defGhcFlag "ddump-faststrings"-        (setDumpFlag Opt_D_dump_faststrings)--        ------ Machine dependent (-m<blah>) stuff -----------------------------  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->-                                                  d { sseVersion = Just SSE1 }))-  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->-                                                  d { sseVersion = Just SSE2 }))-  , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->-                                                  d { sseVersion = Just SSE3 }))-  , make_ord_flag defGhcFlag "msse4"        (noArg (\d ->-                                                  d { sseVersion = Just SSE4 }))-  , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->-                                                 d { sseVersion = Just SSE42 }))-  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->-                                                 d { bmiVersion = Just BMI1 }))-  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->-                                                 d { bmiVersion = Just BMI2 }))-  , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))-  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))-  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->-                                                         d { avx512cd = True }))-  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->-                                                         d { avx512er = True }))-  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))-  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->-                                                         d { avx512pf = True }))--     ------ Warning opts --------------------------------------------------  , make_ord_flag defFlag "W"       (NoArg (mapM_ setWarningFlag minusWOpts))-  , make_ord_flag defFlag "Werror"-               (NoArg (do { setGeneralFlag Opt_WarnIsError-                          ; mapM_ setFatalWarningFlag minusWeverythingOpts   }))-  , make_ord_flag defFlag "Wwarn"-               (NoArg (do { unSetGeneralFlag Opt_WarnIsError-                          ; mapM_ unSetFatalWarningFlag minusWeverythingOpts }))-                          -- Opt_WarnIsError is still needed to pass -Werror-                          -- to CPP; see runCpp in SysTools-  , make_dep_flag defFlag "Wnot"    (NoArg (upd (\d ->-                                              d {warningFlags = EnumSet.empty})))-                                             "Use -w or -Wno-everything instead"-  , make_ord_flag defFlag "w"       (NoArg (upd (\d ->-                                              d {warningFlags = EnumSet.empty})))--     -- New-style uniform warning sets-     ---     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything-  , make_ord_flag defFlag "Weverything"    (NoArg (mapM_-                                           setWarningFlag minusWeverythingOpts))-  , make_ord_flag defFlag "Wno-everything"-                           (NoArg (upd (\d -> d {warningFlags = EnumSet.empty})))--  , make_ord_flag defFlag "Wall"           (NoArg (mapM_-                                                  setWarningFlag minusWallOpts))-  , make_ord_flag defFlag "Wno-all"        (NoArg (mapM_-                                                unSetWarningFlag minusWallOpts))--  , make_ord_flag defFlag "Wextra"         (NoArg (mapM_-                                                     setWarningFlag minusWOpts))-  , make_ord_flag defFlag "Wno-extra"      (NoArg (mapM_-                                                   unSetWarningFlag minusWOpts))--  , make_ord_flag defFlag "Wdefault"       (NoArg (mapM_-                                               setWarningFlag standardWarnings))-  , make_ord_flag defFlag "Wno-default"    (NoArg (mapM_-                                             unSetWarningFlag standardWarnings))--  , make_ord_flag defFlag "Wcompat"        (NoArg (mapM_-                                               setWarningFlag minusWcompatOpts))-  , make_ord_flag defFlag "Wno-compat"     (NoArg (mapM_-                                             unSetWarningFlag minusWcompatOpts))--        ------ Plugin flags -------------------------------------------------  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)-  , make_ord_flag defGhcFlag "fplugin-trustworthy"-      (NoArg (setGeneralFlag Opt_PluginTrustworthy))-  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)-  , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames)-  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)--  , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin)--        ------ Optimisation flags -------------------------------------------  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )-                                                            "Use -O0 instead"-  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->-                                                setOptLevel (mb_n `orElse` 1)))-                -- If the number is missing, use 1--  , make_ord_flag defFlag "fbinary-blob-threshold"-      (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of-                                                    0 -> Nothing-                                                    x -> Just x}))-  , make_ord_flag defFlag "fmax-relevant-binds"-      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))-  , make_ord_flag defFlag "fno-max-relevant-binds"-      (noArg (\d -> d { maxRelevantBinds = Nothing }))--  , make_ord_flag defFlag "fmax-valid-hole-fits"-      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))-  , make_ord_flag defFlag "fno-max-valid-hole-fits"-      (noArg (\d -> d { maxValidHoleFits = Nothing }))-  , make_ord_flag defFlag "fmax-refinement-hole-fits"-      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))-  , make_ord_flag defFlag "fno-max-refinement-hole-fits"-      (noArg (\d -> d { maxRefHoleFits = Nothing }))-  , make_ord_flag defFlag "frefinement-level-hole-fits"-      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))-  , make_ord_flag defFlag "fno-refinement-level-hole-fits"-      (noArg (\d -> d { refLevelHoleFits = Nothing }))--  , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"-            (noArg id)-            "vectors registers are now passed in registers by default."-  , make_ord_flag defFlag "fmax-uncovered-patterns"-      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))-  , make_ord_flag defFlag "fmax-pmcheck-models"-      (intSuffix (\n d -> d { maxPmCheckModels = n }))-  , make_ord_flag defFlag "fsimplifier-phases"-      (intSuffix (\n d -> d { simplPhases = n }))-  , make_ord_flag defFlag "fmax-simplifier-iterations"-      (intSuffix (\n d -> d { maxSimplIterations = n }))-  , (Deprecated, defFlag "fmax-pmcheck-iterations"-      (intSuffixM (\_ d ->-       do { deprecate $ "use -fmax-pmcheck-models instead"-          ; return d })))-  , make_ord_flag defFlag "fsimpl-tick-factor"-      (intSuffix (\n d -> d { simplTickFactor = n }))-  , make_ord_flag defFlag "fdmd-unbox-width"-      (intSuffix (\n d -> d { dmdUnboxWidth = n }))-  , make_ord_flag defFlag "fspec-constr-threshold"-      (intSuffix (\n d -> d { specConstrThreshold = Just n }))-  , make_ord_flag defFlag "fno-spec-constr-threshold"-      (noArg (\d -> d { specConstrThreshold = Nothing }))-  , make_ord_flag defFlag "fspec-constr-count"-      (intSuffix (\n d -> d { specConstrCount = Just n }))-  , make_ord_flag defFlag "fno-spec-constr-count"-      (noArg (\d -> d { specConstrCount = Nothing }))-  , make_ord_flag defFlag "fspec-constr-recursive"-      (intSuffix (\n d -> d { specConstrRecursive = n }))-  , make_ord_flag defFlag "fliberate-case-threshold"-      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))-  , make_ord_flag defFlag "fno-liberate-case-threshold"-      (noArg (\d -> d { liberateCaseThreshold = Nothing }))-  , make_ord_flag defFlag "drule-check"-      (sepArg (\s d -> d { ruleCheck = Just s }))-  , make_ord_flag defFlag "dinline-check"-      (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)}))-  , make_ord_flag defFlag "freduction-depth"-      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))-  , make_ord_flag defFlag "fconstraint-solver-iterations"-      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))-  , (Deprecated, defFlag "fcontext-stack"-      (intSuffixM (\n d ->-       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"-          ; return $ d { reductionDepth = treatZeroAsInf n } })))-  , (Deprecated, defFlag "ftype-function-depth"-      (intSuffixM (\n d ->-       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"-          ; return $ d { reductionDepth = treatZeroAsInf n } })))-  , make_ord_flag defFlag "fstrictness-before"-      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))-  , make_ord_flag defFlag "ffloat-lam-args"-      (intSuffix (\n d -> d { floatLamArgs = Just n }))-  , make_ord_flag defFlag "ffloat-all-lams"-      (noArg (\d -> d { floatLamArgs = Nothing }))-  , make_ord_flag defFlag "fstg-lift-lams-rec-args"-      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))-  , make_ord_flag defFlag "fstg-lift-lams-rec-args-any"-      (noArg (\d -> d { liftLamsRecArgs = Nothing }))-  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args"-      (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n }))-  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"-      (noArg (\d -> d { liftLamsNonRecArgs = Nothing }))-  , make_ord_flag defFlag "fstg-lift-lams-known"-      (noArg (\d -> d { liftLamsKnown = True }))-  , make_ord_flag defFlag "fno-stg-lift-lams-known"-      (noArg (\d -> d { liftLamsKnown = False }))-  , make_ord_flag defFlag "fproc-alignment"-      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))-  , make_ord_flag defFlag "fblock-layout-weights"-        (HasArg (\s ->-            upd (\d -> d { cfgWeights =-                parseWeights s (cfgWeights d)})))-  , make_ord_flag defFlag "fhistory-size"-      (intSuffix (\n d -> d { historySize = n }))--  , make_ord_flag defFlag "funfolding-creation-threshold"-      (intSuffix   (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)}))-  , make_ord_flag defFlag "funfolding-use-threshold"-      (intSuffix   (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)}))-  , make_ord_flag defFlag "funfolding-fun-discount"-      (intSuffix   (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)}))-  , make_ord_flag defFlag "funfolding-dict-discount"-      (intSuffix   (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)}))--  , make_ord_flag defFlag "funfolding-case-threshold"-      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))-  , make_ord_flag defFlag "funfolding-case-scaling"-      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))--  , make_dep_flag defFlag "funfolding-keeness-factor"-      (floatSuffix (\_ d -> d))-      "-funfolding-keeness-factor is no longer respected as of GHC 9.0"--  , make_ord_flag defFlag "fmax-worker-args"-      (intSuffix (\n d -> d {maxWorkerArgs = n}))-  , make_ord_flag defGhciFlag "fghci-hist-size"-      (intSuffix (\n d -> d {ghciHistSize = n}))-  , make_ord_flag defGhcFlag "fmax-inline-alloc-size"-      (intSuffix (\n d -> d { maxInlineAllocSize = n }))-  , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"-      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))-  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"-      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))-  , make_ord_flag defGhcFlag "dinitial-unique"-      (word64Suffix (\n d -> d { initialUnique = n }))-  , make_ord_flag defGhcFlag "dunique-increment"-      (intSuffix (\n d -> d { uniqueIncrement = n }))--        ------ Profiling ------------------------------------------------------        -- OLD profiling flags-  , make_dep_flag defGhcFlag "auto-all"-                    (noArg (\d -> d { profAuto = ProfAutoAll } ))-                    "Use -fprof-auto instead"-  , make_dep_flag defGhcFlag "no-auto-all"-                    (noArg (\d -> d { profAuto = NoProfAuto } ))-                    "Use -fno-prof-auto instead"-  , make_dep_flag defGhcFlag "auto"-                    (noArg (\d -> d { profAuto = ProfAutoExports } ))-                    "Use -fprof-auto-exported instead"-  , make_dep_flag defGhcFlag "no-auto"-            (noArg (\d -> d { profAuto = NoProfAuto } ))-                    "Use -fno-prof-auto instead"-  , make_dep_flag defGhcFlag "caf-all"-            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))-                    "Use -fprof-cafs instead"-  , make_dep_flag defGhcFlag "no-caf-all"-            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))-                    "Use -fno-prof-cafs instead"--        -- NEW profiling flags-  , make_ord_flag defGhcFlag "fprof-auto"-      (noArg (\d -> d { profAuto = ProfAutoAll } ))-  , make_ord_flag defGhcFlag "fprof-auto-top"-      (noArg (\d -> d { profAuto = ProfAutoTop } ))-  , make_ord_flag defGhcFlag "fprof-auto-exported"-      (noArg (\d -> d { profAuto = ProfAutoExports } ))-  , make_ord_flag defGhcFlag "fprof-auto-calls"-      (noArg (\d -> d { profAuto = ProfAutoCalls } ))-  , make_ord_flag defGhcFlag "fno-prof-auto"-      (noArg (\d -> d { profAuto = NoProfAuto } ))--        -- Caller-CC-  , make_ord_flag defGhcFlag "fprof-callers"-         (HasArg setCallerCcFilters)-        ------ Compiler flags -------------------------------------------------  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend ncgBackend))-  , make_ord_flag defGhcFlag "fvia-c"           (NoArg-         (deprecate $ "The -fvia-c flag does nothing; " ++-                      "it will be removed in a future GHC release"))-  , make_ord_flag defGhcFlag "fvia-C"           (NoArg-         (deprecate $ "The -fvia-C flag does nothing; " ++-                      "it will be removed in a future GHC release"))-  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjBackend llvmBackend))--  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->-                  d { ghcLink=NoLink }) >> setBackend noBackend))-  , make_ord_flag defFlag "fbyte-code"-      (noArgM $ \dflags -> do-        setBackend interpreterBackend-        pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode))-  , make_ord_flag defFlag "fobject-code"     $ noArgM $ \dflags -> do-      setBackend $ platformDefaultBackend (targetPlatform dflags)-      dflags' <- liftEwM getCmdLineState-      pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode--  , make_dep_flag defFlag "fglasgow-exts"-      (NoArg enableGlasgowExts) "Use individual extensions instead"-  , make_dep_flag defFlag "fno-glasgow-exts"-      (NoArg disableGlasgowExts) "Use individual extensions instead"-  , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds)-  , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds)-  , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds)-  , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg-                                                            disableUnusedBinds)--        ------ Safe Haskell flags --------------------------------------------  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)-  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->-                                                    d { safeInfer = False }))-  , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore))--        ------ position independent flags  -----------------------------------  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))-  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))-  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIE))-  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIE))--         ------ Debugging flags -----------------------------------------------  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)- ]- ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps- ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps- ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps- ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps- ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps- ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps- ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps- ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps- ++ map (mkFlag turnOn  "Werror="   setWErrorFlag )     wWarningFlagsDeps- ++ map (mkFlag turnOn  "Wwarn="     unSetFatalWarningFlag )-                                                        wWarningFlagsDeps- ++ map (mkFlag turnOn  "Wno-error=" unSetFatalWarningFlag )-                                                        wWarningFlagsDeps- ++ map (mkFlag turnOn  "fwarn-"    setWarningFlag   . hideFlag)-    wWarningFlagsDeps- ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag)-    wWarningFlagsDeps- ++ [ (NotDeprecated, unrecognisedWarning "W"),-      (Deprecated,    unrecognisedWarning "fwarn-"),-      (Deprecated,    unrecognisedWarning "fno-warn-") ]- ++ [ make_ord_flag defFlag "Werror=compat"-        (NoArg (mapM_ setWErrorFlag minusWcompatOpts))-    , make_ord_flag defFlag "Wno-error=compat"-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts))-    , make_ord_flag defFlag "Wwarn=compat"-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ]- ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps- ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps- ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps- ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps- ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps- ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps---- | This is where we handle unrecognised warning flags. We only issue a warning--- if -Wunrecognised-warning-flags is set. See #11429 for context.-unrecognisedWarning :: String -> Flag (CmdLineP DynFlags)-unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)-  where-    action :: String -> EwM (CmdLineP DynFlags) ()-    action flag = do-      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState-      when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $-        "unrecognised warning flag: -" ++ prefix ++ flag---- See Note [Supporting CLI completion]-package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]-package_flags_deps = [-        ------- Packages -----------------------------------------------------    make_ord_flag defFlag "package-db"-      (HasArg (addPkgDbRef . PkgDbPath))-  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)-  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)-  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)-  , make_ord_flag defFlag "global-package-db"-      (NoArg (addPkgDbRef GlobalPkgDb))-  , make_ord_flag defFlag "user-package-db"-      (NoArg (addPkgDbRef UserPkgDb))-    -- backwards compat with GHC<=7.4 :-  , make_dep_flag defFlag "package-conf"-      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"-  , make_dep_flag defFlag "no-user-package-conf"-      (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"-  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->-                                      upd (setUnitId name))-  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)--  , make_ord_flag defGhcFlag "working-dir"       (hasArg setWorkingDirectory)-  , make_ord_flag defGhcFlag "this-package-name"  (hasArg setPackageName)-  , make_ord_flag defGhcFlag "hidden-module"      (HasArg addHiddenModule)-  , make_ord_flag defGhcFlag "reexported-module"  (HasArg addReexportedModule)--  , make_ord_flag defFlag "package"               (HasArg exposePackage)-  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)-  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)-  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)-  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)-  , make_ord_flag defFlag "hide-all-packages"-      (NoArg (setGeneralFlag Opt_HideAllPackages))-  , make_ord_flag defFlag "hide-all-plugin-packages"-      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))-  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)-  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)-  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"-  , make_ord_flag defFlag "distrust-all-packages"-      (NoArg (setGeneralFlag Opt_DistrustAllPackages))-  , make_ord_flag defFlag "trust"                 (HasArg trustPackage)-  , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)-  ]-  where-    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }---- | Make a list of flags for shell completion.--- Filter all available flags into two groups, for interactive GHC vs all other.-flagsForCompletion :: Bool -> [String]-flagsForCompletion isInteractive-    = [ '-':flagName flag-      | flag <- flagsAll-      , modeFilter (flagGhcMode flag)-      ]-    where-      modeFilter AllModes = True-      modeFilter OnlyGhci = isInteractive-      modeFilter OnlyGhc = not isInteractive-      modeFilter HiddenFlag = False--type TurnOnFlag = Bool   -- True  <=> we are turning the flag on-                         -- False <=> we are turning the flag off-turnOn  :: TurnOnFlag; turnOn  = True-turnOff :: TurnOnFlag; turnOff = False--data FlagSpec flag-   = FlagSpec-       { flagSpecName :: String   -- ^ Flag in string form-       , flagSpecFlag :: flag     -- ^ Flag in internal form-       , flagSpecAction :: (TurnOnFlag -> DynP ())-           -- ^ Extra action to run when the flag is found-           -- Typically, emit a warning or error-       , flagSpecGhcMode :: GhcFlagMode-           -- ^ In which ghc mode the flag has effect-       }---- | Define a new flag.-flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)-flagSpec name flag = flagSpec' name flag nop---- | Define a new flag with an effect.-flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())-          -> (Deprecation, FlagSpec flag)-flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)---- | Define a warning flag.-warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)]-warnSpec flag = warnSpec' flag nop---- | Define a warning flag with an effect.-warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ())-          -> [(Deprecation, FlagSpec WarningFlag)]-warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes)-                     | name <- NE.toList (warnFlagNames flag)-                     ]---- | Define a new deprecated flag with an effect.-depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String-            -> (Deprecation, FlagSpec flag)-depFlagSpecOp name flag act dep =-    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))---- | Define a new deprecated flag.-depFlagSpec :: String -> flag -> String-            -> (Deprecation, FlagSpec flag)-depFlagSpec name flag dep = depFlagSpecOp name flag nop dep---- | Define a deprecated warning flag.-depWarnSpec :: WarningFlag -> String-            -> [(Deprecation, FlagSpec WarningFlag)]-depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep-                       | name <- NE.toList (warnFlagNames flag)-                       ]---- | Define a deprecated warning name substituted by another.-subWarnSpec :: String -> WarningFlag -> String-            -> [(Deprecation, FlagSpec WarningFlag)]-subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ]----- | Define a new deprecated flag with an effect where the deprecation message--- depends on the flag value-depFlagSpecOp' :: String-             -> flag-             -> (TurnOnFlag -> DynP ())-             -> (TurnOnFlag -> String)-             -> (Deprecation, FlagSpec flag)-depFlagSpecOp' name flag act dep =-    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))-                                                                       AllModes)---- | Define a new deprecated flag where the deprecation message--- depends on the flag value-depFlagSpec' :: String-             -> flag-             -> (TurnOnFlag -> String)-             -> (Deprecation, FlagSpec flag)-depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep----- | Define a new deprecated flag where the deprecation message--- is shown depending on the flag value-depFlagSpecCond :: String-                -> flag-                -> (TurnOnFlag -> Bool)-                -> String-                -> (Deprecation, FlagSpec flag)-depFlagSpecCond name flag cond dep =-    (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep)-                                                                       AllModes)---- | Define a new flag for GHCi.-flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)-flagGhciSpec name flag = flagGhciSpec' name flag nop---- | Define a new flag for GHCi with an effect.-flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())-              -> (Deprecation, FlagSpec flag)-flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)---- | Define a new flag invisible to CLI completion.-flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)-flagHiddenSpec name flag = flagHiddenSpec' name flag nop---- | Define a new flag invisible to CLI completion with an effect.-flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())-                -> (Deprecation, FlagSpec flag)-flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act-                                                                     HiddenFlag)---- | Hide a 'FlagSpec' from being displayed in @--show-options@.------ This is for example useful for flags that are obsolete, but should not--- (yet) be deprecated for compatibility reasons.-hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)-hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })--mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on-       -> String                -- ^ The flag prefix-       -> (flag -> DynP ())     -- ^ What to do when the flag is found-       -> (Deprecation, FlagSpec flag)  -- ^ Specification of-                                        -- this particular flag-       -> (Deprecation, Flag (CmdLineP DynFlags))-mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))-    = (dep,-       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)---- here to avoid module cycle with GHC.Driver.CmdLine-deprecate :: Monad m => String -> EwM m ()-deprecate s = do-    arg <- getArg-    addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s)--deprecatedForExtension :: String -> TurnOnFlag -> String-deprecatedForExtension lang turn_on-    = "use -X" ++ flag ++-      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"-    where-      flag | turn_on   = lang-           | otherwise = "No" ++ lang--deprecatedForExtensions :: [String] -> TurnOnFlag -> String-deprecatedForExtensions [] _ = panic "new extension has not been specified"-deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on-deprecatedForExtensions langExts turn_on-    = "use " ++ xExt flags ++ " instead"-    where-      flags | turn_on = langExts-            | otherwise = ("No" ++) <$> langExts--      xExt fls = intercalate " and "  $ (\flag -> "-X" ++ flag) <$> fls--useInstead :: String -> String -> TurnOnFlag -> String-useInstead prefix flag turn_on-  = "Use " ++ prefix ++ no ++ flag ++ " instead"-  where-    no = if turn_on then "" else "no-"--nop :: TurnOnFlag -> DynP ()-nop _ = return ()---- | Find the 'FlagSpec' for a 'WarningFlag'.-flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)-flagSpecOf = flip Map.lookup wWarningFlagMap--wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag)-wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags---- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@-wWarningFlags :: [FlagSpec WarningFlag]-wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)--wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]-wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x-  Opt_WarnAmbiguousFields -> warnSpec x-  Opt_WarnAutoOrphans-    -> depWarnSpec x "it has no effect"-  Opt_WarnCPPUndef -> warnSpec x-  Opt_WarnUnbangedStrictPatterns -> warnSpec x-  Opt_WarnDeferredTypeErrors -> warnSpec x-  Opt_WarnDeferredOutOfScopeVariables -> warnSpec x-  Opt_WarnWarningsDeprecations -> warnSpec x-  Opt_WarnDeprecatedFlags -> warnSpec x-  Opt_WarnDerivingDefaults -> warnSpec x-  Opt_WarnDerivingTypeable -> warnSpec x-  Opt_WarnDodgyExports -> warnSpec x-  Opt_WarnDodgyForeignImports -> warnSpec x-  Opt_WarnDodgyImports -> warnSpec x-  Opt_WarnEmptyEnumerations -> warnSpec x-  Opt_WarnDuplicateConstraints-    -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"-  Opt_WarnRedundantConstraints -> warnSpec x-  Opt_WarnDuplicateExports -> warnSpec x-  Opt_WarnHiShadows-    -> depWarnSpec x "it is not used and was never implemented"-  Opt_WarnInaccessibleCode -> warnSpec x-  Opt_WarnImplicitPrelude -> warnSpec x-  Opt_WarnImplicitKindVars-    -> depWarnSpec x "it is now an error"-  Opt_WarnIncompletePatterns -> warnSpec x-  Opt_WarnIncompletePatternsRecUpd -> warnSpec x-  Opt_WarnIncompleteUniPatterns -> warnSpec x-  Opt_WarnInlineRuleShadowing -> warnSpec x-  Opt_WarnIdentities -> warnSpec x-  Opt_WarnLoopySuperclassSolve -> warnSpec x-  Opt_WarnMissingFields -> warnSpec x-  Opt_WarnMissingImportList -> warnSpec x-  Opt_WarnMissingExportList -> warnSpec x-  Opt_WarnMissingLocalSignatures-    -> subWarnSpec "missing-local-sigs" x "it is replaced by -Wmissing-local-signatures"-       ++ warnSpec x-  Opt_WarnMissingMethods -> warnSpec x-  Opt_WarnMissingMonadFailInstances-    -> depWarnSpec x "fail is no longer a method of Monad"-  Opt_WarnSemigroup -> warnSpec x-  Opt_WarnMissingSignatures -> warnSpec x-  Opt_WarnMissingKindSignatures -> warnSpec x-  Opt_WarnMissingExportedSignatures-    -> subWarnSpec "missing-exported-sigs" x "it is replaced by -Wmissing-exported-signatures"-       ++ warnSpec x-  Opt_WarnMonomorphism -> warnSpec x-  Opt_WarnNameShadowing -> warnSpec x-  Opt_WarnNonCanonicalMonadInstances -> warnSpec x-  Opt_WarnNonCanonicalMonadFailInstances-    -> depWarnSpec x "fail is no longer a method of Monad"-  Opt_WarnNonCanonicalMonoidInstances -> warnSpec x-  Opt_WarnOrphans -> warnSpec x-  Opt_WarnOverflowedLiterals -> warnSpec x-  Opt_WarnOverlappingPatterns -> warnSpec x-  Opt_WarnMissedSpecs -> warnSpec x-  Opt_WarnAllMissedSpecs -> warnSpec x-  Opt_WarnSafe -> warnSpec' x setWarnSafe-  Opt_WarnTrustworthySafe -> warnSpec x-  Opt_WarnInferredSafeImports -> warnSpec x-  Opt_WarnMissingSafeHaskellMode -> warnSpec x-  Opt_WarnTabs -> warnSpec x-  Opt_WarnTypeDefaults -> warnSpec x-  Opt_WarnTypedHoles -> warnSpec x-  Opt_WarnPartialTypeSignatures -> warnSpec x-  Opt_WarnUnrecognisedPragmas -> warnSpec x-  Opt_WarnMisplacedPragmas -> warnSpec x-  Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe-  Opt_WarnUnsupportedCallingConventions -> warnSpec x-  Opt_WarnUnsupportedLlvmVersion -> warnSpec x-  Opt_WarnMissedExtraSharedLib -> warnSpec x-  Opt_WarnUntickedPromotedConstructors -> warnSpec x-  Opt_WarnUnusedDoBind -> warnSpec x-  Opt_WarnUnusedForalls -> warnSpec x-  Opt_WarnUnusedImports -> warnSpec x-  Opt_WarnUnusedLocalBinds -> warnSpec x-  Opt_WarnUnusedMatches -> warnSpec x-  Opt_WarnUnusedPatternBinds -> warnSpec x-  Opt_WarnUnusedTopBinds -> warnSpec x-  Opt_WarnUnusedTypePatterns -> warnSpec x-  Opt_WarnUnusedRecordWildcards -> warnSpec x-  Opt_WarnRedundantBangPatterns -> warnSpec x-  Opt_WarnRedundantRecordWildcards -> warnSpec x-  Opt_WarnRedundantStrictnessFlags -> warnSpec x-  Opt_WarnWrongDoBind -> warnSpec x-  Opt_WarnMissingPatternSynonymSignatures -> warnSpec x-  Opt_WarnMissingDerivingStrategies -> warnSpec x-  Opt_WarnSimplifiableClassConstraints -> warnSpec x-  Opt_WarnMissingHomeModules -> warnSpec x-  Opt_WarnUnrecognisedWarningFlags -> warnSpec x-  Opt_WarnStarBinder -> warnSpec x-  Opt_WarnStarIsType -> warnSpec x-  Opt_WarnSpaceAfterBang-    -> depWarnSpec x "bang patterns can no longer be written with a space"-  Opt_WarnPartialFields -> warnSpec x-  Opt_WarnPrepositiveQualifiedModule -> warnSpec x-  Opt_WarnUnusedPackages -> warnSpec x-  Opt_WarnCompatUnqualifiedImports -> warnSpec x-  Opt_WarnInvalidHaddock -> warnSpec x-  Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x-  Opt_WarnOperatorWhitespace -> warnSpec x-  Opt_WarnImplicitLift -> warnSpec x-  Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x-  Opt_WarnForallIdentifier -> warnSpec x-  Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x-  Opt_WarnGADTMonoLocalBinds -> warnSpec x-  Opt_WarnTypeEqualityOutOfScope -> warnSpec x-  Opt_WarnTypeEqualityRequiresOperators -> warnSpec x---- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@-negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-negatableFlagsDeps = [-  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]---- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@-dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-dFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,-  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks-     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),-  flagSpec "suppress-ticks"             Opt_SuppressTicks,-  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts-     (useInstead "-d" "suppress-stg-exts"),-  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,-  flagSpec "suppress-stg-reps"          Opt_SuppressStgReps,-  flagSpec "suppress-coercions"         Opt_SuppressCoercions,-  flagSpec "suppress-coercion-types"    Opt_SuppressCoercionTypes,-  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,-  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,-  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,-  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,-  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,-  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,-  flagSpec "suppress-uniques"           Opt_SuppressUniques,-  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds,-  flagSpec "suppress-core-sizes"        Opt_SuppressCoreSizes-  ]---- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@-fFlags :: [FlagSpec GeneralFlag]-fFlags = map snd fFlagsDeps--fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-fFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  depFlagSpec "asm-shortcutting"              Opt_AsmShortcutting-    "this flag is disabled on this ghc version due to unsoundness concerns (https://gitlab.haskell.org/ghc/ghc/-/issues/24507)",-  flagGhciSpec "break-on-error"               Opt_BreakOnError,-  flagGhciSpec "break-on-exception"           Opt_BreakOnException,-  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,-  flagSpec "call-arity"                       Opt_CallArity,-  flagSpec "exitification"                    Opt_Exitification,-  flagSpec "case-merge"                       Opt_CaseMerge,-  flagSpec "case-folding"                     Opt_CaseFolding,-  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,-  flagSpec "cmm-sink"                         Opt_CmmSink,-  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,-  flagSpec "cse"                              Opt_CSE,-  flagSpec "stg-cse"                          Opt_StgCSE,-  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,-  flagSpec "cpr-anal"                         Opt_CprAnal,-  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,-  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,-  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,-  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,-  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,-  -- With-ways needs to be reversible hence why its made via flagSpec unlike-  -- other debugging flags.-  flagSpec "dump-with-ways"                   Opt_DumpWithWays,-  flagSpec "dicts-cheap"                      Opt_DictsCheap,-  flagSpec "dicts-strict"                     Opt_DictsStrict,-  depFlagSpec "dmd-tx-dict-sel"-      Opt_DmdTxDictSel "effect is now unconditionally enabled",-  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,-  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,-  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,-  flagSpec "embed-manifest"                   Opt_EmbedManifest,-  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,-  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,-  flagSpec "error-spans"                      Opt_ErrorSpans,-  flagSpec "excess-precision"                 Opt_ExcessPrecision,-  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,-  flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,-  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,-  flagSpec "external-interpreter"             Opt_ExternalInterpreter,-  flagSpec "family-application-cache"         Opt_FamAppCache,-  flagSpec "float-in"                         Opt_FloatIn,-  flagSpec "force-recomp"                     Opt_ForceRecomp,-  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,-  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,-  flagSpec "full-laziness"                    Opt_FullLaziness,-  depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk-      (useInstead "-f" "full-laziness"),-  flagSpec "local-float-out"                  Opt_LocalFloatOut,-  flagSpec "local-float-out-top-level"        Opt_LocalFloatOutTopLevel,-  flagSpec "gen-manifest"                     Opt_GenManifest,-  flagSpec "ghci-history"                     Opt_GhciHistory,-  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,-  flagSpec "validate-ide-info"                Opt_ValidateHie,-  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,-  flagGhciSpec "no-it"                        Opt_NoIt,-  flagSpec "ghci-sandbox"                     Opt_GhciSandbox,-  flagSpec "helpful-errors"                   Opt_HelpfulErrors,-  flagSpec "hpc"                              Opt_Hpc,-  flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,-  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,-  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,-  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,-  flagSpec "keep-going"                       Opt_KeepGoing,-  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,-  flagSpec "late-specialise"                  Opt_LateSpecialise,-  flagSpec "liberate-case"                    Opt_LiberateCase,-  flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,-  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,-  flagSpec "loopification"                    Opt_Loopification,-  flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,-  flagSpec "block-layout-weightless"          Opt_WeightlessBlocklayout,-  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,-  flagSpec "omit-yields"                      Opt_OmitYields,-  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,-  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,-  flagSpec "pre-inlining"                     Opt_SimplPreInlining,-  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,-  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,-  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,-  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,-  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,-  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,-  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,-  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,-  flagSpec "print-axiom-incomps"              Opt_PrintAxiomIncomps,-  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,-  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,-  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,-  flagSpec "print-redundant-promotion-ticks"  Opt_PrintRedundantPromotionTicks,-  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,-  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,-  flagSpec "prof-count-entries"               Opt_ProfCountEntries,-  flagSpec "prof-late"                        Opt_ProfLateCcs,-  flagSpec "prof-manual"                      Opt_ProfManualCcs,-  flagSpec "prof-late-inline"                 Opt_ProfLateInlineCcs,-  flagSpec "regs-graph"                       Opt_RegsGraph,-  flagSpec "regs-iterative"                   Opt_RegsIterative,-  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules-   (useInstead "-f" "enable-rewrite-rules"),-  flagSpec "shared-implib"                    Opt_SharedImplib,-  flagSpec "spec-constr"                      Opt_SpecConstr,-  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,-  flagSpec "specialise"                       Opt_Specialise,-  flagSpec "specialize"                       Opt_Specialise,-  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,-  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,-  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,-  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,-  flagSpec "polymorphic-specialisation"       Opt_PolymorphicSpecialisation,-  flagSpec "inline-generics"                  Opt_InlineGenerics,-  flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,-  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,-  flagSpec "strictness"                       Opt_Strictness,-  flagSpec "use-rpaths"                       Opt_RPath,-  flagSpec "write-interface"                  Opt_WriteInterface,-  flagSpec "write-if-simplified-core"         Opt_WriteIfSimplifiedCore,-  flagSpec "write-ide-info"                   Opt_WriteHie,-  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,-  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,-  flagSpec "version-macros"                   Opt_VersionMacros,-  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,-  flagSpec "worker-wrapper-cbv"               Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments]-  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,-  flagSpec "catch-nonexhaustive-cases"        Opt_CatchNonexhaustiveCases,-  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,-  flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,-  flagSpec "num-constant-folding"             Opt_NumConstantFolding,-  flagSpec "core-constant-folding"            Opt_CoreConstantFolding,-  flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,-  flagSpec "spec-eval"                        Opt_SpecEval,-  flagSpec "spec-eval-dictfun"                Opt_SpecEvalDictFun,-  flagSpec "cmm-control-flow"                 Opt_CmmControlFlow,-  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,-  flagSpec "hide-source-paths"                Opt_HideSourcePaths,-  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,-  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,-  flagSpec "keep-cafs"                        Opt_KeepCAFs,-  flagSpec "link-rts"                         Opt_LinkRts,-  flagSpec "byte-code-and-object-code"        Opt_ByteCodeAndObjectCode,-  flagSpec "prefer-byte-code"                 Opt_UseBytecodeRatherThanObjects,-  flagSpec' "compact-unwind"                  Opt_CompactUnwind-      (\turn_on -> updM (\dflags -> do-        unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)-               (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")-        return dflags)),-  flagSpec "show-error-context"               Opt_ShowErrorContext,-  flagSpec "cmm-thread-sanitizer"             Opt_CmmThreadSanitizer,-  flagSpec "split-sections"                   Opt_SplitSections,-  flagSpec "distinct-constructor-tables"      Opt_DistinctConstructorTables,-  flagSpec "info-table-map"                   Opt_InfoTableMap,-  flagSpec "info-table-map-with-stack"        Opt_InfoTableMapWithStack,-  flagSpec "info-table-map-with-fallback"     Opt_InfoTableMapWithFallback-  ]-  ++ fHoleFlags---- | These @-f\<blah\>@ flags have to do with the typed-hole error message or--- the valid hole fits in that message. See Note [Valid hole fits include ...]--- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with--- @-fno-\<blah\>@-fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]-fHoleFlags = [-  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,-  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits-   (useInstead "-f" "show-valid-hole-fits"),-  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,-  -- Sorting settings-  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,-  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,-  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,-  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,-  -- Output format settings-  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,-  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,-  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,-  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,-  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,-  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,-  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits-  ]---- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@-fLangFlags :: [FlagSpec LangExt.Extension]-fLangFlags = map snd fLangFlagsDeps--fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]-fLangFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]-  depFlagSpecOp' "th"                           LangExt.TemplateHaskell-    checkTemplateHaskellOk-    (deprecatedForExtension "TemplateHaskell"),-  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface-    (deprecatedForExtension "ForeignFunctionInterface"),-  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface-    (deprecatedForExtension "ForeignFunctionInterface"),-  depFlagSpec' "arrows"                         LangExt.Arrows-    (deprecatedForExtension "Arrows"),-  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude-    (deprecatedForExtension "ImplicitPrelude"),-  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns-    (deprecatedForExtension "BangPatterns"),-  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction-    (deprecatedForExtension "MonomorphismRestriction"),-  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules-    (deprecatedForExtension "ExtendedDefaultRules"),-  depFlagSpec' "implicit-params"                LangExt.ImplicitParams-    (deprecatedForExtension "ImplicitParams"),-  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables-    (deprecatedForExtension "ScopedTypeVariables"),-  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances-    (deprecatedForExtension "OverlappingInstances"),-  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances-    (deprecatedForExtension "UndecidableInstances"),-  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances-    (deprecatedForExtension "IncoherentInstances")-  ]--supportedLanguages :: [String]-supportedLanguages = map (flagSpecName . snd) languageFlagsDeps--supportedLanguageOverlays :: [String]-supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps--supportedExtensions :: ArchOS -> [String]-supportedExtensions (ArchOS _ os) = concatMap toFlagSpecNamePair xFlags-  where-    toFlagSpecNamePair flg-      -- IMPORTANT! Make sure that `ghc --supported-extensions` omits-      -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the-      -- box. See also GHC #11102 and #16331 for more details about-      -- the rationale-      | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]-      | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]-      | otherwise = [name, noName]-      where-        isAIX = os == OSAIX-        noName = "No" ++ name-        name = flagSpecName flg--supportedLanguagesAndExtensions :: ArchOS -> [String]-supportedLanguagesAndExtensions arch_os =-    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os---- | These -X<blah> flags cannot be reversed with -XNo<blah>-languageFlagsDeps :: [(Deprecation, FlagSpec Language)]-languageFlagsDeps = [-  flagSpec "Haskell98"   Haskell98,-  flagSpec "Haskell2010" Haskell2010,-  flagSpec "GHC2021"     GHC2021-  ]---- | These -X<blah> flags cannot be reversed with -XNo<blah>--- They are used to place hard requirements on what GHC Haskell language--- features can be used.-safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]-safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]-    where mkF flag = flagSpec (show flag) flag---- | These -X<blah> flags can all be reversed with -XNo<blah>-xFlags :: [FlagSpec LangExt.Extension]-xFlags = map snd xFlagsDeps--xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]-xFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- See Note [Adding a language extension]--- Please keep the list of flags below sorted alphabetically-  flagSpec "AllowAmbiguousTypes"              LangExt.AllowAmbiguousTypes,-  flagSpec "AlternativeLayoutRule"            LangExt.AlternativeLayoutRule,-  flagSpec "AlternativeLayoutRuleTransitional"-                                              LangExt.AlternativeLayoutRuleTransitional,-  flagSpec "Arrows"                           LangExt.Arrows,-  depFlagSpecCond "AutoDeriveTypeable"        LangExt.AutoDeriveTypeable-    id-         ("Typeable instances are created automatically " ++-                     "for all types since GHC 8.2."),-  flagSpec "BangPatterns"                     LangExt.BangPatterns,-  flagSpec "BinaryLiterals"                   LangExt.BinaryLiterals,-  flagSpec "CApiFFI"                          LangExt.CApiFFI,-  flagSpec "CPP"                              LangExt.Cpp,-  flagSpec "CUSKs"                            LangExt.CUSKs,-  flagSpec "ConstrainedClassMethods"          LangExt.ConstrainedClassMethods,-  flagSpec "ConstraintKinds"                  LangExt.ConstraintKinds,-  flagSpec "DataKinds"                        LangExt.DataKinds,-  depFlagSpecCond "DatatypeContexts"          LangExt.DatatypeContexts-    id-         ("It was widely considered a misfeature, " ++-                     "and has been removed from the Haskell language."),-  flagSpec "DefaultSignatures"                LangExt.DefaultSignatures,-  flagSpec "DeriveAnyClass"                   LangExt.DeriveAnyClass,-  flagSpec "DeriveDataTypeable"               LangExt.DeriveDataTypeable,-  flagSpec "DeriveFoldable"                   LangExt.DeriveFoldable,-  flagSpec "DeriveFunctor"                    LangExt.DeriveFunctor,-  flagSpec "DeriveGeneric"                    LangExt.DeriveGeneric,-  flagSpec "DeriveLift"                       LangExt.DeriveLift,-  flagSpec "DeriveTraversable"                LangExt.DeriveTraversable,-  flagSpec "DerivingStrategies"               LangExt.DerivingStrategies,-  flagSpec' "DerivingVia"                     LangExt.DerivingVia-                                              setDeriveVia,-  flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,-  flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,-  flagSpec "BlockArguments"                   LangExt.BlockArguments,-  depFlagSpec' "DoRec"                        LangExt.RecursiveDo-    (deprecatedForExtension "RecursiveDo"),-  flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,-  flagSpec "FieldSelectors"                   LangExt.FieldSelectors,-  flagSpec "EmptyCase"                        LangExt.EmptyCase,-  flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,-  flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,-  flagSpec "ExistentialQuantification"        LangExt.ExistentialQuantification,-  flagSpec "ExplicitForAll"                   LangExt.ExplicitForAll,-  flagSpec "ExplicitNamespaces"               LangExt.ExplicitNamespaces,-  flagSpec "ExtendedDefaultRules"             LangExt.ExtendedDefaultRules,-  flagSpec "FlexibleContexts"                 LangExt.FlexibleContexts,-  flagSpec "FlexibleInstances"                LangExt.FlexibleInstances,-  flagSpec "ForeignFunctionInterface"         LangExt.ForeignFunctionInterface,-  flagSpec "FunctionalDependencies"           LangExt.FunctionalDependencies,-  flagSpec "GADTSyntax"                       LangExt.GADTSyntax,-  flagSpec "GADTs"                            LangExt.GADTs,-  flagSpec "GHCForeignImportPrim"             LangExt.GHCForeignImportPrim,-  flagSpec' "GeneralizedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving-                                              setGenDeriving,-  flagSpec' "GeneralisedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving-                                              setGenDeriving,-  flagSpec "ImplicitParams"                   LangExt.ImplicitParams,-  flagSpec "ImplicitPrelude"                  LangExt.ImplicitPrelude,-  flagSpec "ImportQualifiedPost"              LangExt.ImportQualifiedPost,-  flagSpec "ImpredicativeTypes"               LangExt.ImpredicativeTypes,-  flagSpec' "IncoherentInstances"             LangExt.IncoherentInstances-                                              setIncoherentInsts,-  flagSpec "TypeFamilyDependencies"           LangExt.TypeFamilyDependencies,-  flagSpec "InstanceSigs"                     LangExt.InstanceSigs,-  flagSpec "ApplicativeDo"                    LangExt.ApplicativeDo,-  flagSpec "InterruptibleFFI"                 LangExt.InterruptibleFFI,-  flagSpec "JavaScriptFFI"                    LangExt.JavaScriptFFI,-  flagSpec "KindSignatures"                   LangExt.KindSignatures,-  flagSpec "LambdaCase"                       LangExt.LambdaCase,-  flagSpec "LexicalNegation"                  LangExt.LexicalNegation,-  flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,-  flagSpec "LinearTypes"                      LangExt.LinearTypes,-  flagSpec "MagicHash"                        LangExt.MagicHash,-  flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,-  flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,-  flagSpec "DeepSubsumption"                  LangExt.DeepSubsumption,-  flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,-  flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,-  flagSpec "MultiWayIf"                       LangExt.MultiWayIf,-  flagSpec "NumericUnderscores"               LangExt.NumericUnderscores,-  flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,-  flagSpec "NamedFieldPuns"                   LangExt.NamedFieldPuns,-  flagSpec "NamedWildCards"                   LangExt.NamedWildCards,-  flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,-  flagSpec "HexFloatLiterals"                 LangExt.HexFloatLiterals,-  flagSpec "NondecreasingIndentation"         LangExt.NondecreasingIndentation,-  depFlagSpec' "NullaryTypeClasses"           LangExt.NullaryTypeClasses-    (deprecatedForExtension "MultiParamTypeClasses"),-  flagSpec "NumDecimals"                      LangExt.NumDecimals,-  depFlagSpecOp "OverlappingInstances"        LangExt.OverlappingInstances-    setOverlappingInsts-    "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",-  flagSpec "OverloadedLabels"                 LangExt.OverloadedLabels,-  flagSpec "OverloadedLists"                  LangExt.OverloadedLists,-  flagSpec "OverloadedStrings"                LangExt.OverloadedStrings,-  flagSpec "PackageImports"                   LangExt.PackageImports,-  flagSpec "ParallelArrays"                   LangExt.ParallelArrays,-  flagSpec "ParallelListComp"                 LangExt.ParallelListComp,-  flagSpec "PartialTypeSignatures"            LangExt.PartialTypeSignatures,-  flagSpec "PatternGuards"                    LangExt.PatternGuards,-  depFlagSpec' "PatternSignatures"            LangExt.ScopedTypeVariables-    (deprecatedForExtension "ScopedTypeVariables"),-  flagSpec "PatternSynonyms"                  LangExt.PatternSynonyms,-  flagSpec "PolyKinds"                        LangExt.PolyKinds,-  flagSpec "PolymorphicComponents"            LangExt.RankNTypes,-  flagSpec "QuantifiedConstraints"            LangExt.QuantifiedConstraints,-  flagSpec "PostfixOperators"                 LangExt.PostfixOperators,-  flagSpec "QuasiQuotes"                      LangExt.QuasiQuotes,-  flagSpec "QualifiedDo"                      LangExt.QualifiedDo,-  flagSpec "Rank2Types"                       LangExt.RankNTypes,-  flagSpec "RankNTypes"                       LangExt.RankNTypes,-  flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,-  flagSpec "OverloadedRecordDot"              LangExt.OverloadedRecordDot,-  flagSpec "OverloadedRecordUpdate"           LangExt.OverloadedRecordUpdate,-  depFlagSpec' "RecordPuns"                   LangExt.NamedFieldPuns-    (deprecatedForExtension "NamedFieldPuns"),-  flagSpec "RecordWildCards"                  LangExt.RecordWildCards,-  flagSpec "RecursiveDo"                      LangExt.RecursiveDo,-  flagSpec "RelaxedLayout"                    LangExt.RelaxedLayout,-  depFlagSpecCond "RelaxedPolyRec"            LangExt.RelaxedPolyRec-    not-         "You can't turn off RelaxedPolyRec any more",-  flagSpec "RoleAnnotations"                  LangExt.RoleAnnotations,-  flagSpec "ScopedTypeVariables"              LangExt.ScopedTypeVariables,-  flagSpec "StandaloneDeriving"               LangExt.StandaloneDeriving,-  flagSpec "StarIsType"                       LangExt.StarIsType,-  flagSpec "StaticPointers"                   LangExt.StaticPointers,-  flagSpec "Strict"                           LangExt.Strict,-  flagSpec "StrictData"                       LangExt.StrictData,-  flagSpec' "TemplateHaskell"                 LangExt.TemplateHaskell-                                              checkTemplateHaskellOk,-  flagSpec "TemplateHaskellQuotes"            LangExt.TemplateHaskellQuotes,-  flagSpec "StandaloneKindSignatures"         LangExt.StandaloneKindSignatures,-  flagSpec "TraditionalRecordSyntax"          LangExt.TraditionalRecordSyntax,-  flagSpec "TransformListComp"                LangExt.TransformListComp,-  flagSpec "TupleSections"                    LangExt.TupleSections,-  flagSpec "TypeApplications"                 LangExt.TypeApplications,-  flagSpec "TypeData"                         LangExt.TypeData,-  depFlagSpec' "TypeInType"                   LangExt.TypeInType-    (deprecatedForExtensions ["DataKinds", "PolyKinds"]),-  flagSpec "TypeFamilies"                     LangExt.TypeFamilies,-  flagSpec "TypeOperators"                    LangExt.TypeOperators,-  flagSpec "TypeSynonymInstances"             LangExt.TypeSynonymInstances,-  flagSpec "UnboxedTuples"                    LangExt.UnboxedTuples,-  flagSpec "UnboxedSums"                      LangExt.UnboxedSums,-  flagSpec "UndecidableInstances"             LangExt.UndecidableInstances,-  flagSpec "UndecidableSuperClasses"          LangExt.UndecidableSuperClasses,-  flagSpec "UnicodeSyntax"                    LangExt.UnicodeSyntax,-  flagSpec "UnliftedDatatypes"                LangExt.UnliftedDatatypes,-  flagSpec "UnliftedFFITypes"                 LangExt.UnliftedFFITypes,-  flagSpec "UnliftedNewtypes"                 LangExt.UnliftedNewtypes,-  flagSpec "ViewPatterns"                     LangExt.ViewPatterns-  ]--defaultFlags :: Settings -> [GeneralFlag]-defaultFlags settings--- See Note [Updating flag description in the User's Guide]-  = [ Opt_AutoLinkPackages,-      Opt_DiagnosticsShowCaret,-      Opt_EmbedManifest,-      Opt_FamAppCache,-      Opt_GenManifest,-      Opt_GhciHistory,-      Opt_GhciSandbox,-      Opt_HelpfulErrors,-      Opt_KeepHiFiles,-      Opt_KeepOFiles,-      Opt_OmitYields,-      Opt_PrintBindContents,-      Opt_ProfCountEntries,-      Opt_SharedImplib,-      Opt_SimplPreInlining,-      Opt_VersionMacros,-      Opt_RPath,-      Opt_DumpWithWays,-      Opt_CompactUnwind,-      Opt_ShowErrorContext,-      Opt_SuppressStgReps-    ]--    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]-             -- The default -O0 options--    -- Default floating flags (see Note [RHS Floating])-    ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ]---    ++ default_PIC platform--    ++ validHoleFitDefaults---    where platform = sTargetPlatform settings---- | These are the default settings for the display and sorting of valid hole---  fits in typed-hole error messages. See Note [Valid hole fits include ...]- -- in the "GHC.Tc.Errors.Hole" module.-validHoleFitDefaults :: [GeneralFlag]-validHoleFitDefaults-  =  [ Opt_ShowTypeAppOfHoleFits-     , Opt_ShowTypeOfHoleFits-     , Opt_ShowProvOfHoleFits-     , Opt_ShowMatchesOfHoleFits-     , Opt_ShowValidHoleFits-     , Opt_SortValidHoleFits-     , Opt_SortBySizeHoleFits-     , Opt_ShowHoleConstraints ]---validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]-validHoleFitsImpliedGFlags-  = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)-    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)-    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)-    , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)-    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]--default_PIC :: Platform -> [GeneralFlag]-default_PIC platform =-  case (platformOS platform, platformArch platform) of-    -- Darwin always requires PIC.  Especially on more recent macOS releases-    -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses-    -- while we could work around this on x86_64 (like WINE does), we won't be-    -- able on aarch64, where this is enforced.-    (OSDarwin,  ArchX86_64)  -> [Opt_PIC]-    -- For AArch64, we need to always have PIC enabled.  The relocation model-    -- on AArch64 does not permit arbitrary relocations.  Under ASLR, we can't-    -- control much how far apart symbols are in memory for our in-memory static-    -- linker;  and thus need to ensure we get sufficiently capable relocations.-    -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top-    -- of that.  Subsequently we expect all code on aarch64/linux (and macOS) to-    -- be built with -fPIC.-    (OSDarwin,  ArchAArch64) -> [Opt_PIC]-    (OSLinux,   ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]-    (OSLinux,   ArchARM {})  -> [Opt_PIC, Opt_ExternalDynamicRefs]-    (OSOpenBSD, ArchX86_64)  -> [Opt_PIC] -- Due to PIE support in-                                         -- OpenBSD since 5.3 release-                                         -- (1 May 2013) we need to-                                         -- always generate PIC. See-                                         -- #10597 for more-                                         -- information.-    _                      -> []---- General flags that are switched on/off when other general flags are switched--- on-impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]-impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)-                ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)-                ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)-                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)-                ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface)-                ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore)-                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack)-                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback)-                ] ++ validHoleFitsImpliedGFlags---- General flags that are switched on/off when other general flags are switched--- off-impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]-impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]--impliedXFlags :: [(LangExt.Extension, TurnOnFlag, 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.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!--    , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)--    , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)-    , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)-    , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)--    , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures-    , (LangExt.PolyKinds,        turnOn, 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)--    -- Standalone kind signatures are a replacement for CUSKs.-    , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)--    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable-    , (LangExt.AutoDeriveTypeable, turnOn, 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.ImpredicativeTypes,  turnOn, 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.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)--    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)-    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)--    -- Duplicate record fields require field disambiguation-    , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)--    , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)-    , (LangExt.Strict, turnOn, 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)--    -- The extensions needed to declare an H98 unlifted data type-    , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)-    , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)-  ]---- Note [When is StarIsType enabled]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The StarIsType extension determines whether to treat '*' as a regular type--- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType--- programs expect '*' to be synonymous with 'Type', so by default StarIsType is--- enabled.------ Programs that use TypeOperators might expect to repurpose '*' for--- multiplication or another binary operation, but making TypeOperators imply--- NoStarIsType caused too much breakage on Hackage.------- Note [Documenting optimisation flags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you change the list of flags enabled for particular optimisation levels--- please remember to update the User's Guide. The relevant file is:------   docs/users_guide/using-optimisation.rst------ Make sure to note whether a flag is implied by -O0, -O or -O2.--optLevelFlags :: [([Int], GeneralFlag)]--- Default settings of flags, before any command-line overrides-optLevelFlags -- see Note [Documenting optimisation flags]-  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)-    , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]-    , ([0,1,2], Opt_LlvmTBAA)-    , ([0,1,2], Opt_ProfManualCcs )-    , ([2], Opt_DictsStrict)--    , ([0],     Opt_IgnoreInterfacePragmas)-    , ([0],     Opt_OmitInterfacePragmas)--    , ([1,2],   Opt_CoreConstantFolding)--    , ([1,2],   Opt_CallArity)-    , ([1,2],   Opt_Exitification)-    , ([1,2],   Opt_CaseMerge)-    , ([1,2],   Opt_CaseFolding)-    , ([1,2],   Opt_CmmElimCommonBlocks)-    -- Disabled due to #24507-    -- , ([2],     Opt_AsmShortcutting)-    , ([1,2],   Opt_CmmSink)-    , ([1,2],   Opt_CmmStaticPred)-    , ([1,2],   Opt_CSE)-    , ([1,2],   Opt_StgCSE)-    , ([2],     Opt_StgLiftLams)-    , ([1,2],   Opt_CmmControlFlow)--    , ([1,2],   Opt_EnableRewriteRules)-          -- Off for -O0.   Otherwise we desugar list literals-          -- to 'build' but don't run the simplifier passes that-          -- would rewrite them back to cons cells!  This seems-          -- silly, and matters for the GHCi debugger.--    , ([1,2],   Opt_FloatIn)-    , ([1,2],   Opt_FullLaziness)-    , ([1,2],   Opt_IgnoreAsserts)-    , ([1,2],   Opt_Loopification)-    , ([1,2],   Opt_CfgBlocklayout)      -- Experimental--    , ([1,2],   Opt_Specialise)-    , ([1,2],   Opt_CrossModuleSpecialise)-    , ([1,2],   Opt_InlineGenerics)-    , ([1,2],   Opt_Strictness)-    , ([1,2],   Opt_UnboxSmallStrictFields)-    , ([1,2],   Opt_CprAnal)-    , ([1,2],   Opt_WorkerWrapper)-    , ([1,2],   Opt_SolveConstantDicts)-    , ([1,2],   Opt_NumConstantFolding)--    , ([2],     Opt_LiberateCase)-    , ([2],     Opt_SpecConstr)-    , ([2],     Opt_FastPAPCalls)---  , ([2],     Opt_RegsGraph)---   RegsGraph suffers performance regression. See #7679---  , ([2],     Opt_StaticArgumentTransformation)---   Static Argument Transformation needs investigation. See #9374-    , ([0,1,2], Opt_SpecEval)-    , ([0,1,2], Opt_SpecEvalDictFun)-    ]---enableUnusedBinds :: DynP ()-enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags--disableUnusedBinds :: DynP ()-disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags---- | Things you get with `-dlint`.-enableDLint :: DynP ()-enableDLint = do-    mapM_ setGeneralFlag dLintFlags-    addWayDynP WayDebug-  where-    dLintFlags :: [GeneralFlag]-    dLintFlags =-        [ Opt_DoCoreLinting-        , Opt_DoStgLinting-        , Opt_DoCmmLinting-        , Opt_DoAsmLinting-        , Opt_CatchNonexhaustiveCases-        , Opt_LlvmFillUndefWithGarbage-        ]--enableGlasgowExts :: DynP ()-enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls-                       mapM_ setExtensionFlag glasgowExtsFlags--disableGlasgowExts :: DynP ()-disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls-                        mapM_ unSetExtensionFlag glasgowExtsFlags---- Please keep what_glasgow_exts_does.rst up to date with this list-glasgowExtsFlags :: [LangExt.Extension]-glasgowExtsFlags = [-             LangExt.ConstrainedClassMethods-           , LangExt.DeriveDataTypeable-           , LangExt.DeriveFoldable-           , LangExt.DeriveFunctor-           , LangExt.DeriveGeneric-           , LangExt.DeriveTraversable-           , LangExt.EmptyDataDecls-           , LangExt.ExistentialQuantification-           , LangExt.ExplicitNamespaces-           , LangExt.FlexibleContexts-           , LangExt.FlexibleInstances-           , LangExt.ForeignFunctionInterface-           , LangExt.FunctionalDependencies-           , LangExt.GeneralizedNewtypeDeriving-           , LangExt.ImplicitParams-           , LangExt.KindSignatures-           , LangExt.LiberalTypeSynonyms-           , LangExt.MagicHash-           , LangExt.MultiParamTypeClasses-           , LangExt.ParallelListComp-           , LangExt.PatternGuards-           , LangExt.PostfixOperators-           , LangExt.RankNTypes-           , LangExt.RecursiveDo-           , LangExt.ScopedTypeVariables-           , LangExt.StandaloneDeriving-           , LangExt.TypeOperators-           , LangExt.TypeSynonymInstances-           , LangExt.UnboxedTuples-           , LangExt.UnicodeSyntax-           , LangExt.UnliftedFFITypes ]--setWarnSafe :: Bool -> DynP ()-setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })-setWarnSafe False = return ()--setWarnUnsafe :: Bool -> DynP ()-setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })-setWarnUnsafe False = return ()--setPackageTrust :: DynP ()-setPackageTrust = do-    setGeneralFlag Opt_PackageTrust-    l <- getCurLoc-    upd $ \d -> d { pkgTrustOnLoc = l }--setGenDeriving :: TurnOnFlag -> DynP ()-setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })-setGenDeriving False = return ()--setDeriveVia :: TurnOnFlag -> DynP ()-setDeriveVia True  = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })-setDeriveVia False = return ()--setOverlappingInsts :: TurnOnFlag -> DynP ()-setOverlappingInsts False = return ()-setOverlappingInsts True = do-  l <- getCurLoc-  upd (\d -> d { overlapInstLoc = l })--setIncoherentInsts :: TurnOnFlag -> DynP ()-setIncoherentInsts False = return ()-setIncoherentInsts True = do-  l <- getCurLoc-  upd (\d -> d { incoherentOnLoc = l })--checkTemplateHaskellOk :: TurnOnFlag -> DynP ()-checkTemplateHaskellOk _turn_on-  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })--{- **********************************************************************-%*                                                                      *-                DynFlags constructors-%*                                                                      *-%********************************************************************* -}--type DynP = EwM (CmdLineP DynFlags)--upd :: (DynFlags -> DynFlags) -> DynP ()-upd f = liftEwM (do dflags <- getCmdLineState-                    putCmdLineState $! f dflags)--updM :: (DynFlags -> DynP DynFlags) -> DynP ()-updM f = do dflags <- liftEwM getCmdLineState-            dflags' <- f dflags-            liftEwM $ putCmdLineState $! dflags'----------------- Constructor functions for OptKind ------------------noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-noArg fn = NoArg (upd fn)--noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)-noArgM fn = NoArg (updM fn)--hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-hasArg fn = HasArg (upd . fn)--sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-sepArg fn = SepArg (upd . fn)--intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-intSuffix fn = IntSuffix (\n -> upd (fn n))--intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)-intSuffixM fn = IntSuffix (\n -> updM (fn n))--word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-word64Suffix fn = Word64Suffix (\n -> upd (fn n))--floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-floatSuffix fn = FloatSuffix (\n -> upd (fn n))--optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)-              -> OptKind (CmdLineP DynFlags)-optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))--setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)-setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)-----------------------------addWayDynP :: Way -> DynP ()-addWayDynP = upd . addWay'--addWay' :: Way -> DynFlags -> DynFlags-addWay' w dflags0 =-   let platform = targetPlatform dflags0-       dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }-       dflags2 = foldr setGeneralFlag' dflags1-                       (wayGeneralFlags platform w)-       dflags3 = foldr unSetGeneralFlag' dflags2-                       (wayUnsetGeneralFlags platform w)-   in dflags3--removeWayDyn :: DynP ()-removeWayDyn = upd (\dfs -> dfs { targetWays_ = removeWay WayDyn (targetWays_ dfs) })-----------------------------setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()-setGeneralFlag   f = upd (setGeneralFlag' f)-unSetGeneralFlag f = upd (unSetGeneralFlag' f)--setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags-setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps-  where-    deps = [ if turn_on then setGeneralFlag'   d-                        else unSetGeneralFlag' d-           | (f', turn_on, d) <- impliedGFlags, f' == f ]-        -- When you set f, set the ones it implies-        -- NB: use setGeneralFlag recursively, in case the implied flags-        --     implies further flags--unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags-unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps-  where-    deps = [ if turn_on then setGeneralFlag' d-                        else unSetGeneralFlag' d-           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]-   -- In general, when you un-set f, we don't un-set the things it implies.-   -- There are however some exceptions, e.g., -fno-strictness implies-   -- -fno-worker-wrapper.-   ---   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags-   --     imply further flags.-----------------------------setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()-setWarningFlag   f = upd (\dfs -> wopt_set dfs f)-unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)--setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()-setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)-unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)--setWErrorFlag :: WarningFlag -> DynP ()-setWErrorFlag flag =-  do { setWarningFlag flag-     ; setFatalWarningFlag flag }-----------------------------setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()-setExtensionFlag f = upd (setExtensionFlag' f)-unSetExtensionFlag f = upd (unSetExtensionFlag' f)--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 ]-        -- When you set f, set the ones it implies-        -- NB: use setExtensionFlag recursively, in case the implied flags-        --     implies further flags--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)------------------------------alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags-alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }-----------------------------setDumpFlag' :: DumpFlag -> DynP ()-setDumpFlag' dump_flag-  = do upd (\dfs -> dopt_set dfs dump_flag)-       when want_recomp forceRecompile-    where -- Certain dumpy-things are really interested in what's going-          -- on during recompilation checking, so in those cases we-          -- don't want to turn it off.-          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,-                                             Opt_D_dump_hi_diffs,-                                             Opt_D_no_debug_output]--forceRecompile :: DynP ()--- Whenever we -ddump, force recompilation (by switching off the--- recompilation checker), else you don't see the dump! However,--- don't switch it off in --make mode, else *everything* gets--- recompiled which probably isn't what you want-forceRecompile = do dfs <- liftEwM getCmdLineState-                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)-        where-          force_recomp dfs = isOneShot (ghcMode dfs)---setVerbosity :: Maybe Int -> DynP ()-setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })--setDebugLevel :: Maybe Int -> DynP ()-setDebugLevel mb_n =-  upd (\dfs -> exposeSyms $ dfs{ debugLevel = n })-  where-    n = mb_n `orElse` 2-    exposeSyms-      | n > 2     = setGeneralFlag' Opt_ExposeInternalSymbols-      | otherwise = id--data PkgDbRef-  = GlobalPkgDb-  | UserPkgDb-  | PkgDbPath FilePath-  deriving Eq--addPkgDbRef :: PkgDbRef -> DynP ()-addPkgDbRef p = upd $ \s ->-  s { packageDBFlags = PackageDB p : packageDBFlags s }--removeUserPkgDb :: DynP ()-removeUserPkgDb = upd $ \s ->-  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }--removeGlobalPkgDb :: DynP ()-removeGlobalPkgDb = upd $ \s ->- s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }--clearPkgDb :: DynP ()-clearPkgDb = upd $ \s ->-  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }--parsePackageFlag :: String                 -- the flag-                 -> ReadP PackageArg       -- type of argument-                 -> String                 -- string to parse-                 -> PackageFlag-parsePackageFlag flag arg_parse str- = case filter ((=="").snd) (readP_to_S parse str) of-    [(r, "")] -> r-    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)-  where doc = flag ++ " " ++ str-        parse = do-            pkg_arg <- tok arg_parse-            let mk_expose = ExposePackage doc pkg_arg-            ( do _ <- tok $ string "with"-                 fmap (mk_expose . ModRenaming True) parseRns-             <++ fmap (mk_expose . ModRenaming False) parseRns-             <++ return (mk_expose (ModRenaming True [])))-        parseRns = do _ <- tok $ R.char '('-                      rns <- tok $ sepBy parseItem (tok $ R.char ',')-                      _ <- tok $ R.char ')'-                      return rns-        parseItem = do-            orig <- tok $ parseModuleName-            (do _ <- tok $ string "as"-                new <- tok $ parseModuleName-                return (orig, new)-              +++-             return (orig, orig))-        tok m = m >>= \x -> skipSpaces >> return x--exposePackage, exposePackageId, hidePackage,-        exposePluginPackage, exposePluginPackageId,-        ignorePackage,-        trustPackage, distrustPackage :: String -> DynP ()-exposePackage p = upd (exposePackage' p)-exposePackageId p =-  upd (\s -> s{ packageFlags =-    parsePackageFlag "-package-id" parseUnitArg p : packageFlags s })-exposePluginPackage p =-  upd (\s -> s{ pluginPackageFlags =-    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })-exposePluginPackageId p =-  upd (\s -> s{ pluginPackageFlags =-    parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s })-hidePackage p =-  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })-ignorePackage p =-  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })--trustPackage p = exposePackage p >> -- both trust and distrust also expose a package-  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })-distrustPackage p = exposePackage p >>-  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })--exposePackage' :: String -> DynFlags -> DynFlags-exposePackage' p dflags-    = dflags { packageFlags =-            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }--parsePackageArg :: ReadP PackageArg-parsePackageArg =-    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))--parseUnitArg :: ReadP PackageArg-parseUnitArg =-    fmap UnitIdArg parseUnit--setUnitId :: String -> DynFlags -> DynFlags-setUnitId p d = d { homeUnitId_ = stringToUnitId p }--setWorkingDirectory :: String -> DynFlags -> DynFlags-setWorkingDirectory p d = d { workingDirectory =  Just p }--{--Note [Filepaths and Multiple Home Units]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is common to assume that a package is compiled in the directory where its-cabal file resides. Thus, all paths used in the compiler are assumed to be relative-to this directory. When there are multiple home units the compiler is often-not operating in the standard directory and instead where the cabal.project-file is located. In this case the `-working-dir` option can be passed which specifies-the path from the current directory to the directory the unit assumes to be it's root,-normally the directory which contains the cabal file.--When the flag is passed, any relative paths used by the compiler are offset-by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and-the location of input files.---}--augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath-augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp-augmentByWorkingDirectory _ fp = fp--setPackageName :: String -> DynFlags -> DynFlags-setPackageName p d = d { thisPackageName =  Just p }--addHiddenModule :: String -> DynP ()-addHiddenModule p =-  upd (\s -> s{ hiddenModules  = Set.insert (mkModuleName p) (hiddenModules s) })--addReexportedModule :: String -> DynP ()-addReexportedModule p =-  upd (\s -> s{ reexportedModules  = Set.insert (mkModuleName p) (reexportedModules s) })----- If we're linking a binary, then only backends that produce object--- code are allowed (requests for other target types are ignored).-setBackend :: Backend -> DynP ()-setBackend l = upd $ \ dfs ->-  if ghcLink dfs /= LinkBinary || backendWritesFiles l-  then dfs{ backend = l }-  else dfs---- Changes the target only if we're compiling object code.  This is--- used by -fasm and -fllvm, which switch from one to the other, but--- not from bytecode to object-code.  The idea is that -fasm/-fllvm--- can be safely used in an OPTIONS_GHC pragma.-setObjBackend :: Backend -> DynP ()-setObjBackend l = updM set-  where-   set dflags-     | backendWritesFiles (backend dflags)-       = return $ dflags { backend = l }-     | otherwise = return dflags--setOptLevel :: Int -> DynFlags -> DynP DynFlags-setOptLevel n dflags = return (updOptLevel n dflags)--setCallerCcFilters :: String -> DynP ()-setCallerCcFilters arg =-  case parseCallerCcFilter arg of-    Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d }-    Left err -> addErr err--setMainIs :: String -> DynP ()-setMainIs arg-  | x:_ <- main_fn, isLower x  -- The arg looked like "Foo.Bar.baz"-  = upd $ \d -> d { mainFunIs = Just main_fn,-                    mainModuleNameIs = mkModuleName main_mod }--  | x:_ <- arg, isUpper x  -- The arg looked like "Foo" or "Foo.Bar"-  = upd $ \d -> d { mainModuleNameIs = mkModuleName arg }--  | otherwise                   -- The arg looked like "baz"-  = upd $ \d -> d { mainFunIs = Just arg }-  where-    (main_mod, main_fn) = splitLongestPrefix arg (== '.')--addLdInputs :: Option -> DynFlags -> DynFlags-addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}---- -------------------------------------------------------------------------------- Load dynflags from environment files.--setFlagsFromEnvFile :: FilePath -> String -> DynP ()-setFlagsFromEnvFile envfile content = do-  setGeneralFlag Opt_HideAllPackages-  parseEnvFile envfile content--parseEnvFile :: FilePath -> String -> DynP ()-parseEnvFile envfile = mapM_ parseEntry . lines-  where-    parseEntry str = case words str of-      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))-        -- relative package dbs are interpreted relative to the env file-        where envdir = takeDirectory envfile-              db     = drop 11 str-      ["clear-package-db"]  -> clearPkgDb-      ["hide-package", pkg]  -> hidePackage pkg-      ["global-package-db"] -> addPkgDbRef GlobalPkgDb-      ["user-package-db"]   -> addPkgDbRef UserPkgDb-      ["package-id", pkgid] -> exposePackageId pkgid-      (('-':'-':_):_)       -> return () -- comments-      -- and the original syntax introduced in 7.10:-      [pkgid]               -> exposePackageId pkgid-      []                    -> return ()-      _                     -> throwGhcException $ CmdLineError $-                                    "Can't parse environment file entry: "-                                 ++ envfile ++ ": " ++ str----------------------------------------------------------------------------------- Paths & Libraries--addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()---- -i on its own deletes the import paths-addImportPath "" = upd (\s -> s{importPaths = []})-addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})--addLibraryPath p =-  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})--addIncludePath p =-  upd (\s -> s{includePaths =-                  addGlobalInclude (includePaths s) (splitPathList p)})--addFrameworkPath p =-  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})--#if !defined(mingw32_HOST_OS)-split_marker :: Char-split_marker = ':'   -- not configurable (ToDo)-#endif--splitPathList :: String -> [String]-splitPathList s = filter notNull (splitUp s)-                -- empty paths are ignored: there might be a trailing-                -- ':' in the initial list, for example.  Empty paths can-                -- cause confusion when they are translated into -I options-                -- for passing to gcc.-  where-#if !defined(mingw32_HOST_OS)-    splitUp xs = split split_marker xs-#else-     -- Windows: 'hybrid' support for DOS-style paths in directory lists.-     ---     -- That is, if "foo:bar:baz" is used, this interpreted as-     -- consisting of three entries, 'foo', 'bar', 'baz'.-     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted-     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"-     ---     -- Notice that no attempt is made to fully replace the 'standard'-     -- split marker ':' with the Windows / DOS one, ';'. The reason being-     -- that this will cause too much breakage for users & ':' will-     -- work fine even with DOS paths, if you're not insisting on being silly.-     -- So, use either.-    splitUp []             = []-    splitUp (x:':':div:xs) | div `elem` dir_markers-                           = ((x:':':div:p): splitUp rs)-                           where-                              (p,rs) = findNextPath xs-          -- we used to check for existence of the path here, but that-          -- required the IO monad to be threaded through the command-line-          -- parser which is quite inconvenient.  The-    splitUp xs = cons p (splitUp rs)-               where-                 (p,rs) = findNextPath xs--                 cons "" xs = xs-                 cons x  xs = x:xs--    -- will be called either when we've consumed nought or the-    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of-    -- finding the next split marker.-    findNextPath xs =-        case break (`elem` split_markers) xs of-           (p, _:ds) -> (p, ds)-           (p, xs)   -> (p, xs)--    split_markers :: [Char]-    split_markers = [':', ';']--    dir_markers :: [Char]-    dir_markers = ['/', '\\']-#endif---- -------------------------------------------------------------------------------- tmpDir, where we store temporary files.--setTmpDir :: FilePath -> DynFlags -> DynFlags-setTmpDir dir d = d { tmpDir = TempDir (normalise dir) }-  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't-  -- seem necessary now --SDM 7/2/2008---------------------------------------------------------------------------------- RTS opts--setRtsOpts :: String -> DynP ()-setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}--setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()-setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}---------------------------------------------------------------------------------- Hpc stuff--setOptHpcDir :: String -> DynP ()-setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}---------------------------------------------------------------------------------- Via-C compilation stuff---- There are some options that we need to pass to gcc when compiling--- Haskell code via C, but are only supported by recent versions of--- gcc.  The configure script decides which of these options we need,--- and puts them in the "settings" file in $topdir. The advantage of--- having these in a separate file is that the file can be created at--- install-time depending on the available gcc version, and even--- re-generated later if gcc is upgraded.------ The options below are not dependent on the version of gcc, only the--- platform.--picCCOpts :: DynFlags -> [String]-picCCOpts dflags =-      case platformOS (targetPlatform dflags) of-      OSDarwin-          -- Apple prefers to do things the other way round.-          -- PIC is on by default.-          -- -mdynamic-no-pic:-          --     Turn off PIC code generation.-          -- -fno-common:-          --     Don't generate "common" symbols - these are unwanted-          --     in dynamic libraries.--       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]-       | otherwise           -> ["-mdynamic-no-pic"]-      OSMinGW32 -- no -fPIC for Windows-       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]-       | otherwise           -> []-      _-      -- we need -fPIC for C files when we are compiling with -dynamic,-      -- otherwise things like stub.c files don't get compiled-      -- correctly.  They need to reference data in the Haskell-      -- objects, but can't without -fPIC.  See-      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code-       | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn ->-          ["-fPIC", "-U__PIC__", "-D__PIC__"]-      -- gcc may be configured to have PIC on by default, let's be-      -- explicit here, see #15847-       | otherwise -> ["-fno-PIC"]--pieCCLDOpts :: DynFlags -> [String]-pieCCLDOpts dflags-      | gopt Opt_PICExecutable dflags       = ["-pie"]-        -- See Note [No PIE when linking]-      | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]-      | otherwise                           = []---{--Note [No PIE when linking]-~~~~~~~~~~~~~~~~~~~~~~~~~~-As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by-default in their gcc builds. This is incompatible with -r as it implies that we-are producing an executable. Consequently, we must manually pass -no-pie to gcc-when joining object files or linking dynamic libraries. Unless, of course, the-user has explicitly requested a PIE executable with -pie. See #12759.--}--picPOpts :: DynFlags -> [String]-picPOpts dflags- | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]- | otherwise           = []---- -------------------------------------------------------------------------------- Compiler Info--compilerInfo :: DynFlags -> [(String, String)]-compilerInfo dflags-    = -- We always make "Project name" be first to keep parsing in-      -- other languages simple, i.e. when looking for other fields,-      -- you don't have to worry whether there is a leading '[' or not-      ("Project name",                 cProjectName)-      -- Next come the settings, so anything else can be overridden-      -- in the settings file (as "lookup" uses the first match for the-      -- key)-    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))-          (rawSettings dflags)-   ++ [("Project version",             projectVersion dflags),-       ("Project Git commit id",       cProjectGitCommitId),-       ("Project Version Int",         cProjectVersionInt),-       ("Project Patch Level",         cProjectPatchLevel),-       ("Project Patch Level1",        cProjectPatchLevel1),-       ("Project Patch Level2",        cProjectPatchLevel2),-       ("Booter version",              cBooterVersion),-       ("Stage",                       cStage),-       ("Build platform",              cBuildPlatformString),-       ("Host platform",               cHostPlatformString),-       ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),-       ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),-       ("Object splitting supported",  showBool False),-       ("Have native code generator",  showBool $ platformNcgSupported (targetPlatform dflags)),-       ("Target default backend",      show $ platformDefaultBackend (targetPlatform dflags)),-       -- Whether or not we support @-dynamic-too@-       ("Support dynamic-too",         showBool $ not isWindows),-       -- Whether or not we support the @-j@ flag with @--make@.-       ("Support parallel --make",     "YES"),-       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in-       -- installed package info.-       ("Support reexported-modules",  "YES"),-       -- Whether or not we support extended @-package foo (Foo)@ syntax.-       ("Support thinning and renaming package flags", "YES"),-       -- Whether or not we support Backpack.-       ("Support Backpack", "YES"),-       -- If true, we require that the 'id' field in installed package info-       -- match what is passed to the @-this-unit-id@ flag for modules-       -- built in it-       ("Requires unified installed package IDs", "YES"),-       -- Whether or not we support the @-this-package-key@ flag.  Prefer-       -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@-       -- flag has been removed, otherwise it breaks Cabal...-       ("Uses package keys",           "YES"),-       -- Whether or not we support the @-this-unit-id@ flag-       ("Uses unit IDs",               "YES"),-       -- Whether or not GHC was compiled using -dynamic-       ("GHC Dynamic",                 showBool hostIsDynamic),-       -- Whether or not GHC was compiled using -prof-       ("GHC Profiled",                showBool hostIsProfiled),-       ("Debug on",                    showBool debugIsOn),-       ("LibDir",                      topDir dflags),-       -- The path of the global package database used by GHC-       ("Global Package DB",           globalPackageDatabasePath dflags)-      ]-  where-    showBool True  = "YES"-    showBool False = "NO"-    platform  = targetPlatform dflags-    isWindows = platformOS platform == OSMinGW32-    useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags-    expandDirectories :: FilePath -> Maybe FilePath -> String -> String-    expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd----- | Get target profile-targetProfile :: DynFlags -> Profile-targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)--{- ------------------------------------------------------------------------------Note [DynFlags consistency]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are a number of number of DynFlags configurations which either-do not make sense or lead to unimplemented or buggy codepaths in the-compiler. makeDynFlagsConsistent is responsible for verifying the validity-of a set of DynFlags, fixing any issues, and reporting them back to the-caller.--GHCi and -O------------------When using optimization, the compiler can introduce several things-(such as unboxed tuples) into the intermediate code, which GHCi later-chokes on since the bytecode interpreter can't handle this (and while-this is arguably a bug these aren't handled, there are no plans to fix-it.)--While the driver pipeline always checks for this particular erroneous-combination when parsing flags, we also need to check when we update-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).--}---- | 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, [Located String])--- 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!-makeDynFlagsConsistent dflags- -- Disable -dynamic-too on Windows (#8228, #7134, #5987)- | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags-    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo-          warn    = "-dynamic-too is not supported on Windows"-      in loop dflags' warn- -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise- -- you get two dynamic object files (.o and .dyn_o). (#20436)- | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags-    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo-          warn = "-dynamic-too is ignored when using -dynamic"-      in loop dflags' warn-- | gopt Opt_SplitSections dflags- , platformHasSubsectionsViaSymbols (targetPlatform dflags)-    = let dflags' = gopt_unset dflags Opt_SplitSections-          warn = "-fsplit-sections is not useful on this platform " ++-                 "since it uses subsections-via-symbols. Ignoring."-      in loop dflags' warn--   -- Via-C backend only supports unregisterised ABI. Switch to a backend-   -- supporting it if possible.- | backendUnregisterisedAbiOnly (backend dflags) &&-   not (platformUnregisterised (targetPlatform dflags))-    = let b = platformDefaultBackend (targetPlatform dflags)-      in if backendSwappableWithViaC b then-           let dflags' = dflags { backend = b }-               warn = "Target platform doesn't use unregisterised ABI, so using " ++-                      backendDescription b ++ " rather than " ++-                      backendDescription (backend dflags)-           in loop dflags' warn-         else-           pgmError (backendDescription (backend dflags) ++-                     " supports only unregisterised ABI but target platform doesn't use it.")-- | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags))-    = let dflags' = gopt_unset dflags Opt_Hpc-          warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++-                 ". Ignoring -fhpc."-      in loop dflags' warn-- | backendSwappableWithViaC (backend dflags) &&-   platformUnregisterised (targetPlatform dflags)-    = loop (dflags { backend = viaCBackend })-           "Target platform uses unregisterised ABI, so compiling via C"-- | backendNeedsPlatformNcgSupport (backend dflags) &&-   not (platformNcgSupported $ targetPlatform dflags)-      = let dflags' = dflags { backend = llvmBackend }-            warn = "Native code generator doesn't support target platform, so using LLVM"-        in loop dflags' warn-- | not (osElfTarget os) && gopt Opt_PIE dflags-    = loop (gopt_unset dflags Opt_PIE)-           "Position-independent only supported on ELF platforms"- | os == OSDarwin &&-   arch == ArchX86_64 &&-   not (gopt Opt_PIC dflags)-    = loop (gopt_set dflags Opt_PIC)-           "Enabling -fPIC as it is always on for this platform"-- | backendForcesOptimization0 (backend dflags)- , let (dflags', changed) = updOptLevelChanged 0 dflags- , changed-    = loop dflags' ("Optimization flags are incompatible with the " ++-                   backendDescription (backend dflags) ++-                                          "; optimization flags ignored.")-- | LinkInMemory <- ghcLink dflags- , not (gopt Opt_ExternalInterpreter dflags)- , hostIsProfiled- , backendWritesFiles (backend dflags)- , ways dflags `hasNotWay` WayProf-    = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}-         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"-- | LinkMergedObj <- ghcLink dflags- , Nothing <- outputFile dflags- = pgmError "--output must be specified when using --merge-objs"-- | otherwise = (dflags, [])-    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")-          loop updated_dflags warning-              = case makeDynFlagsConsistent updated_dflags of-                (dflags', ws) -> (dflags', L loc warning : ws)-          platform = targetPlatform dflags-          arch = platformArch platform-          os   = platformOS   platform---setUnsafeGlobalDynFlags :: DynFlags -> IO ()-setUnsafeGlobalDynFlags dflags = do-   writeIORef v_unsafeHasPprDebug (hasPprDebug dflags)-   writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags)-   writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags)----- -------------------------------------------------------------------------------- SSE and AVX--isSse4_2Enabled :: DynFlags -> Bool-isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42--isAvxEnabled :: DynFlags -> Bool-isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags--isAvx2Enabled :: DynFlags -> Bool-isAvx2Enabled dflags = avx2 dflags || avx512f dflags--isAvx512cdEnabled :: DynFlags -> Bool-isAvx512cdEnabled dflags = avx512cd dflags--isAvx512erEnabled :: DynFlags -> Bool-isAvx512erEnabled dflags = avx512er dflags--isAvx512fEnabled :: DynFlags -> Bool-isAvx512fEnabled dflags = avx512f dflags--isAvx512pfEnabled :: DynFlags -> Bool-isAvx512pfEnabled dflags = avx512pf dflags---- -------------------------------------------------------------------------------- BMI2--isBmiEnabled :: DynFlags -> Bool-isBmiEnabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> bmiVersion dflags >= Just BMI1-    ArchX86    -> bmiVersion dflags >= Just BMI1-    _          -> False--isBmi2Enabled :: DynFlags -> Bool-isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> bmiVersion dflags >= Just BMI2-    ArchX86    -> bmiVersion dflags >= Just BMI2-    _          -> False---- | Indicate if cost-centre profiling is enabled-sccProfilingEnabled :: DynFlags -> Bool-sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)---- | Indicate whether we need to generate source notes-needSourceNotes :: DynFlags -> Bool-needSourceNotes dflags = debugLevel dflags > 0-                       || gopt Opt_InfoTableMap dflags---- -------------------------------------------------------------------------------- Linker/compiler information---- LinkerInfo contains any extra options needed by the system linker.-data LinkerInfo-  = GnuLD    [Option]-  | GnuGold  [Option]-  | LlvmLLD  [Option]-  | DarwinLD [Option]-  | SolarisLD [Option]-  | AixLD    [Option]-  | UnknownLD-  deriving Eq---- CompilerInfo tells us which C compiler we're using-data CompilerInfo-   = GCC-   | Clang-   | AppleClang-   | AppleClang51-   | Emscripten-   | UnknownCC-   deriving Eq----- | Should we use `-XLinker -rpath` when linking or not?--- See Note [-fno-use-rpaths]-useXLinkerRPath :: DynFlags -> OS -> Bool-useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS]-useXLinkerRPath dflags _ = gopt Opt_RPath dflags--{--Note [-fno-use-rpaths]-~~~~~~~~~~~~~~~~~~~~~~--First read, Note [Dynamic linking on macOS] to understand why on darwin we never-use `-XLinker -rpath`.--The specification of `Opt_RPath` is as follows:--The default case `-fuse-rpaths`:-* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath-  afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin-  as things stand but it wasn't documented in the user guide before this patch how-  `-fuse-rpaths` should behave and the fact it was always disabled on darwin.-* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable,-  this is the normal way you should set the rpath.--The case of `-fno-use-rpaths`-* Never inject anything into the rpath.--When this was first implemented, `Opt_RPath` was disabled on darwin, but-the rpath was still always augmented by `runInjectRPaths`, and there was no way to-stop this. This was problematic because you couldn't build an executable in CI-with a clean rpath.---}---- -------------------------------------------------------------------------------- RTS hooks---- Convert sizes like "3.5M" into integers-decodeSize :: String -> Integer-decodeSize str-  | c == ""      = truncate n-  | c == "K" || c == "k" = truncate (n * 1000)-  | c == "M" || c == "m" = truncate (n * 1000 * 1000)-  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)-  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))-  where (m, c) = span pred str-        n      = readRational m-        pred c = isDigit c || c == '.'--foreign import ccall unsafe "ghc_lib_parser_setHeapSize"       setHeapSize       :: Int -> IO ()-foreign import ccall unsafe "ghc_lib_parser_enableTimingStats" enableTimingStats :: IO ()----- | Initialize the pretty-printing options-initSDocContext :: DynFlags -> PprStyle -> SDocContext-initSDocContext dflags style = SDC-  { sdocStyle                       = style-  , sdocColScheme                   = colScheme dflags-  , sdocLastColour                  = Col.colReset-  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)-  , sdocDefaultDepth                = pprUserLength dflags-  , sdocLineLength                  = pprCols dflags-  , sdocCanUseUnicode               = useUnicode dflags-  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags-  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags-  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags-  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags-  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags-  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags-  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags-  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags-  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags-  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags-  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags-  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags-  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags-  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags-  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags-  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags-  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags-  , sdocSuppressCoercionTypes       = gopt Opt_SuppressCoercionTypes dflags-  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags-  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags-  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags-  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags-  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags-  , sdocSuppressStgReps             = gopt Opt_SuppressStgReps dflags-  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags-  , sdocStarIsType                  = xopt LangExt.StarIsType dflags-  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags-  , sdocListTuplePuns               = True-  , sdocPrintTypeAbbreviations      = True-  , sdocUnitIdForUser               = ftext-  }---- | Initialize the pretty-printing options using the default user style-initDefaultSDocContext :: DynFlags -> SDocContext-initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle--initPromotionTickContext :: DynFlags -> PromotionTickContext-initPromotionTickContext dflags =-  PromTickCtx {-    ptcListTuplePuns = True,-    ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags-  }--outputFile :: DynFlags -> Maybe String-outputFile dflags-   | dynamicNow dflags = dynOutputFile_ dflags-   | otherwise         = outputFile_    dflags--objectSuf :: DynFlags -> String-objectSuf dflags-   | dynamicNow dflags = dynObjectSuf_ dflags-   | otherwise         = objectSuf_    dflags--ways :: DynFlags -> Ways-ways dflags-   | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)-   | otherwise         = targetWays_ dflags+module GHC.Driver.Session (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), DiagnosticReason(..),+        Language(..),+        FatalMessager, FlushOut(..),+        ProfAuto(..),+        glasgowExtsFlags,+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        wopt_set_all_custom, wopt_unset_all_custom,+        wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,+        wopt_set_custom, wopt_unset_custom,+        wopt_set_fatal_custom, wopt_unset_fatal_custom,+        wopt_any_custom,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow,+        sccProfilingEnabled,+        needSourceNotes,+        OnOff(..),+        DynFlags(..),+        ParMakeCount(..),+        outputFile, objectSuf, ways,+        FlagSpec(..),+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        fFlags, fLangFlags, xFlags,+        wWarningFlags,+        makeDynFlagsConsistent,+        positionIndependent,+        optimisationFlags,+        codeGenFlags,+        setFlagsFromEnvFile,+        pprDynFlagsDiff,+        flagSpecOf,++        targetProfile,++        -- ** Safe Haskell+        safeHaskellOn, safeHaskellModeEnabled,+        safeImportsOn, safeLanguageOn, safeInferOn,+        packageTrustOn,+        safeDirectImpsReq, safeImplicitImpsReq,+        unsafeFlags, unsafeFlagsForInfer,++        -- ** base+        baseUnitId,++        -- ** System tool settings and locations+        Settings(..),+        sProgramName,+        sProjectVersion,+        sGhcUsagePath,+        sGhciUsagePath,+        sToolDir,+        sTopDir,+        sGlobalPackageDatabasePath,+        sLdSupportsCompactUnwind,+        sLdSupportsFilelist,+        sLdIsGnuLd,+        sGccSupportsNoPie,+        sPgm_L,+        sPgm_P,+        sPgm_F,+        sPgm_c,+        sPgm_cxx,+        sPgm_cpp,+        sPgm_a,+        sPgm_l,+        sPgm_lm,+        sPgm_windres,+        sPgm_ar,+        sPgm_ranlib,+        sPgm_lo,+        sPgm_lc,+        sPgm_las,+        sPgm_i,+        sOpt_L,+        sOpt_P,+        sOpt_P_fingerprint,+        sOpt_JSP,+        sOpt_JSP_fingerprint,+        sOpt_CmmP,+        sOpt_CmmP_fingerprint,+        sOpt_F,+        sOpt_c,+        sOpt_cxx,+        sOpt_a,+        sOpt_l,+        sOpt_lm,+        sOpt_windres,+        sOpt_lo,+        sOpt_lc,+        sOpt_i,+        sExtraGccViaCFlags,+        sTargetPlatformString,+        sGhcWithInterpreter,+        sLibFFI,+        sTargetRTSLinkerOnlySupportsSharedLibs,+        GhcNameVersion(..),+        FileSettings(..),+        PlatformMisc(..),+        settings,+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,+        pgm_L, pgm_P, pgm_JSP, pgm_CmmP, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l,+        pgm_lm, pgm_windres, pgm_ar,+        pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i,+        opt_L, opt_P, opt_JSP, opt_CmmP, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,+        opt_P_signature, opt_JSP_signature, opt_CmmP_signature,+        opt_windres, opt_lo, opt_lc, opt_las,+        updatePlatformConstants,++        -- ** Manipulating DynFlags+        addPluginModuleName,+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,+        augmentByWorkingDirectory,++        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]+        getVerbFlags,+        updOptLevel,+        setTmpDir,+        setUnitId,+        setHomeUnitId,++        TurnOnFlag,+        turnOn,+        turnOff,+        impliedGFlags,+        impliedOffGFlags,+        impliedXFlags,++        -- ** State+        CmdLineP(..), runCmdLineP,+        getCmdLineState, putCmdLineState,+        processCmdLineP,++        -- ** Parsing DynFlags+        parseDynamicFlagsCmdLine,+        parseDynamicFilePragma,+        parseDynamicFlagsFull,+        flagSuggestions,++        -- ** Available DynFlags+        allNonDeprecatedFlags,+        flagsAll,+        flagsDynamic,+        flagsPackage,+        flagsForCompletion,++        supportedLanguagesAndExtensions,+        languageExtensions,++        -- ** DynFlags C compiler options+        picCCOpts, picPOpts,++        -- ** DynFlags C linker options+        pieCCLDOpts,++        -- * Compiler configuration suitable for display to the user+        compilerInfo,++        wordAlignment,++        setUnsafeGlobalDynFlags,++        -- * SSE and AVX+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,+        isSse4_2Enabled,+        isBmiEnabled,+        isBmi2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,++        -- * Linker/compiler information+        useXLinkerRPath,++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+        initPromotionTickContext,+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile+import GHC.Platform.ArchOS++import GHC.Unit.Types+import GHC.Unit.Parser+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Driver.DynFlags+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Flags+import GHC.Driver.Backend+import GHC.Driver.Errors.Types+import GHC.Driver.Plugins.External+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)+import GHC.Utils.GlobalVars+import GHC.Data.Maybe+import GHC.Data.Bool+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Types.Error+import GHC.Types.Name.Reader (RdrName(..))+import GHC.Types.Name.Occurrence (isVarOcc, occNameString)+import GHC.Utils.Monad+import GHC.Types.SrcLoc+import GHC.Types.SafeHaskell+import GHC.Types.Basic ( treatZeroAsInf )+import GHC.Data.FastString+import GHC.Utils.TmpFs+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable+import GHC.Utils.Error (emptyDiagOpts, logInfo)+import GHC.Settings+import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Opt.CallerCC+import GHC.Parser (parseIdentifier)+import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))++import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )++import Data.IORef+import Control.Arrow ((&&&))+import Control.Monad+import Control.Monad.Trans.State as State+import Data.Functor.Identity++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+import Data.Word+import System.FilePath+import Text.ParserCombinators.ReadP hiding (char)+import Text.ParserCombinators.ReadP as R++import qualified GHC.Data.EnumSet as EnumSet++import qualified GHC.LanguageExtensions as LangExt+++-- Note [Updating flag description in the User's Guide]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you modify anything in this file please make sure that your changes are+-- described in the User's Guide. Please update the flag description in the+-- users guide (docs/users_guide) whenever you add or change a flag.+-- Please make sure you add ":since:" information to new flags.++-- Note [Supporting CLI completion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The command line interface completion (in for example bash) is an easy way+-- for the developer to learn what flags are available from GHC.+-- GHC helps by separating which flags are available when compiling with GHC,+-- and which flags are available when using GHCi.+-- A flag is assumed to either work in both these modes, or only in one of them.+-- When adding or changing a flag, please consider for which mode the flag will+-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,+-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.++-- Note [Adding a language extension]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are a few steps to adding (or removing) a language extension,+--+--  * Adding the extension to GHC.LanguageExtensions+--+--    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs+--    is the canonical list of language extensions known by GHC.+--+--  * Adding a flag to DynFlags.xFlags+--+--    This is fairly self-explanatory. The name should be concise, memorable,+--    and consistent with any previous implementations of the similar idea in+--    other Haskell compilers.+--+--  * Adding the flag to the documentation+--+--    This is the same as any other flag. See+--    Note [Updating flag description in the User's Guide]+--+--  * Adding the flag to Cabal+--+--    The Cabal library has its own list of all language extensions supported+--    by all major compilers. This is the list that user code being uploaded+--    to Hackage is checked against to ensure language extension validity.+--    Consequently, it is very important that this list remains up-to-date.+--+--    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)+--    whose job it is to ensure these GHC's extensions are consistent with+--    Cabal.+--+--    The recommended workflow is,+--+--     1. Temporarily add your new language extension to the+--        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't+--        break while Cabal is updated.+--+--     2. After your GHC change is accepted, submit a Cabal pull request adding+--        your new extension to Cabal's list (found in+--        Cabal/Language/Haskell/Extension.hs).+--+--     3. After your Cabal change is accepted, let the GHC developers know so+--        they can update the Cabal submodule and remove the extensions from+--        expectedGhcOnlyExtensions.+--+--  * Adding the flag to the GHC Wiki+--+--    There is a change log tracking language extension additions and removals+--    on the GHC wiki:  https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history+--+--  See #4437 and #8176.++-- -----------------------------------------------------------------------------+-- DynFlags++{- Note [RHS Floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to+  'doFloatFromRhs'; with this we can control floating out with GHC flags.++  This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and+  allows for experimentation.+-}++-----------------------------------------------------------------------------+-- Accessors from 'DynFlags'++-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the+-- vast majority of code. But GHCi questionably uses this to produce a default+-- 'DynFlags' from which to compute a flags diff for printing.+settings :: DynFlags -> Settings+settings dflags = Settings+  { sGhcNameVersion = ghcNameVersion dflags+  , sFileSettings = fileSettings dflags+  , sUnitSettings = unitSettings dflags+  , sTargetPlatform = targetPlatform dflags+  , sToolSettings = toolSettings dflags+  , sPlatformMisc = platformMisc dflags+  , sRawSettings = rawSettings dflags+  }++pgm_L                 :: DynFlags -> String+pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags+pgm_P                 :: DynFlags -> (String,[Option])+pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags+pgm_JSP               :: DynFlags -> (String,[Option])+pgm_JSP dflags = toolSettings_pgm_JSP $ toolSettings dflags+pgm_CmmP              :: DynFlags -> (String,[Option])+pgm_CmmP dflags = toolSettings_pgm_CmmP $ toolSettings dflags+pgm_F                 :: DynFlags -> String+pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags+pgm_c                 :: DynFlags -> String+pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags+pgm_cxx               :: DynFlags -> String+pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags+pgm_cpp               :: DynFlags -> (String,[Option])+pgm_cpp dflags = toolSettings_pgm_cpp $ toolSettings dflags+pgm_a                 :: DynFlags -> (String,[Option])+pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags+pgm_l                 :: DynFlags -> (String,[Option])+pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags+pgm_lm                 :: DynFlags -> Maybe (String,[Option])+pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags+pgm_windres           :: DynFlags -> String+pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags+pgm_ar                :: DynFlags -> String+pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags+pgm_ranlib            :: DynFlags -> String+pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags+pgm_lo                :: DynFlags -> (String,[Option])+pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags+pgm_lc                :: DynFlags -> (String,[Option])+pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags+pgm_las               :: DynFlags -> (String,[Option])+pgm_las dflags = toolSettings_pgm_las $ toolSettings dflags+pgm_i                 :: DynFlags -> String+pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags+opt_L                 :: DynFlags -> [String]+opt_L dflags = toolSettings_opt_L $ toolSettings dflags+opt_P                 :: DynFlags -> [String]+opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_P (toolSettings dflags)+opt_JSP               :: DynFlags -> [String]+opt_JSP dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_JSP (toolSettings dflags)+opt_CmmP              :: DynFlags -> [String]+opt_CmmP dflags = toolSettings_opt_CmmP $ toolSettings dflags++-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_P_signature       :: DynFlags -> ([String], Fingerprint)+opt_P_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_P_fingerprint $ toolSettings dflags+  )+-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_JSP_signature     :: DynFlags -> ([String], Fingerprint)+opt_JSP_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_JSP_fingerprint $ toolSettings dflags+  )+-- This function packages everything that's needed to fingerprint opt_CmmP+-- flags. See Note [Repeated -optP hashing].+opt_CmmP_signature     :: DynFlags -> Fingerprint+opt_CmmP_signature = toolSettings_opt_CmmP_fingerprint . toolSettings++opt_F                 :: DynFlags -> [String]+opt_F dflags= toolSettings_opt_F $ toolSettings dflags+opt_c                 :: DynFlags -> [String]+opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_c (toolSettings dflags)+opt_cxx               :: DynFlags -> [String]+opt_cxx dflags = concatMap (wayOptcxx (targetPlatform dflags)) (ways dflags)+           ++ toolSettings_opt_cxx (toolSettings dflags)+opt_a                 :: DynFlags -> [String]+opt_a dflags= toolSettings_opt_a $ toolSettings dflags+opt_l                 :: DynFlags -> [String]+opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_l (toolSettings dflags)+opt_lm                :: DynFlags -> [String]+opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags+opt_windres           :: DynFlags -> [String]+opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags+opt_lo                :: DynFlags -> [String]+opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags+opt_lc                :: DynFlags -> [String]+opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags+opt_las               :: DynFlags -> [String]+opt_las dflags = toolSettings_opt_las $ toolSettings dflags+opt_i                 :: DynFlags -> [String]+opt_i dflags= toolSettings_opt_i $ toolSettings dflags+++setBaseUnitId :: String -> DynP ()+setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }++-----------------------------------------------------------------------------++{-+Note [Verbosity levels]+~~~~~~~~~~~~~~~~~~~~~~~+    0   |   print errors & warnings only+    1   |   minimal verbosity: print "compiling M ... done." for each module.+    2   |   equivalent to -dshow-passes+    3   |   equivalent to existing "ghc -v"+    4   |   "ghc -v -ddump-most"+    5   |   "ghc -v -ddump-all"+-}++-- | Set the Haskell language standard to use+setLanguage :: Language -> DynP ()+setLanguage l = upd (`lang_set` Just l)++-- | Is the -fpackage-trust mode on+packageTrustOn :: DynFlags -> Bool+packageTrustOn = gopt Opt_PackageTrust++-- | Is Safe Haskell on in some way (including inference mode)+safeHaskellOn :: DynFlags -> Bool+safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags++safeHaskellModeEnabled :: DynFlags -> Bool+safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy+                                                   , Sf_Safe ]+++-- | Is the Safe Haskell safe language in use+safeLanguageOn :: DynFlags -> Bool+safeLanguageOn dflags = safeHaskell dflags == Sf_Safe++-- | Is the Safe Haskell safe inference mode active+safeInferOn :: DynFlags -> Bool+safeInferOn = safeInfer++-- | Test if Safe Imports are on in some form+safeImportsOn :: DynFlags -> Bool+safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||+                       safeHaskell dflags == Sf_Trustworthy ||+                       safeHaskell dflags == Sf_Safe++-- | Set a 'Safe Haskell' flag+setSafeHaskell :: SafeHaskellMode -> DynP ()+setSafeHaskell s = updM f+    where f dfs = do+              let sf = safeHaskell dfs+              safeM <- combineSafeFlags sf s+              case s of+                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }+                -- leave safe inference on in Trustworthy mode so we can warn+                -- if it could have been inferred safe.+                Sf_Trustworthy -> do+                  l <- getCurLoc+                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }+                -- leave safe inference on in Unsafe mode as well.+                _ -> return $ dfs { safeHaskell = safeM }++-- | Are all direct imports required to be safe for this Safe Haskell mode?+-- Direct imports are when the code explicitly imports a module+safeDirectImpsReq :: DynFlags -> Bool+safeDirectImpsReq d = safeLanguageOn d++-- | Are all implicit imports required to be safe for this Safe Haskell mode?+-- Implicit imports are things in the prelude. e.g System.IO when print is used.+safeImplicitImpsReq :: DynFlags -> Bool+safeImplicitImpsReq d = safeLanguageOn d++-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.+-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't+-- want to export this functionality from the module but do want to export the+-- type constructors.+combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode+combineSafeFlags a b | a == Sf_None         = return b+                     | b == Sf_None         = return a+                     | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore+                     | a == b               = return a+                     | otherwise            = addErr errm >> pure a+    where errm = "Incompatible Safe Haskell flags! ("+                    ++ show a ++ ", " ++ show b ++ ")"++-- | A list of unsafe flags under Safe Haskell. Tuple elements are:+--     * name of the flag+--     * function to get srcspan that enabled the flag+--     * function to test if the flag is on+--     * function to turn the flag off+unsafeFlags, unsafeFlagsForInfer+  :: [(LangExt.Extension, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]+unsafeFlags = [ (LangExt.GeneralizedNewtypeDeriving, newDerivOnLoc,+                    xopt LangExt.GeneralizedNewtypeDeriving,+                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)+              , (LangExt.DerivingVia, deriveViaOnLoc,+                    xopt LangExt.DerivingVia,+                    flip xopt_unset LangExt.DerivingVia)+              , (LangExt.TemplateHaskell, thOnLoc,+                    xopt LangExt.TemplateHaskell,+                    flip xopt_unset LangExt.TemplateHaskell)+              ]+unsafeFlagsForInfer = unsafeFlags+++-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order+getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from+        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors+        -> [a]                  -- ^ Correctly ordered extracted options+getOpts dflags opts = reverse (opts dflags)+        -- We add to the options from the front, so we need to reverse the list++-- | Gets the verbosity flag for the current verbosity level. This is fed to+-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included+getVerbFlags :: DynFlags -> [String]+getVerbFlags dflags+  | verbosity dflags >= 4 = ["-v"]+  | otherwise             = []++setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,+         setDynObjectSuf, setDynHiSuf,+         setDylibInstallName,+         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,+         setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP,+         addOptJSP, addOptCmmP,+         addCmdlineFramework, addHaddockOpts, addGhciScript,+         setInteractivePrint+   :: String -> DynFlags -> DynFlags+setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce+   :: Maybe String -> DynFlags -> DynFlags++setObjectDir  f d = d { objectDir  = Just f}+setHiDir      f d = d { hiDir      = Just f}+setHieDir     f d = d { hieDir     = Just f}+setStubDir    f d = d { stubDir    = Just f+                      , includePaths = addGlobalInclude (includePaths d) [f] }+  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file+  -- \#included from the .hc file when compiling via C (i.e. unregisterised+  -- builds).+setDumpDir    f d = d { dumpDir    = Just f}+setOutputDir  f = setObjectDir f+                . setHieDir f+                . setHiDir f+                . setStubDir f+                . setDumpDir f+setDylibInstallName  f d = d { dylibInstallName = Just f}++setObjectSuf    f d = d { objectSuf_    = f}+setDynObjectSuf f d = d { dynObjectSuf_ = f}+setHiSuf        f d = d { hiSuf_        = f}+setHieSuf       f d = d { hieSuf        = f}+setDynHiSuf     f d = d { dynHiSuf_     = f}+setHcSuf        f d = d { hcSuf         = f}++setOutputFile    f d = d { outputFile_    = f}+setDynOutputFile f d = d { dynOutputFile_ = f}+setOutputHi      f d = d { outputHi       = f}+setDynOutputHi   f d = d { dynOutputHi    = f}++parseUnitInsts :: String -> Instantiations+parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)+  where parse = sepBy parseEntry (R.char ',')+        parseEntry = do+            n <- parseModuleName+            _ <- R.char '='+            m <- parseHoleyModule+            return (n, m)++setUnitInstantiations :: String -> DynFlags -> DynFlags+setUnitInstantiations s d =+    d { homeUnitInstantiations_ = parseUnitInsts s }++setUnitInstanceOf :: String -> DynFlags -> DynFlags+setUnitInstanceOf s d =+    d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) }++addPluginModuleName :: String -> DynFlags -> DynFlags+addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }++clearPluginModuleNames :: DynFlags -> DynFlags+clearPluginModuleNames d =+    d { pluginModNames = []+      , pluginModNameOpts = []+      }++addPluginModuleNameOption :: String -> DynFlags -> DynFlags+addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }+  where (m, rest) = break (== ':') optflag+        option = case rest of+          [] -> "" -- should probably signal an error+          (_:plug_opt) -> plug_opt -- ignore the ':' from break++addExternalPlugin :: String -> DynFlags -> DynFlags+addExternalPlugin optflag d = case parseExternalPluginSpec optflag of+  Just r  -> d { externalPluginSpecs = r : externalPluginSpecs d }+  Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag++addFrontendPluginOption :: String -> DynFlags -> DynFlags+addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }++parseDynLibLoaderMode f d =+ case splitAt 8 f of+   ("deploy", "")       -> d { dynLibLoader = Deployable }+   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }+   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))++setDumpPrefixForce f d = d { dumpPrefixForce = f}++-- 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 = 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 = 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 = 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})+addOptP   f = alterToolSettings $ \s -> s+          { toolSettings_opt_P   = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+          -- See Note [Repeated -optP hashing]+addOptJSP f = alterToolSettings $ \s -> s+          { toolSettings_opt_JSP   = f : toolSettings_opt_JSP s+          , toolSettings_opt_JSP_fingerprint = fingerprintStrings (f : toolSettings_opt_JSP s)+          }+          -- See Note [Repeated -optP hashing]+addOptCmmP f = alterToolSettings $ \s -> s+          { toolSettings_opt_CmmP = f : toolSettings_opt_CmmP s+          , toolSettings_opt_CmmP_fingerprint = fingerprintStrings (f : toolSettings_opt_CmmP s)+          }++setDepMakefile :: FilePath -> DynFlags -> DynFlags+setDepMakefile f d = d { depMakefile = f }++setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags+setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }++setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags+setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }++addDepExcludeMod :: String -> DynFlags -> DynFlags+addDepExcludeMod m d+    = d { depExcludeMods = mkModuleName m : depExcludeMods d }++addDepSuffix :: FilePath -> DynFlags -> DynFlags+addDepSuffix s d = d { depSuffixes = s : depSuffixes d }++addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}++addGhcVersionFile :: FilePath -> DynFlags -> DynFlags+addGhcVersionFile f d = d { ghcVersionFile = Just f }++addHaddockOpts f d = d { haddockOptions = Just f}++addGhciScript f d = d { ghciScripts = f : ghciScripts d}++setInteractivePrint f d = d { interactivePrint = Just f}++-----------------------------------------------------------------------------+-- Setting the optimisation level++updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool)+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place+updOptLevelChanged n dfs+  = (dfs3, changed1 || changed2 || changed3)+  where+   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2+   (dfs1, changed1) = foldr unset (dfs , False) remove_gopts+   (dfs2, changed2) = foldr set   (dfs1, False) extra_gopts+   (dfs3, changed3) = setLlvmOptLevel dfs2++   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]+   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]++   set f (dfs, changed)+     | gopt f dfs = (dfs, changed)+     | otherwise = (gopt_set dfs f, True)++   unset f (dfs, changed)+     | not (gopt f dfs) = (dfs, changed)+     | otherwise = (gopt_unset dfs f, True)++   setLlvmOptLevel dfs+     | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True)+     | otherwise = (dfs, False)++updOptLevel :: Int -> DynFlags -> DynFlags+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level+updOptLevel n = fst . updOptLevelChanged n++{- **********************************************************************+%*                                                                      *+                DynFlags parser+%*                                                                      *+%********************************************************************* -}++-- -----------------------------------------------------------------------------+-- Parsing the dynamic flags.+++-- | Parse dynamic flags from a list of command line arguments.  Returns+-- 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 => Logger -> DynFlags -> [Located String]+                         -> m (DynFlags, [Located String], Messages DriverMessage)+                            -- ^ Updated 'DynFlags', left-over arguments, and+                            -- list of warnings.+parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True+++-- | 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 => Logger -> DynFlags -> [Located String]+                       -> m (DynFlags, [Located String], Messages DriverMessage)+                          -- ^ Updated 'DynFlags', left-over arguments, and+                          -- list of warnings.+parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False++newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)+  deriving (Functor)++instance Monad (CmdLineP s) where+    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)+    return = pure++instance Applicative (CmdLineP s) where+    pure x = CmdLineP (pure x)+    (<*>) = ap++getCmdLineState :: CmdLineP s s+getCmdLineState = CmdLineP State.get++putCmdLineState :: s -> CmdLineP s ()+putCmdLineState x = CmdLineP (State.put x)++runCmdLineP :: CmdLineP s a -> s -> (a, s)+runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0++-- | A helper to parse a set of flags from a list of command-line arguments, handling+-- response files.+processCmdLineP+    :: forall s m. MonadIO m+    => [Flag (CmdLineP s)]  -- ^ valid flags to match against+    -> s                    -- ^ current state+    -> [Located String]     -- ^ arguments to parse+    -> m (([Located String], [Err], [Warn]), s)+                            -- ^ (leftovers, errors, warnings)+processCmdLineP activeFlags s0 args =+    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0+  where+    getCmdLineP :: CmdLineP s a -> StateT s m a+    getCmdLineP (CmdLineP k) = k++-- | Parses the dynamically set flags for GHC. This is the most general form of+-- the dynamic flag parser that the other methods simply wrap. It allows+-- saying which flags are valid flags and indicating if we are parsing+-- arguments from the command line or from a file pragma.+parseDynamicFlagsFull+    :: 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 logger dflags0 args = do+  ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args++  -- See Note [Handling errors when parsing command-line flags]+  let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)+  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $+    map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs++  -- check for disabled flags in safe haskell+  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1+      theWays = ways dflags2++  unless (allowed_combination theWays) $ liftIO $+      throwGhcExceptionIO (CmdLineError ("combination not supported: " +++                               intercalate "/" (map wayDesc (Set.toAscList theWays))))++  let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2++  -- Set timer stats & heap size+  when (enableTimeStats dflags3) $ liftIO enableTimingStats+  case (ghcHeapSize dflags3) of+    Just x -> liftIO (setHeapSize x)+    _      -> return ()++  liftIO $ setUnsafeGlobalDynFlags dflags3++  -- create message envelopes using final DynFlags: #23402+  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+-- in safe mode.+--+-- The bool is to indicate if we are parsing command line flags (false means+-- file pragma). This allows us to generate better warnings.+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Warn])+safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)+  where+    -- Handle illegal flags under safe language.+    (dflagsUnset, warns) = foldl' check_method (dflags, mempty) unsafeFlags++    check_method (df, warns) (ext,loc,test,fix)+        | test df   = (fix df, safeFailure (loc df) ext :  warns)+        | otherwise = (df, warns)++    safeFailure loc ext+       = L loc $ DriverSafeHaskellIgnoredExtension ext++safeFlagCheck cmdl dflags =+  case safeInferOn dflags of+    True   -> (dflags' { safeInferred = safeFlags }, warn)+    False  -> (dflags', warn)++  where+    -- dynflags and warn for when -fpackage-trust by itself with no safe+    -- haskell flag+    (dflags', warn)+      | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags+      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)+      | otherwise = (dflags, mempty)++    pkgWarnMsg :: [Warn]+    pkgWarnMsg = [ L (pkgTrustOnLoc dflags') DriverPackageTrustIgnored ]++    -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main+    -- Force this to avoid retaining reference to old DynFlags value+    !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer++-- | Produce a list of suggestions for a user provided flag that is invalid.+flagSuggestions+  :: [String] -- valid flags to match against+  -> String+  -> [String]+flagSuggestions flags userInput+  -- fixes #11789+  -- If the flag contains '=',+  -- this uses both the whole and the left side of '=' for comparing.+  | elem '=' userInput =+        let (flagsWithEq, flagsWithoutEq) = partition (elem '=') flags+            fName = takeWhile (/= '=') userInput+        in (fuzzyMatch userInput flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+  | otherwise = fuzzyMatch userInput flags++{- **********************************************************************+%*                                                                      *+                DynFlags specifications+%*                                                                      *+%********************************************************************* -}++-- | All dynamic flags option strings without the deprecated ones.+-- These are the user facing strings for enabling and disabling options.+allNonDeprecatedFlags :: [String]+allNonDeprecatedFlags = allFlagsDeps False++-- | All flags with possibility to filter deprecated ones+allFlagsDeps :: Bool -> [String]+allFlagsDeps keepDeprecated = [ '-':flagName flag+                              | (deprecated, flag) <- flagsAllDeps+                              , keepDeprecated || not (isDeprecated deprecated)]+  where isDeprecated Deprecated = True+        isDeprecated _ = False++{-+ - Below we export user facing symbols for GHC dynamic flags for use with the+ - GHC API.+ -}++-- All dynamic flags present in GHC.+flagsAll :: [Flag (CmdLineP DynFlags)]+flagsAll = map snd flagsAllDeps++-- All dynamic flags present in GHC with deprecation information.+flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]+flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps+++-- All dynamic flags, minus package flags, present in GHC.+flagsDynamic :: [Flag (CmdLineP DynFlags)]+flagsDynamic = map snd dynamic_flags_deps++-- ALl package flags present in GHC.+flagsPackage :: [Flag (CmdLineP DynFlags)]+flagsPackage = map snd package_flags_deps++----------------Helpers to make flags and keep deprecation information----------++type FlagMaker m = String -> OptKind m -> Flag m+type DynFlagMaker = FlagMaker (CmdLineP DynFlags)++-- Make a non-deprecated flag+make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)+              -> (Deprecation, Flag (CmdLineP DynFlags))+make_ord_flag fm name kind = (NotDeprecated, fm name kind)++-- Make a deprecated flag+make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String+                 -> (Deprecation, Flag (CmdLineP DynFlags))+make_dep_flag fm name kind message = (Deprecated,+                                      fm name $ add_dep_message kind message)++add_dep_message :: OptKind (CmdLineP DynFlags) -> String+                -> OptKind (CmdLineP DynFlags)+add_dep_message (NoArg f) message = NoArg $ f >> deprecate message+add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message+add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message+add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message+add_dep_message (OptPrefix f) message =+                                  OptPrefix $ \s -> f s >> deprecate message+add_dep_message (OptIntSuffix f) message =+                               OptIntSuffix $ \oi -> f oi >> deprecate message+add_dep_message (IntSuffix f) message =+                                  IntSuffix $ \i -> f i >> deprecate message+add_dep_message (Word64Suffix f) message =+                                  Word64Suffix $ \i -> f i >> deprecate message+add_dep_message (FloatSuffix f) message =+                                FloatSuffix $ \fl -> f fl >> deprecate message+add_dep_message (PassFlag f) message =+                                   PassFlag $ \s -> f s >> deprecate message+add_dep_message (AnySuffix f) message =+                                  AnySuffix $ \s -> f s >> deprecate message++----------------------- The main flags themselves ------------------------------+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+dynamic_flags_deps = [+    make_dep_flag defFlag "n" (NoArg $ return ())+        "The -n flag is deprecated and no longer has any effect"+  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))+  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))+  , (Deprecated, defFlag "#include"+      (HasArg (\_s ->+         deprecate ("-#include and INCLUDE pragmas are " +++                    "deprecated: They no longer have any effect"))))+  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)++  , make_ord_flag defGhcFlag "j"     (OptIntSuffix+        (\n -> case n of+                 Just n+                     | n > 0     -> upd (\d -> d { parMakeCount = Just (ParMakeThisMany n) })+                     | otherwise -> addErr "Syntax: -j[n] where n > 0"+                 Nothing -> upd (\d -> d { parMakeCount = Just ParMakeNumProcessors })))+                 -- When the number of parallel builds+                 -- is omitted, it is the same+                 -- as specifying that the number of+                 -- parallel builds is equal to the+                 -- result of getNumProcessors+  , make_ord_flag defGhcFlag "jsem" $ hasArg $ \f d -> d { parMakeCount = Just (ParMakeSemaphore f) }++  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)+  , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)++    -- RTS options -------------------------------------------------------------+  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->+          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))++  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->+                                               d { enableTimeStats = True })))++    ------- ways ---------------------------------------------------------------+  , make_ord_flag defGhcFlag "prof"           (NoArg (addWayDynP WayProf))+  , (Deprecated, defFlag     "eventlog"+     $ noArgM $ \d -> do+         deprecate "the eventlog is now enabled in all runtime system ways"+         return d)+  , make_ord_flag defGhcFlag "debug"          (NoArg (addWayDynP WayDebug))+  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWayDynP WayThreaded))+  , make_ord_flag defGhcFlag "single-threaded" (NoArg (removeWayDynP WayThreaded))++  , make_ord_flag defGhcFlag "ticky"+      (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))++    -- -ticky enables ticky-ticky code generation, and also implies -debug which+    -- is required to get the RTS ticky support.++        ----- Linker --------------------------------------------------------+  , make_ord_flag defGhcFlag "static"         (NoArg (removeWayDynP WayDyn))+  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWayDynP WayDyn))+  , make_ord_flag defGhcFlag "rdynamic" $ noArg $+#if defined(linux_HOST_OS)+                              addOptl "-rdynamic"+#elif defined(mingw32_HOST_OS)+                              addOptl "-Wl,--export-all-symbols"+#else+    -- ignored for compat w/ gcc:+                              id+#endif+  , make_ord_flag defGhcFlag "relative-dynlib-paths"+      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))+  , make_ord_flag defGhcFlag "copy-libs-when-linking"+      (NoArg (setGeneralFlag Opt_SingleLibFolder))+  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))+  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))++        ------- Specific phases  --------------------------------------------+    -- need to appear before -pgmL to be parsed as LLVM flags.+  , make_ord_flag defFlag "pgmlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }+  , make_ord_flag defFlag "pgmlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }+  , make_ord_flag defFlag "pgmlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_las  = (f,[]) }+  , make_ord_flag defFlag "pgmlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  =+          if null f then Nothing else Just (f,[]) }+  , make_ord_flag defFlag "pgmi"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i   =  f }+  , make_ord_flag defFlag "pgmL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L   = f }+  , make_ord_flag defFlag "pgmP"+      (hasArg setPgmP)+  , make_ord_flag defFlag "pgmJSP"+      (hasArg setPgmJSP)+  , make_ord_flag defFlag "pgmCmmP"+      (hasArg setPgmCmmP)+  , make_ord_flag defFlag "pgmF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F   = f }+  , make_ord_flag defFlag "pgmc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c   = f }+  , make_ord_flag defFlag "pgmcxx"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f }+  , (Deprecated, defFlag  "pgmc-supports-no-pie"+      $ noArgM  $ \d -> do+        deprecate $ "use -pgml-supports-no-pie instead"+        pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d)+  , make_ord_flag defFlag "pgms"+      (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8"))+  , make_ord_flag defFlag "pgma"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a   = (f,[]) }+  , make_ord_flag defFlag "pgml"+      $ hasArg $ \f -> alterToolSettings $ \s -> s+         { toolSettings_pgm_l   = (f,[])+         , -- Don't pass -no-pie with custom -pgml (see #15319). Note+           -- that this could break when -no-pie is actually needed.+           -- But the CC_SUPPORTS_NO_PIE check only happens at+           -- buildtime, and -pgml is a runtime option. A better+           -- solution would be running this check for each custom+           -- -pgml.+           toolSettings_ccSupportsNoPie = False+         }+  , make_ord_flag defFlag "pgml-supports-no-pie"+      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }+  , make_ord_flag defFlag "pgmwindres"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }+  , make_ord_flag defFlag "pgmar"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f }+  , make_ord_flag defFlag "pgmotool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f}+  , make_ord_flag defFlag "pgminstall_name_tool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f}+  , make_ord_flag defFlag "pgmranlib"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f }+++    -- need to appear before -optl/-opta to be parsed as LLVM flags.+  , make_ord_flag defFlag "optlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm  = f : toolSettings_opt_lm s }+  , make_ord_flag defFlag "optlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }+  , make_ord_flag defFlag "optlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }+  , make_ord_flag defFlag "optlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_las  = f : toolSettings_opt_las s }+  , make_ord_flag defFlag "opti"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }+  , make_ord_flag defFlag "optL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L   = f : toolSettings_opt_L s }+  , make_ord_flag defFlag "optP"+      (hasArg addOptP)+  , make_ord_flag defFlag "optJSP"+      (hasArg addOptJSP)+  , make_ord_flag defFlag "optCmmP"+      (hasArg addOptCmmP)+  , make_ord_flag defFlag "optF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F   = f : toolSettings_opt_F s }+  , make_ord_flag defFlag "optc"+      (hasArg addOptc)+  , make_ord_flag defFlag "optcxx"+      (hasArg addOptcxx)+  , make_ord_flag defFlag "opta"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a   = f : toolSettings_opt_a s }+  , make_ord_flag defFlag "optl"+      (hasArg addOptl)+  , make_ord_flag defFlag "optwindres"+      $ hasArg $ \f ->+        alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s }++    -- N.B. We may someday deprecate this in favor of -fsplit-sections,+    -- which has the benefit of also having a negating -fno-split-sections.+  , make_ord_flag defGhcFlag "split-sections"+      (NoArg $ setGeneralFlag Opt_SplitSections)++        -------- ghc -M -----------------------------------------------------+  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)+  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)+  , make_ord_flag defGhcFlag "include-cpp-deps"+        (noArg (setDepIncludeCppDeps True))+  , make_ord_flag defGhcFlag "include-pkg-deps"+        (noArg (setDepIncludePkgDeps True))+  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)++        -------- Linking ----------------------------------------------------+  , make_ord_flag defGhcFlag "no-link"+        (noArg (\d -> d { ghcLink=NoLink }))+  , make_ord_flag defGhcFlag "shared"+        (noArg (\d -> d { ghcLink=LinkDynLib }))+  , make_ord_flag defGhcFlag "staticlib"+        (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))+  , make_ord_flag defGhcFlag "-merge-objs"+        (noArg (\d -> d { ghcLink=LinkMergedObj }))+  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)+  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)++        ------- Libraries ---------------------------------------------------+  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)+  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))++        ------- Frameworks --------------------------------------------------+        -- -framework-path should really be -F ...+  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)+  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)++        ------- Output Redirection ------------------------------------------+  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)+  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))+  , make_ord_flag defGhcFlag "dyno"+        (sepArg (setDynOutputFile . Just))+  , make_ord_flag defGhcFlag "ohi"+        (hasArg (setOutputHi . Just ))+  , make_ord_flag defGhcFlag "dynohi"+        (hasArg (setDynOutputHi . Just ))+  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)+  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)+  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)+  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)+  , make_ord_flag defGhcFlag "hiesuf"            (hasArg setHieSuf)+  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)+  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)+  , make_ord_flag defGhcFlag "hiedir"            (hasArg setHieDir)+  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)+  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)+  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)+  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)+  , make_ord_flag defGhcFlag "ddump-file-prefix"+        (hasArg (setDumpPrefixForce . Just . flip (++) "."))++  , make_ord_flag defGhcFlag "dynamic-too"+        (NoArg (setGeneralFlag Opt_BuildDynamicToo))++        ------- Keeping temporary files -------------------------------------+     -- These can be singular (think ghc -c) or plural (think ghc --make)+  , make_ord_flag defGhcFlag "keep-hc-file"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hc-files"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-file"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-files"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-s-file"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-s-files"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-llvm-file"+        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)+  , make_ord_flag defGhcFlag "keep-llvm-files"+        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)+     -- This only makes sense as plural+  , make_ord_flag defGhcFlag "keep-tmp-files"+        (NoArg (setGeneralFlag Opt_KeepTmpFiles))+  , make_ord_flag defGhcFlag "keep-hi-file"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-file"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-hi-files"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-files"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-o-file"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-file"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "keep-o-files"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-files"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))++        ------- Miscellaneous ----------------------------------------------+  , make_ord_flag defGhcFlag "no-auto-link-packages"+        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))+  , make_ord_flag defGhcFlag "no-hs-main"+        (NoArg (setGeneralFlag Opt_NoHsMain))+  , make_ord_flag defGhcFlag "fno-state-hack"+        (NoArg (setGeneralFlag Opt_G_NoStateHack))+  , make_ord_flag defGhcFlag "fno-opt-coercion"+        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))+  , make_ord_flag defGhcFlag "with-rtsopts"+        (HasArg setRtsOpts)+  , make_ord_flag defGhcFlag "rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=all"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=some"+        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))+  , make_ord_flag defGhcFlag "rtsopts=none"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "rtsopts=ignore"+        (NoArg (setRtsOptsEnabled RtsOptsIgnore))+  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"+        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))+  , make_ord_flag defGhcFlag "no-rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"+      (noArg (\d -> d {rtsOptsSuggestions = False}))+  , make_ord_flag defGhcFlag "dhex-word-literals"+        (NoArg (setGeneralFlag Opt_HexWordLiterals))++  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)+  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)+  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)+  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)+  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)+  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)+  , make_ord_flag defGhcFlag "ticky-allocd"+        (NoArg (setGeneralFlag Opt_Ticky_Allocd))+  , make_ord_flag defGhcFlag "ticky-LNE"+        (NoArg (setGeneralFlag Opt_Ticky_LNE))+  , make_ord_flag defGhcFlag "ticky-ap-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_AP))+  , make_ord_flag defGhcFlag "ticky-dyn-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))+  , make_ord_flag defGhcFlag "ticky-tag-checks"+        (NoArg (setGeneralFlag Opt_Ticky_Tag))+        ------- recompilation checker --------------------------------------+  , make_dep_flag defGhcFlag "recomp"+        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)+             "Use -fno-force-recomp instead"+  , make_dep_flag defGhcFlag "no-recomp"+        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"+  , make_ord_flag defFlag "fmax-errors"+      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))+  , make_ord_flag defFlag "fno-max-errors"+      (noArg (\d -> d { maxErrors = Nothing }))+  , make_ord_flag defFlag "freverse-errors"+        (noArg (\d -> d {reverseErrors = True} ))+  , make_ord_flag defFlag "fno-reverse-errors"+        (noArg (\d -> d {reverseErrors = False} ))++        ------ HsCpp opts ---------------------------------------------------+  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))+  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))++        ------- Include/Import Paths ----------------------------------------+  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)+  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)++        ------ Output style options -----------------------------------------+  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->+                                                       d { pprUserLength = n }))+  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->+                                                             d { pprCols = n }))+  , make_ord_flag defFlag "fdiagnostics-color=auto"+      (NoArg (upd (\d -> d { useColor = Auto })))+  , make_ord_flag defFlag "fdiagnostics-color=always"+      (NoArg (upd (\d -> d { useColor = Always })))+  , make_ord_flag defFlag "fdiagnostics-color=never"+      (NoArg (upd (\d -> d { useColor = Never })))++  , make_ord_flag defFlag "fprint-error-index-links=auto"+      (NoArg (upd (\d -> d { useErrorLinks = Auto })))+  , make_ord_flag defFlag "fprint-error-index-links=always"+      (NoArg (upd (\d -> d { useErrorLinks = Always })))+  , make_ord_flag defFlag "fprint-error-index-links=never"+      (NoArg (upd (\d -> d { useErrorLinks = Never })))++  -- Suppress all that is suppressible in core dumps.+  -- Except for uniques, as some simplifier phases introduce new variables that+  -- have otherwise identical names.+  , make_ord_flag defGhcFlag "dsuppress-all"+      (NoArg $ do setGeneralFlag Opt_SuppressCoercions+                  setGeneralFlag Opt_SuppressCoercionTypes+                  setGeneralFlag Opt_SuppressVarKinds+                  setGeneralFlag Opt_SuppressModulePrefixes+                  setGeneralFlag Opt_SuppressTypeApplications+                  setGeneralFlag Opt_SuppressIdInfo+                  setGeneralFlag Opt_SuppressTicks+                  setGeneralFlag Opt_SuppressStgExts+                  setGeneralFlag Opt_SuppressStgReps+                  setGeneralFlag Opt_SuppressTypeSignatures+                  setGeneralFlag Opt_SuppressCoreSizes+                  setGeneralFlag Opt_SuppressTimestamps)++        ------ Debugging ----------------------------------------------------+  , make_ord_flag defGhcFlag "dstg-stats"+        (NoArg (setGeneralFlag Opt_StgStats))++  , make_ord_flag defGhcFlag "ddump-cmm"+        (setDumpFlag Opt_D_dump_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"+        (setDumpFlag Opt_D_dump_cmm_from_stg)+  , make_ord_flag defGhcFlag "ddump-cmm-raw"+        (setDumpFlag Opt_D_dump_cmm_raw)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose"+        (setDumpFlag Opt_D_dump_cmm_verbose)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc"+        (setDumpFlag Opt_D_dump_cmm_verbose_by_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-cfg"+        (setDumpFlag Opt_D_dump_cmm_cfg)+  , make_ord_flag defGhcFlag "ddump-cmm-cbe"+        (setDumpFlag Opt_D_dump_cmm_cbe)+  , make_ord_flag defGhcFlag "ddump-cmm-switch"+        (setDumpFlag Opt_D_dump_cmm_switch)+  , make_ord_flag defGhcFlag "ddump-cmm-proc"+        (setDumpFlag Opt_D_dump_cmm_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-sp"+        (setDumpFlag Opt_D_dump_cmm_sp)+  , make_ord_flag defGhcFlag "ddump-cmm-sink"+        (setDumpFlag Opt_D_dump_cmm_sink)+  , make_ord_flag defGhcFlag "ddump-cmm-caf"+        (setDumpFlag Opt_D_dump_cmm_caf)+  , make_ord_flag defGhcFlag "ddump-cmm-procmap"+        (setDumpFlag Opt_D_dump_cmm_procmap)+  , make_ord_flag defGhcFlag "ddump-cmm-split"+        (setDumpFlag Opt_D_dump_cmm_split)+  , make_ord_flag defGhcFlag "ddump-cmm-info"+        (setDumpFlag Opt_D_dump_cmm_info)+  , make_ord_flag defGhcFlag "ddump-cmm-cps"+        (setDumpFlag Opt_D_dump_cmm_cps)+  , make_ord_flag defGhcFlag "ddump-cmm-opt"+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer"+        (setDumpFlag Opt_D_dump_cmm_thread_sanitizer)+  , make_ord_flag defGhcFlag "ddump-cfg-weights"+        (setDumpFlag Opt_D_dump_cfg_weights)+  , make_ord_flag defGhcFlag "ddump-core-stats"+        (setDumpFlag Opt_D_dump_core_stats)+  , make_ord_flag defGhcFlag "ddump-asm"+        (setDumpFlag Opt_D_dump_asm)+  , make_ord_flag defGhcFlag "ddump-js"+        (setDumpFlag Opt_D_dump_js)+  , make_ord_flag defGhcFlag "ddump-asm-native"+        (setDumpFlag Opt_D_dump_asm_native)+  , make_ord_flag defGhcFlag "ddump-asm-liveness"+        (setDumpFlag Opt_D_dump_asm_liveness)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc"+        (setDumpFlag Opt_D_dump_asm_regalloc)+  , make_ord_flag defGhcFlag "ddump-asm-conflicts"+        (setDumpFlag Opt_D_dump_asm_conflicts)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"+        (setDumpFlag Opt_D_dump_asm_regalloc_stages)+  , make_ord_flag defGhcFlag "ddump-asm-stats"+        (setDumpFlag Opt_D_dump_asm_stats)+  , make_ord_flag defGhcFlag "ddump-llvm"+        (NoArg $ setDumpFlag' Opt_D_dump_llvm)+  , make_ord_flag defGhcFlag "ddump-c-backend"+        (NoArg $ setDumpFlag' Opt_D_dump_c_backend)+  , make_ord_flag defGhcFlag "ddump-deriv"+        (setDumpFlag Opt_D_dump_deriv)+  , make_ord_flag defGhcFlag "ddump-ds"+        (setDumpFlag Opt_D_dump_ds)+  , make_ord_flag defGhcFlag "ddump-ds-preopt"+        (setDumpFlag Opt_D_dump_ds_preopt)+  , make_ord_flag defGhcFlag "ddump-foreign"+        (setDumpFlag Opt_D_dump_foreign)+  , make_ord_flag defGhcFlag "ddump-inlinings"+        (setDumpFlag Opt_D_dump_inlinings)+  , make_ord_flag defGhcFlag "ddump-verbose-inlinings"+        (setDumpFlag Opt_D_dump_verbose_inlinings)+  , make_ord_flag defGhcFlag "ddump-rule-firings"+        (setDumpFlag Opt_D_dump_rule_firings)+  , make_ord_flag defGhcFlag "ddump-rule-rewrites"+        (setDumpFlag Opt_D_dump_rule_rewrites)+  , make_ord_flag defGhcFlag "ddump-simpl-trace"+        (setDumpFlag Opt_D_dump_simpl_trace)+  , make_ord_flag defGhcFlag "ddump-occur-anal"+        (setDumpFlag Opt_D_dump_occur_anal)+  , make_ord_flag defGhcFlag "ddump-parsed"+        (setDumpFlag Opt_D_dump_parsed)+  , make_ord_flag defGhcFlag "ddump-parsed-ast"+        (setDumpFlag Opt_D_dump_parsed_ast)+  , make_ord_flag defGhcFlag "dkeep-comments"+        (NoArg (setGeneralFlag Opt_KeepRawTokenStream))+  , make_ord_flag defGhcFlag "ddump-rn"+        (setDumpFlag Opt_D_dump_rn)+  , make_ord_flag defGhcFlag "ddump-rn-ast"+        (setDumpFlag Opt_D_dump_rn_ast)+  , make_ord_flag defGhcFlag "ddump-simpl"+        (setDumpFlag Opt_D_dump_simpl)+  , make_ord_flag defGhcFlag "ddump-simpl-iterations"+      (setDumpFlag Opt_D_dump_simpl_iterations)+  , make_ord_flag defGhcFlag "ddump-spec"+        (setDumpFlag Opt_D_dump_spec)+  , make_ord_flag defGhcFlag "ddump-spec-constr"+        (setDumpFlag Opt_D_dump_spec_constr)+  , make_ord_flag defGhcFlag "ddump-prep"+        (setDumpFlag Opt_D_dump_prep)+  , make_ord_flag defGhcFlag "ddump-late-cc"+        (setDumpFlag Opt_D_dump_late_cc)+  , make_ord_flag defGhcFlag "ddump-stg-from-core"+        (setDumpFlag Opt_D_dump_stg_from_core)+  , make_ord_flag defGhcFlag "ddump-stg-unarised"+        (setDumpFlag Opt_D_dump_stg_unarised)+  , make_ord_flag defGhcFlag "ddump-stg-final"+        (setDumpFlag Opt_D_dump_stg_final)+  , make_ord_flag defGhcFlag "ddump-stg-cg"+        (setDumpFlag Opt_D_dump_stg_cg)+  , make_dep_flag defGhcFlag "ddump-stg"+        (setDumpFlag Opt_D_dump_stg_from_core)+        "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"+        (setDumpFlag Opt_D_dump_exitify)+  , make_dep_flag defGhcFlag "ddump-stranal"+        (setDumpFlag Opt_D_dump_dmdanal)+        "Use `-ddump-dmdanal` instead"+  , make_dep_flag defGhcFlag "ddump-str-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+        "Use `-ddump-dmd-signatures` instead"+  , make_ord_flag defGhcFlag "ddump-dmdanal"+        (setDumpFlag Opt_D_dump_dmdanal)+  , make_ord_flag defGhcFlag "ddump-dmd-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+  , make_ord_flag defGhcFlag "ddump-cpranal"+        (setDumpFlag Opt_D_dump_cpranal)+  , make_ord_flag defGhcFlag "ddump-cpr-signatures"+        (setDumpFlag Opt_D_dump_cpr_signatures)+  , make_ord_flag defGhcFlag "ddump-tc"+        (setDumpFlag Opt_D_dump_tc)+  , make_ord_flag defGhcFlag "ddump-tc-ast"+        (setDumpFlag Opt_D_dump_tc_ast)+  , make_ord_flag defGhcFlag "ddump-hie"+        (setDumpFlag Opt_D_dump_hie)+  , make_ord_flag defGhcFlag "ddump-types"+        (setDumpFlag Opt_D_dump_types)+  , make_ord_flag defGhcFlag "ddump-rules"+        (setDumpFlag Opt_D_dump_rules)+  , make_ord_flag defGhcFlag "ddump-cse"+        (setDumpFlag Opt_D_dump_cse)+  , make_ord_flag defGhcFlag "ddump-float-out"+        (setDumpFlag Opt_D_dump_float_out)+  , make_ord_flag defGhcFlag "ddump-full-laziness"+        (setDumpFlag Opt_D_dump_float_out)+  , make_ord_flag defGhcFlag "ddump-float-in"+        (setDumpFlag Opt_D_dump_float_in)+  , make_ord_flag defGhcFlag "ddump-liberate-case"+        (setDumpFlag Opt_D_dump_liberate_case)+  , make_ord_flag defGhcFlag "ddump-static-argument-transformation"+        (setDumpFlag Opt_D_dump_static_argument_transformation)+  , make_ord_flag defGhcFlag "ddump-worker-wrapper"+        (setDumpFlag Opt_D_dump_worker_wrapper)+  , make_ord_flag defGhcFlag "ddump-rn-trace"+        (setDumpFlag Opt_D_dump_rn_trace)+  , make_ord_flag defGhcFlag "ddump-if-trace"+        (setDumpFlag Opt_D_dump_if_trace)+  , make_ord_flag defGhcFlag "ddump-cs-trace"+        (setDumpFlag Opt_D_dump_cs_trace)+  , make_ord_flag defGhcFlag "ddump-tc-trace"+        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace+                   setDumpFlag' Opt_D_dump_cs_trace))+  , make_ord_flag defGhcFlag "ddump-ec-trace"+        (setDumpFlag Opt_D_dump_ec_trace)+  , make_ord_flag defGhcFlag "ddump-splices"+        (setDumpFlag Opt_D_dump_splices)+  , make_ord_flag defGhcFlag "dth-dec-file"+        (setDumpFlag Opt_D_th_dec_file)++  , make_ord_flag defGhcFlag "ddump-rn-stats"+        (setDumpFlag Opt_D_dump_rn_stats)+  , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-simpl-stats"+        (setDumpFlag Opt_D_dump_simpl_stats)+  , make_ord_flag defGhcFlag "ddump-bcos"+        (setDumpFlag Opt_D_dump_BCOs)+  , make_ord_flag defGhcFlag "dsource-stats"+        (setDumpFlag Opt_D_source_stats)+  , make_ord_flag defGhcFlag "dverbose-core2core"+        (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core)+  , make_ord_flag defGhcFlag "dverbose-stg2stg"+        (setDumpFlag Opt_D_verbose_stg2stg)+  , make_ord_flag defGhcFlag "ddump-hi"+        (setDumpFlag Opt_D_dump_hi)+  , make_ord_flag defGhcFlag "ddump-minimal-imports"+        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))+  , make_ord_flag defGhcFlag "ddump-hpc"+        (setDumpFlag Opt_D_dump_ticked) -- back compat+  , make_ord_flag defGhcFlag "ddump-ticked"+        (setDumpFlag Opt_D_dump_ticked)+  , make_ord_flag defGhcFlag "ddump-mod-cycles"+        (setDumpFlag Opt_D_dump_mod_cycles)+  , make_ord_flag defGhcFlag "ddump-mod-map"+        (setDumpFlag Opt_D_dump_mod_map)+  , make_ord_flag defGhcFlag "ddump-timings"+        (setDumpFlag Opt_D_dump_timings)+  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"+        (setDumpFlag Opt_D_dump_view_pattern_commoning)+  , make_ord_flag defGhcFlag "ddump-to-file"+        (NoArg (setGeneralFlag Opt_DumpToFile))+  , make_ord_flag defGhcFlag "ddump-hi-diffs"+        (setDumpFlag Opt_D_dump_hi_diffs)+  , make_ord_flag defGhcFlag "ddump-rtti"+        (setDumpFlag Opt_D_dump_rtti)+  , make_ord_flag defGhcFlag "dlint"+        (NoArg enableDLint)+  , make_ord_flag defGhcFlag "dcore-lint"+        (NoArg (setGeneralFlag Opt_DoCoreLinting))+  , make_ord_flag defGhcFlag "dlinear-core-lint"+        (NoArg (setGeneralFlag Opt_DoLinearCoreLinting))+  , make_ord_flag defGhcFlag "dstg-lint"+        (NoArg (setGeneralFlag Opt_DoStgLinting))+  , make_ord_flag defGhcFlag "dcmm-lint"+        (NoArg (setGeneralFlag Opt_DoCmmLinting))+  , make_ord_flag defGhcFlag "dasm-lint"+        (NoArg (setGeneralFlag Opt_DoAsmLinting))+  , make_ord_flag defGhcFlag "dannot-lint"+        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))+  , make_ord_flag defGhcFlag "dtag-inference-checks"+        (NoArg (setGeneralFlag Opt_DoTagInferenceChecks))+  , make_ord_flag defGhcFlag "dshow-passes"+        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dipe-stats"+        (setDumpFlag Opt_D_ipe_stats)+  , make_ord_flag defGhcFlag "dfaststring-stats"+        (setDumpFlag Opt_D_faststring_stats)+  , make_ord_flag defGhcFlag "dno-llvm-mangler"+        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag+  , make_ord_flag defGhcFlag "dno-typeable-binds"+        (NoArg (setGeneralFlag Opt_NoTypeableBinds))+  , make_ord_flag defGhcFlag "ddump-debug"+        (setDumpFlag Opt_D_dump_debug)+  , make_dep_flag defGhcFlag "ddump-json"+        (setDumpFlag Opt_D_dump_json)+        "Use `-fdiagnostics-as-json` instead"+  , make_ord_flag defGhcFlag "dppr-debug"+        (setDumpFlag Opt_D_ppr_debug)+  , make_ord_flag defGhcFlag "ddebug-output"+        (noArg (flip dopt_unset Opt_D_no_debug_output))+  , make_ord_flag defGhcFlag "dno-debug-output"+        (setDumpFlag Opt_D_no_debug_output)+  , make_ord_flag defGhcFlag "ddump-faststrings"+        (setDumpFlag Opt_D_dump_faststrings)++        ------ Machine dependent (-m<blah>) stuff ---------------------------++  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->+                                                  d { sseVersion = Just SSE1 }))+  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->+                                                  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 ->+                                                 d { sseVersion = Just SSE42 }))+  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->+                                                 d { bmiVersion = Just BMI1 }))+  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->+                                                 d { bmiVersion = Just BMI2 }))+  , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))+  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))+  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->+                                                         d { avx512cd = True }))+  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->+                                                         d { avx512er = True }))+  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))+  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->+                                                         d { avx512pf = True }))+  , make_ord_flag defGhcFlag "mfma"         (noArg (\d -> d { fma = True }))++        ------ Plugin flags ------------------------------------------------+  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)+  , make_ord_flag defGhcFlag "fplugin-trustworthy"+      (NoArg (setGeneralFlag Opt_PluginTrustworthy))+  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)+  , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames)+  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)++  , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin)++        ------ Optimisation flags ------------------------------------------+  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )+                                                            "Use -O0 instead"+  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->+                                                setOptLevel (mb_n `orElse` 1)))+                -- If the number is missing, use 1++  , make_ord_flag defFlag "fbinary-blob-threshold"+      (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of+                                                    0 -> Nothing+                                                    x -> Just x}))+  , make_ord_flag defFlag "fmax-relevant-binds"+      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))+  , make_ord_flag defFlag "fno-max-relevant-binds"+      (noArg (\d -> d { maxRelevantBinds = Nothing }))++  , make_ord_flag defFlag "fmax-valid-hole-fits"+      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-valid-hole-fits"+      (noArg (\d -> d { maxValidHoleFits = Nothing }))+  , make_ord_flag defFlag "fmax-refinement-hole-fits"+      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-refinement-hole-fits"+      (noArg (\d -> d { maxRefHoleFits = Nothing }))+  , make_ord_flag defFlag "frefinement-level-hole-fits"+      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))+  , make_ord_flag defFlag "fno-refinement-level-hole-fits"+      (noArg (\d -> d { refLevelHoleFits = Nothing }))++  , make_ord_flag defFlag "fwrite-if-compression"+      (intSuffix (\n d -> d { ifCompression = n }))++  , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"+            (noArg id)+            "vectors registers are now passed in registers by default."+  , make_ord_flag defFlag "fmax-uncovered-patterns"+      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))+  , make_ord_flag defFlag "fmax-pmcheck-models"+      (intSuffix (\n d -> d { maxPmCheckModels = n }))+  , make_ord_flag defFlag "fsimplifier-phases"+      (intSuffix (\n d -> d { simplPhases = n }))+  , make_ord_flag defFlag "fmax-simplifier-iterations"+      (intSuffix (\n d -> d { maxSimplIterations = n }))+  , (Deprecated, defFlag "fmax-pmcheck-iterations"+      (intSuffixM (\_ d ->+       do { deprecate $ "use -fmax-pmcheck-models instead"+          ; return d })))+  , make_ord_flag defFlag "fsimpl-tick-factor"+      (intSuffix (\n d -> d { simplTickFactor = n }))+  , make_ord_flag defFlag "fdmd-unbox-width"+      (intSuffix (\n d -> d { dmdUnboxWidth = n }))+  , make_ord_flag defFlag "fspec-constr-threshold"+      (intSuffix (\n d -> d { specConstrThreshold = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-threshold"+      (noArg (\d -> d { specConstrThreshold = Nothing }))+  , make_ord_flag defFlag "fspec-constr-count"+      (intSuffix (\n d -> d { specConstrCount = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-count"+      (noArg (\d -> d { specConstrCount = Nothing }))+  , make_ord_flag defFlag "fspec-constr-recursive"+      (intSuffix (\n d -> d { specConstrRecursive = n }))+  , make_ord_flag defFlag "fliberate-case-threshold"+      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))+  , make_ord_flag defFlag "fno-liberate-case-threshold"+      (noArg (\d -> d { liberateCaseThreshold = Nothing }))+  , make_ord_flag defFlag "drule-check"+      (sepArg (\s d -> d { ruleCheck = Just s }))+  , make_ord_flag defFlag "dinline-check"+      (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)}))+  , make_ord_flag defFlag "freduction-depth"+      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))+  , make_ord_flag defFlag "fconstraint-solver-iterations"+      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))+  , make_ord_flag defFlag "fgivens-expansion-fuel"+      (intSuffix (\n d -> d { givensFuel = n }))+  , make_ord_flag defFlag "fwanteds-expansion-fuel"+      (intSuffix (\n d -> d { wantedsFuel = n }))+  , make_ord_flag defFlag "fqcs-expansion-fuel"+      (intSuffix (\n d -> d { qcsFuel = n }))+  , (Deprecated, defFlag "fcontext-stack"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , (Deprecated, defFlag "ftype-function-depth"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , make_ord_flag defFlag "fstrictness-before"+      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))+  , make_ord_flag defFlag "ffloat-lam-args"+      (intSuffix (\n d -> d { floatLamArgs = Just n }))+  , make_ord_flag defFlag "ffloat-all-lams"+      (noArg (\d -> d { floatLamArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args"+      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args-any"+      (noArg (\d -> d { liftLamsRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args"+      (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"+      (noArg (\d -> d { liftLamsNonRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = True }))+  , make_ord_flag defFlag "fno-stg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = False }))+  , make_ord_flag defFlag "fproc-alignment"+      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))+  , make_ord_flag defFlag "fblock-layout-weights"+        (HasArg (\s ->+            upd (\d -> d { cfgWeights =+                parseWeights s (cfgWeights d)})))+  , make_ord_flag defFlag "fhistory-size"+      (intSuffix (\n d -> d { historySize = n }))++  , make_ord_flag defFlag "funfolding-creation-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-use-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-fun-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-dict-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)}))++  , make_ord_flag defFlag "funfolding-case-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-case-scaling"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))++  , make_dep_flag defFlag "funfolding-keeness-factor"+      (floatSuffix (\_ d -> d))+      "-funfolding-keeness-factor is no longer respected as of GHC 9.0"++  , make_ord_flag defFlag "fmax-worker-args"+      (intSuffix (\n d -> d {maxWorkerArgs = n}))+  , make_ord_flag defFlag "fmax-forced-spec-args"+      (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"+      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"+      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))+  , make_ord_flag defGhcFlag "dinitial-unique"+      (word64Suffix (\n d -> d { initialUnique = n }))+  , make_ord_flag defGhcFlag "dunique-increment"+      (intSuffix (\n d -> d { uniqueIncrement = n }))++        ------ Profiling ----------------------------------------------------++        -- OLD profiling flags+  , make_dep_flag defGhcFlag "auto-all"+                    (noArg (\d -> d { profAuto = ProfAutoAll } ))+                    "Use -fprof-auto instead"+  , make_dep_flag defGhcFlag "no-auto-all"+                    (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "auto"+                    (noArg (\d -> d { profAuto = ProfAutoExports } ))+                    "Use -fprof-auto-exported instead"+  , make_dep_flag defGhcFlag "no-auto"+            (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "caf-all"+            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fprof-cafs instead"+  , make_dep_flag defGhcFlag "no-caf-all"+            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fno-prof-cafs instead"++        -- NEW profiling flags+  , make_ord_flag defGhcFlag "fprof-auto"+      (noArg (\d -> d { profAuto = ProfAutoAll } ))+  , make_ord_flag defGhcFlag "fprof-auto-top"+      (noArg (\d -> d { profAuto = ProfAutoTop } ))+  , make_ord_flag defGhcFlag "fprof-auto-exported"+      (noArg (\d -> d { profAuto = ProfAutoExports } ))+  , make_ord_flag defGhcFlag "fprof-auto-calls"+      (noArg (\d -> d { profAuto = ProfAutoCalls } ))+  , make_ord_flag defGhcFlag "fno-prof-auto"+      (noArg (\d -> d { profAuto = NoProfAuto } ))++        -- Caller-CC+  , make_ord_flag defGhcFlag "fprof-callers"+         (HasArg setCallerCcFilters)+        ------ Compiler flags -----------------------------------------------++  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend ncgBackend))+  , make_ord_flag defGhcFlag "fvia-c"           (NoArg+         (deprecate $ "The -fvia-c flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fvia-C"           (NoArg+         (deprecate $ "The -fvia-C flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjBackend llvmBackend))++  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->+                  d { ghcLink=NoLink }) >> setBackend noBackend))+  , make_ord_flag defFlag "fbyte-code"+      (noArgM $ \dflags -> do+        setBackend interpreterBackend+        pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode))+  , make_ord_flag defFlag "fobject-code"     $ noArgM $ \dflags -> do+      setBackend $ platformDefaultBackend (targetPlatform dflags)+      dflags' <- liftEwM getCmdLineState+      pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode++  , make_dep_flag defFlag "fglasgow-exts"+      (NoArg enableGlasgowExts) "Use individual extensions instead"+  , make_dep_flag defFlag "fno-glasgow-exts"+      (NoArg disableGlasgowExts) "Use individual extensions instead"++        ------ Safe Haskell flags -------------------------------------------+  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)+  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->+                                                    d { safeInfer = False }))+  , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore))++        ------ position independent flags  ----------------------------------+  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIE))+  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIE))++         ------ Debugging flags ----------------------------------------------+  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)+ ]+ ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps+ ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps+ ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps+ ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps+ ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps+ ++++        ------ Warning flags -------------------------------------------------+  [ make_ord_flag defFlag "W"       (NoArg (setWarningGroup W_extra))+  , make_ord_flag defFlag "Werror"+               (NoArg (do { setGeneralFlag Opt_WarnIsError+                          ; setFatalWarningGroup W_everything }))+  , make_ord_flag defFlag "Wwarn"+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError+                          ; unSetFatalWarningGroup W_everything }))+                          -- Opt_WarnIsError is still needed to pass -Werror+                          -- to CPP; see runCpp in SysTools+  , make_dep_flag defFlag "Wnot"    (NoArg (unSetWarningGroup W_everything))+                                             "Use -w or -Wno-everything instead"+  , make_ord_flag defFlag "w"       (NoArg (unSetWarningGroup W_everything))+  ]++     -- New-style uniform warning sets+     --+     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything+ ++ warningControls setWarningGroup unSetWarningGroup setWErrorWarningGroup unSetFatalWarningGroup warningGroupsDeps+ ++ warningControls setWarningFlag unSetWarningFlag setWErrorFlag unSetFatalWarningFlag wWarningFlagsDeps+ ++ warningControls setCustomWarningFlag unSetCustomWarningFlag setCustomWErrorFlag unSetCustomFatalWarningFlag+      [(NotDeprecated, FlagSpec "warnings-deprecations" defaultWarningCategory nop AllModes)]+      -- See Note [Warning categories] in GHC.Unit.Module.Warnings.++ ++ [ (NotDeprecated, customOrUnrecognisedWarning "Wno-"       unSetCustomWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Werror="    setCustomWErrorFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Wwarn="     unSetCustomFatalWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "W"          setCustomWarningFlag)+    , (Deprecated,    customOrUnrecognisedWarning "fwarn-"     setCustomWarningFlag)+    , (Deprecated,    customOrUnrecognisedWarning "fno-warn-"  unSetCustomWarningFlag)+    ]++     ------ JavaScript flags -----------------------------------------------+ ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier))+    , make_ord_flag defFlag "ddisable-js-c-sources" (NoArg (setGeneralFlag Opt_DisableJsCsources))+    ]++     ------ Language flags -------------------------------------------------+ ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps+ ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps+ ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps+ ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps+ ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps++-- | Warnings have both new-style flags to control their state (@-W@, @-Wno-@,+-- @-Werror=@, @-Wwarn=@) and old-style flags (@-fwarn-@, @-fno-warn-@).  We+-- define these uniformly for individual warning flags and groups of warnings.+warningControls :: (warn_flag -> DynP ()) -- ^ Set the warning+                -> (warn_flag -> DynP ()) -- ^ Unset the warning+                -> (warn_flag -> DynP ()) -- ^ Make the warning an error+                -> (warn_flag -> DynP ()) -- ^ Clear the error status+                -> [(Deprecation, FlagSpec warn_flag)]+                -> [(Deprecation, Flag (CmdLineP DynFlags))]+warningControls set unset set_werror unset_fatal xs =+    map (mkFlag turnOn  "W"          set             ) xs+ ++ map (mkFlag turnOff "Wno-"       unset           ) xs+ ++ map (mkFlag turnOn  "Werror="    set_werror      ) xs+ ++ map (mkFlag turnOn  "Wwarn="     unset_fatal     ) xs+ ++ map (mkFlag turnOn  "Wno-error=" unset_fatal     ) xs+ ++ map (mkFlag turnOn  "fwarn-"     set   . hideFlag) xs+ ++ map (mkFlag turnOff "fno-warn-"  unset . hideFlag) xs++-- | This is where we handle unrecognised warning flags. If the flag is valid as+-- an extended warning category, we call the supplied action. Otherwise, issue a+-- warning if -Wunrecognised-warning-flags is set. See #11429 for context.+-- See Note [Warning categories] in GHC.Unit.Module.Warnings.+customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags)+customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action)+  where+    action :: String -> DynP ()+    action flag+      | validWarningCategory cat = custom cat+      | otherwise = unrecognised flag+      where+        cat = mkWarningCategory (mkFastString flag)++    unrecognised flag = do+      -- #23402 and #12056+      -- for unrecognised flags we consider current dynflags, not the final one.+      -- But if final state says to not report unrecognised flags, they won't anyway.+      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState+      when f $ addFlagWarn (DriverUnrecognisedFlag (prefix ++ flag))++-- See Note [Supporting CLI completion]+package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+package_flags_deps = [+        ------- Packages ----------------------------------------------------+    make_ord_flag defFlag "package-db"+      (HasArg (addPkgDbRef . PkgDbPath))+  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)+  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)+  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)+  , make_ord_flag defFlag "global-package-db"+      (NoArg (addPkgDbRef GlobalPkgDb))+  , make_ord_flag defFlag "user-package-db"+      (NoArg (addPkgDbRef UserPkgDb))+    -- backwards compat with GHC<=7.4 :+  , make_dep_flag defFlag "package-conf"+      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"+  , make_dep_flag defFlag "no-user-package-conf"+      (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"+  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->+                                      upd (setUnitId name))+  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)++  , make_ord_flag defGhcFlag "working-dir"       (hasArg setWorkingDirectory)+  , make_ord_flag defGhcFlag "this-package-name"  (hasArg setPackageName)+  , make_ord_flag defGhcFlag "hidden-module"      (HasArg addHiddenModule)+  , make_ord_flag defGhcFlag "reexported-module"  (HasArg addReexportedModule)++  , make_ord_flag defFlag "package"               (HasArg exposePackage)+  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)+  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)+  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)+  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)+  , make_ord_flag defFlag "hide-all-packages"+      (NoArg (setGeneralFlag Opt_HideAllPackages))+  , make_ord_flag defFlag "hide-all-plugin-packages"+      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))+  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)+  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)+  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"+  , make_ord_flag defFlag "distrust-all-packages"+      (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 }++-- | Make a list of flags for shell completion.+-- Filter all available flags into two groups, for interactive GHC vs all other.+flagsForCompletion :: Bool -> [String]+flagsForCompletion isInteractive+    = [ '-':flagName flag+      | flag <- flagsAll+      , modeFilter (flagGhcMode flag)+      ]+    where+      modeFilter AllModes = True+      modeFilter OnlyGhci = isInteractive+      modeFilter OnlyGhc = not isInteractive+      modeFilter HiddenFlag = False++data FlagSpec flag+   = FlagSpec+       { flagSpecName :: String   -- ^ Flag in string form+       , flagSpecFlag :: flag     -- ^ Flag in internal form+       , flagSpecAction :: (TurnOnFlag -> DynP ())+           -- ^ Extra action to run when the flag is found+           -- Typically, emit a warning or error+       , flagSpecGhcMode :: GhcFlagMode+           -- ^ In which ghc mode the flag has effect+       }++-- | Define a new flag.+flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagSpec name flag = flagSpec' name flag nop++-- | Define a new flag with an effect.+flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+          -> (Deprecation, FlagSpec flag)+flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)++-- | Define a warning flag.+warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec flag = warnSpec' flag nop++-- | Define a warning flag with an effect.+warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ())+          -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes)+                     | name <- NE.toList (warnFlagNames flag)+                     ]++-- | Define a new deprecated flag with an effect.+depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpecOp name flag act dep =+    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))++-- | Define a new deprecated flag.+depFlagSpec :: String -> flag -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpec name flag dep = depFlagSpecOp name flag nop dep++-- | Define a deprecated warning flag.+depWarnSpec :: WarningFlag -> String+            -> [(Deprecation, FlagSpec WarningFlag)]+depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep+                       | name <- NE.toList (warnFlagNames flag)+                       ]++-- | Define a deprecated warning name substituted by another.+subWarnSpec :: String -> WarningFlag -> String+            -> [(Deprecation, FlagSpec WarningFlag)]+subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ]+++-- | Define a new deprecated flag with an effect where the deprecation message+-- depends on the flag value+depFlagSpecOp' :: String+             -> flag+             -> (TurnOnFlag -> DynP ())+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpecOp' name flag act dep =+    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))+                                                                       AllModes)++-- | Define a new deprecated flag where the deprecation message+-- depends on the flag value+depFlagSpec' :: String+             -> flag+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep++-- | Define a new flag for GHCi.+flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagGhciSpec name flag = flagGhciSpec' name flag nop++-- | Define a new flag for GHCi with an effect.+flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+              -> (Deprecation, FlagSpec flag)+flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)++-- | Define a new flag invisible to CLI completion.+flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagHiddenSpec name flag = flagHiddenSpec' name flag nop++-- | Define a new flag invisible to CLI completion with an effect.+flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+                -> (Deprecation, FlagSpec flag)+flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act+                                                                     HiddenFlag)++-- | Hide a 'FlagSpec' from being displayed in @--show-options@.+--+-- This is for example useful for flags that are obsolete, but should not+-- (yet) be deprecated for compatibility reasons.+hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)+hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })++mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on+       -> String                -- ^ The flag prefix+       -> (flag -> DynP ())     -- ^ What to do when the flag is found+       -> (Deprecation, FlagSpec flag)  -- ^ Specification of+                                        -- this particular flag+       -> (Deprecation, Flag (CmdLineP DynFlags))+mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))+    = (dep,+       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)++deprecate :: String -> DynP ()+deprecate s = do+    arg <- getArg+    addFlagWarn (DriverDeprecatedFlag arg s)++deprecatedForExtension :: String -> TurnOnFlag -> String+deprecatedForExtension lang turn_on+    = "use -X" ++ flag +++      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"+    where+      flag | turn_on   = lang+           | otherwise = "No" ++ lang++deprecatedForExtensions :: [String] -> TurnOnFlag -> String+deprecatedForExtensions [] _ = panic "new extension has not been specified"+deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on+deprecatedForExtensions langExts turn_on+    = "use " ++ xExt flags ++ " instead"+    where+      flags | turn_on = langExts+            | otherwise = ("No" ++) <$> langExts++      xExt fls = intercalate " and "  $ (\flag -> "-X" ++ flag) <$> fls++useInstead :: String -> String -> TurnOnFlag -> String+useInstead prefix flag turn_on+  = "Use " ++ prefix ++ no ++ flag ++ " instead"+  where+    no = if turn_on then "" else "no-"++nop :: TurnOnFlag -> DynP ()+nop _ = return ()++-- | Find the 'FlagSpec' for a 'WarningFlag'.+flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)+flagSpecOf = flip Map.lookup wWarningFlagMap++wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag)+wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags++-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@+wWarningFlags :: [FlagSpec WarningFlag]+wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)++wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]+wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x+  Opt_WarnAmbiguousFields -> warnSpec x+  Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"+  Opt_WarnCPPUndef -> 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+  Opt_WarnDeprecatedFlags -> warnSpec x+  Opt_WarnDerivingDefaults -> warnSpec x+  Opt_WarnDerivingTypeable -> warnSpec x+  Opt_WarnDodgyExports -> warnSpec x+  Opt_WarnDodgyForeignImports -> warnSpec x+  Opt_WarnDodgyImports -> warnSpec x+  Opt_WarnEmptyEnumerations -> warnSpec x+  Opt_WarnDuplicateConstraints+    -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"+  Opt_WarnRedundantConstraints -> warnSpec x+  Opt_WarnDuplicateExports -> warnSpec x+  Opt_WarnHiShadows+    -> depWarnSpec x "it is not used, and was never implemented"+  Opt_WarnInaccessibleCode -> warnSpec x+  Opt_WarnImplicitPrelude -> warnSpec x+  Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error"+  Opt_WarnIncompletePatterns -> warnSpec x+  Opt_WarnIncompletePatternsRecUpd -> warnSpec x+  Opt_WarnIncompleteUniPatterns -> warnSpec x+  Opt_WarnInconsistentFlags -> warnSpec x+  Opt_WarnInlineRuleShadowing -> warnSpec x+  Opt_WarnIdentities -> warnSpec x+  Opt_WarnLoopySuperclassSolve -> depWarnSpec x "it is now an error"+  Opt_WarnMissingFields -> warnSpec x+  Opt_WarnMissingImportList -> warnSpec x+  Opt_WarnMissingExportList -> warnSpec x+  Opt_WarnMissingLocalSignatures+    -> subWarnSpec "missing-local-sigs" x+                   "it is replaced by -Wmissing-local-signatures"+       ++ warnSpec x+  Opt_WarnMissingMethods -> warnSpec x+  Opt_WarnMissingMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid"+  Opt_WarnMissingSignatures -> warnSpec x+  Opt_WarnMissingKindSignatures -> warnSpec x+  Opt_WarnMissingPolyKindSignatures -> warnSpec x+  Opt_WarnMissingExportedSignatures+    -> subWarnSpec "missing-exported-sigs" x+                   "it is replaced by -Wmissing-exported-signatures"+       ++ warnSpec x+  Opt_WarnMonomorphism -> warnSpec x+  Opt_WarnNameShadowing -> warnSpec x+  Opt_WarnNonCanonicalMonadInstances -> warnSpec x+  Opt_WarnNonCanonicalMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnNonCanonicalMonoidInstances -> warnSpec x+  Opt_WarnOrphans -> warnSpec x+  Opt_WarnOverflowedLiterals -> warnSpec x+  Opt_WarnOverlappingPatterns -> warnSpec x+  Opt_WarnMissedSpecs -> warnSpec x+  Opt_WarnAllMissedSpecs -> warnSpec x+  Opt_WarnSafe -> warnSpec' x setWarnSafe+  Opt_WarnTrustworthySafe -> warnSpec x+  Opt_WarnInferredSafeImports -> warnSpec x+  Opt_WarnMissingSafeHaskellMode -> warnSpec x+  Opt_WarnTabs -> warnSpec x+  Opt_WarnTypeDefaults -> warnSpec x+  Opt_WarnTypedHoles -> warnSpec x+  Opt_WarnPartialTypeSignatures -> warnSpec x+  Opt_WarnUnrecognisedPragmas -> warnSpec x+  Opt_WarnMisplacedPragmas -> warnSpec x+  Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe+  Opt_WarnUnsupportedCallingConventions -> warnSpec x+  Opt_WarnUnsupportedLlvmVersion -> warnSpec x+  Opt_WarnMissedExtraSharedLib -> warnSpec x+  Opt_WarnUntickedPromotedConstructors -> warnSpec x+  Opt_WarnUnusedDoBind -> warnSpec x+  Opt_WarnUnusedForalls -> warnSpec x+  Opt_WarnUnusedImports -> warnSpec x+  Opt_WarnUnusedLocalBinds -> warnSpec x+  Opt_WarnUnusedMatches -> warnSpec x+  Opt_WarnUnusedPatternBinds -> warnSpec x+  Opt_WarnUnusedTopBinds -> warnSpec x+  Opt_WarnUnusedTypePatterns -> warnSpec x+  Opt_WarnUnusedRecordWildcards -> warnSpec x+  Opt_WarnRedundantBangPatterns -> warnSpec x+  Opt_WarnRedundantRecordWildcards -> warnSpec x+  Opt_WarnRedundantStrictnessFlags -> warnSpec x+  Opt_WarnWrongDoBind -> warnSpec x+  Opt_WarnMissingPatternSynonymSignatures -> warnSpec x+  Opt_WarnMissingDerivingStrategies -> warnSpec x+  Opt_WarnSimplifiableClassConstraints -> warnSpec x+  Opt_WarnMissingHomeModules -> warnSpec x+  Opt_WarnUnrecognisedWarningFlags -> warnSpec x+  Opt_WarnStarBinder -> warnSpec x+  Opt_WarnStarIsType -> warnSpec x+  Opt_WarnSpaceAfterBang+    -> depWarnSpec x "bang patterns can no longer be written with a space"+  Opt_WarnPartialFields -> warnSpec x+  Opt_WarnPrepositiveQualifiedModule -> warnSpec x+  Opt_WarnUnusedPackages -> warnSpec x+  Opt_WarnCompatUnqualifiedImports ->+    depWarnSpec x "This warning no longer does anything; see GHC #24904"+  Opt_WarnInvalidHaddock -> warnSpec x+  Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x+  Opt_WarnOperatorWhitespace -> warnSpec x+  Opt_WarnImplicitLift -> warnSpec x+  Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x+  Opt_WarnForallIdentifier+    -> depWarnSpec x "forall is no longer a valid identifier"+  Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x+  Opt_WarnGADTMonoLocalBinds -> warnSpec x+  Opt_WarnTypeEqualityOutOfScope -> warnSpec x+  Opt_WarnTypeEqualityRequiresOperators -> warnSpec x+  Opt_WarnTermVariableCapture -> warnSpec x+  Opt_WarnMissingRoleAnnotations -> warnSpec x+  Opt_WarnImplicitRhsQuantification -> warnSpec x+  Opt_WarnIncompleteExportWarnings -> warnSpec x+  Opt_WarnIncompleteRecordSelectors -> 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+  where+    mk g = (NotDeprecated, FlagSpec (warningGroupName g) g nop AllModes)++-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@+negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+negatableFlagsDeps = [+  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]++-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@+dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+dFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,+  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks+     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),+  flagSpec "suppress-ticks"             Opt_SuppressTicks,+  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts+     (useInstead "-d" "suppress-stg-exts"),+  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,+  flagSpec "suppress-stg-reps"          Opt_SuppressStgReps,+  flagSpec "suppress-coercions"         Opt_SuppressCoercions,+  flagSpec "suppress-coercion-types"    Opt_SuppressCoercionTypes,+  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,+  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,+  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,+  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,+  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,+  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,+  flagSpec "suppress-uniques"           Opt_SuppressUniques,+  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds,+  flagSpec "suppress-core-sizes"        Opt_SuppressCoreSizes+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fFlags :: [FlagSpec GeneralFlag]+fFlags = map snd fFlagsDeps++fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+fFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,+  flagGhciSpec "break-on-error"               Opt_BreakOnError,+  flagGhciSpec "break-on-exception"           Opt_BreakOnException,+  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,+  flagSpec "call-arity"                       Opt_CallArity,+  flagSpec "exitification"                    Opt_Exitification,+  flagSpec "case-merge"                       Opt_CaseMerge,+  flagSpec "case-folding"                     Opt_CaseFolding,+  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,+  flagSpec "cmm-sink"                         Opt_CmmSink,+  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,+  flagSpec "cse"                              Opt_CSE,+  flagSpec "stg-cse"                          Opt_StgCSE,+  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,+  flagSpec "cpr-anal"                         Opt_CprAnal,+  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,+  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,+  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,+  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,+  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,+  flagSpec "diagnostics-as-json"              Opt_DiagnosticsAsJSON,+  -- With-ways needs to be reversible hence why its made via flagSpec unlike+  -- other debugging flags.+  flagSpec "dump-with-ways"                   Opt_DumpWithWays,+  flagSpec "dicts-cheap"                      Opt_DictsCheap,+  flagSpec "dicts-strict"                     Opt_DictsStrict,+  depFlagSpec "dmd-tx-dict-sel"+      Opt_DmdTxDictSel "effect is now unconditionally enabled",+  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,+  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,+  flagSpec "do-clever-arg-eta-expansion"      Opt_DoCleverArgEtaExpansion, -- See Note [Eta expansion of arguments in CorePrep]+  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,+  flagSpec "orig-thunk-info"                  Opt_OrigThunkInfo,+  flagSpec "embed-manifest"                   Opt_EmbedManifest,+  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,+  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,+  flagSpec "error-spans"                      Opt_ErrorSpans,+  flagSpec "excess-precision"                 Opt_ExcessPrecision,+  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,+  flagSpec "expose-overloaded-unfoldings"     Opt_ExposeOverloadedUnfoldings,+  flagSpec "keep-auto-rules"                  Opt_KeepAutoRules,+  flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,+  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,+  flagSpec "external-interpreter"             Opt_ExternalInterpreter,+  flagSpec "family-application-cache"         Opt_FamAppCache,+  flagSpec "float-in"                         Opt_FloatIn,+  flagSpec "force-recomp"                     Opt_ForceRecomp,+  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,+  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,+  flagSpec "full-laziness"                    Opt_FullLaziness,+  depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk+      (useInstead "-f" "full-laziness"),+  flagSpec "local-float-out"                  Opt_LocalFloatOut,+  flagSpec "local-float-out-top-level"        Opt_LocalFloatOutTopLevel,+  flagSpec "gen-manifest"                     Opt_GenManifest,+  flagSpec "ghci-history"                     Opt_GhciHistory,+  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,+  flagSpec "inter-module-far-jumps"               Opt_InterModuleFarJumps,+  flagSpec "validate-ide-info"                Opt_ValidateHie,+  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,+  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,+  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,+  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,+  flagSpec "keep-going"                       Opt_KeepGoing,+  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,+  flagSpec "late-specialise"                  Opt_LateSpecialise,+  flagSpec "liberate-case"                    Opt_LiberateCase,+  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,+  flagSpec "loopification"                    Opt_Loopification,+  flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,+  flagSpec "block-layout-weightless"          Opt_WeightlessBlocklayout,+  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,+  flagSpec "omit-yields"                      Opt_OmitYields,+  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,+  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,+  flagSpec "pre-inlining"                     Opt_SimplPreInlining,+  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,+  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,+  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,+  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,+  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,+  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,+  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,+  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,+  flagSpec "print-axiom-incomps"              Opt_PrintAxiomIncomps,+  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,+  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,+  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,+  flagSpec "print-redundant-promotion-ticks"  Opt_PrintRedundantPromotionTicks,+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,+  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,+  flagSpec "prof-count-entries"               Opt_ProfCountEntries,+  flagSpec "prof-late"                        Opt_ProfLateCcs,+  flagSpec "prof-late-overloaded"             Opt_ProfLateOverloadedCcs,+  flagSpec "prof-late-overloaded-calls"       Opt_ProfLateoverloadedCallsCCs,+  flagSpec "prof-manual"                      Opt_ProfManualCcs,+  flagSpec "prof-late-inline"                 Opt_ProfLateInlineCcs,+  flagSpec "regs-graph"                       Opt_RegsGraph,+  flagSpec "regs-iterative"                   Opt_RegsIterative,+  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules+   (useInstead "-f" "enable-rewrite-rules"),+  flagSpec "shared-implib"                    Opt_SharedImplib,+  flagSpec "spec-constr"                      Opt_SpecConstr,+  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,+  flagSpec "specialise"                       Opt_Specialise,+  flagSpec "specialize"                       Opt_Specialise,+  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,+  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,+  flagSpec "polymorphic-specialisation"       Opt_PolymorphicSpecialisation,+  flagSpec "specialise-incoherents"           Opt_SpecialiseIncoherents,+  flagSpec "inline-generics"                  Opt_InlineGenerics,+  flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,+  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,+  flagSpec "strictness"                       Opt_Strictness,+  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,+  flagSpec "unoptimized-core-for-interpreter" Opt_UnoptimizedCoreForInterpreter,+  flagSpec "version-macros"                   Opt_VersionMacros,+  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,+  flagSpec "worker-wrapper-cbv"               Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments]+  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,+  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,+  flagSpec "spec-eval"                        Opt_SpecEval,+  flagSpec "spec-eval-dictfun"                Opt_SpecEvalDictFun,+  flagSpec "cmm-control-flow"                 Opt_CmmControlFlow,+  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,+  flagSpec "hide-source-paths"                Opt_HideSourcePaths,+  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,+  flagSpec "keep-cafs"                        Opt_KeepCAFs,+  flagSpec "link-rts"                         Opt_LinkRts,+  flagSpec "byte-code-and-object-code"        Opt_ByteCodeAndObjectCode,+  flagSpec "prefer-byte-code"                 Opt_UseBytecodeRatherThanObjects,+  flagSpec "object-determinism"               Opt_ObjectDeterminism,+  flagSpec' "compact-unwind"                  Opt_CompactUnwind+      (\turn_on -> updM (\dflags -> do+        unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)+               (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")+        return dflags)),+  flagSpec "show-error-context"               Opt_ShowErrorContext,+  flagSpec "cmm-thread-sanitizer"             Opt_CmmThreadSanitizer,+  flagSpec "split-sections"                   Opt_SplitSections,+  flagSpec "break-points"                     Opt_InsertBreakpoints,+  flagSpec "distinct-constructor-tables"      Opt_DistinctConstructorTables,+  flagSpec "info-table-map"                   Opt_InfoTableMap,+  flagSpec "info-table-map-with-stack"        Opt_InfoTableMapWithStack,+  flagSpec "info-table-map-with-fallback"     Opt_InfoTableMapWithFallback+  ]+  ++ fHoleFlags++-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or+-- the valid hole fits in that message. See Note [Valid hole fits include ...]+-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with+-- @-fno-\<blah\>@+fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]+fHoleFlags = [+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,+  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits+   (useInstead "-f" "show-valid-hole-fits"),+  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,+  -- Sorting settings+  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,+  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,+  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,+  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,+  -- Output format settings+  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,+  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,+  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,+  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,+  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,+  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,+  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fLangFlags :: [FlagSpec LangExt.Extension]+fLangFlags = map snd fLangFlagsDeps++fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+fLangFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  depFlagSpecOp' "th"                           LangExt.TemplateHaskell+    checkTemplateHaskellOk+    (deprecatedForExtension "TemplateHaskell"),+  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "arrows"                         LangExt.Arrows+    (deprecatedForExtension "Arrows"),+  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude+    (deprecatedForExtension "ImplicitPrelude"),+  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns+    (deprecatedForExtension "BangPatterns"),+  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction+    (deprecatedForExtension "MonomorphismRestriction"),+  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules+    (deprecatedForExtension "ExtendedDefaultRules"),+  depFlagSpec' "implicit-params"                LangExt.ImplicitParams+    (deprecatedForExtension "ImplicitParams"),+  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances+    (deprecatedForExtension "OverlappingInstances"),+  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances+    (deprecatedForExtension "UndecidableInstances"),+  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances+    (deprecatedForExtension "IncoherentInstances")+  ]++supportedLanguages :: [String]+supportedLanguages = map (flagSpecName . snd) languageFlagsDeps++supportedLanguageOverlays :: [String]+supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps++supportedExtensions :: ArchOS -> [String]+supportedExtensions (ArchOS arch os) = concatMap toFlagSpecNamePair xFlags+  where+    toFlagSpecNamePair flg+      -- IMPORTANT! Make sure that `ghc --supported-extensions` omits+      -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the+      -- box. See also GHC #11102 and #16331 for more details about+      -- the rationale+      | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]+      | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]+      -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend+      | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName]+      | otherwise = [name, noName]+      where+        isAIX = os == OSAIX+        notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ]+        noName = "No" ++ name+        name = flagSpecName flg++supportedLanguagesAndExtensions :: ArchOS -> [String]+supportedLanguagesAndExtensions arch_os =+    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+languageFlagsDeps :: [(Deprecation, FlagSpec Language)]+languageFlagsDeps = [+  flagSpec "Haskell98"   Haskell98,+  flagSpec "Haskell2010" Haskell2010,+  flagSpec "GHC2021"     GHC2021,+  flagSpec "GHC2024"     GHC2024+  ]++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+-- They are used to place hard requirements on what GHC Haskell language+-- features can be used.+safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]+safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]+    where mkF flag = flagSpec (show flag) flag++-- | These -X<blah> flags can all be reversed with -XNo<blah>+xFlags :: [FlagSpec LangExt.Extension]+xFlags = map snd xFlagsDeps++makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)]+makeExtensionFlags ext = [ makeExtensionFlag name depr ext | (depr, name) <- extensionNames ext ]++xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+xFlagsDeps = concatMap makeExtensionFlags [minBound .. maxBound]++makeExtensionFlag :: String -> ExtensionDeprecation -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension)+makeExtensionFlag name depr ext = (deprecation depr, spec)+  where effect = extensionEffect ext+        spec = FlagSpec name ext (\f -> effect f >> act f) AllModes+        act = case depr of+                ExtensionNotDeprecated -> nop+                ExtensionDeprecatedFor xs+                  -> deprecate . deprecatedForExtensions (map extensionName xs)+                ExtensionFlagDeprecatedCond cond str+                  -> \f -> when (f == cond) (deprecate str)+                ExtensionFlagDeprecated str+                  -> const (deprecate str)++extensionEffect :: LangExt.Extension -> (TurnOnFlag -> DynP ())+extensionEffect = \case+  LangExt.TemplateHaskell+    -> checkTemplateHaskellOk+  LangExt.OverlappingInstances+    -> setOverlappingInsts+  LangExt.GeneralizedNewtypeDeriving+    -> setGenDeriving+  LangExt.IncoherentInstances+    -> setIncoherentInsts+  LangExt.DerivingVia+    -> setDeriveVia+  _ -> nop++-- | Things you get with `-dlint`.+enableDLint :: DynP ()+enableDLint = do+    mapM_ setGeneralFlag dLintFlags+    addWayDynP WayDebug+  where+    dLintFlags :: [GeneralFlag]+    dLintFlags =+        [ Opt_DoCoreLinting+        , Opt_DoStgLinting+        , Opt_DoCmmLinting+        , Opt_DoAsmLinting+        , Opt_CatchNonexhaustiveCases+        , Opt_LlvmFillUndefWithGarbage+        ]++enableGlasgowExts :: DynP ()+enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls+                       mapM_ setExtensionFlag glasgowExtsFlags++disableGlasgowExts :: DynP ()+disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls+                        mapM_ unSetExtensionFlag glasgowExtsFlags+++setWarnSafe :: Bool -> DynP ()+setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })+setWarnSafe False = return ()++setWarnUnsafe :: Bool -> DynP ()+setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })+setWarnUnsafe False = return ()++setPackageTrust :: DynP ()+setPackageTrust = do+    setGeneralFlag Opt_PackageTrust+    l <- getCurLoc+    upd $ \d -> d { pkgTrustOnLoc = l }++setGenDeriving :: TurnOnFlag -> DynP ()+setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })+setGenDeriving False = return ()++setDeriveVia :: TurnOnFlag -> DynP ()+setDeriveVia True  = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })+setDeriveVia False = return ()++setOverlappingInsts :: TurnOnFlag -> DynP ()+setOverlappingInsts False = return ()+setOverlappingInsts True = do+  l <- getCurLoc+  upd (\d -> d { overlapInstLoc = l })++setIncoherentInsts :: TurnOnFlag -> DynP ()+setIncoherentInsts False = return ()+setIncoherentInsts True = do+  l <- getCurLoc+  upd (\d -> d { incoherentOnLoc = l })++checkTemplateHaskellOk :: TurnOnFlag -> DynP ()+checkTemplateHaskellOk _turn_on+  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })++{- **********************************************************************+%*                                                                      *+                DynFlags constructors+%*                                                                      *+%********************************************************************* -}++type DynP = EwM (CmdLineP DynFlags)++upd :: (DynFlags -> DynFlags) -> DynP ()+upd f = liftEwM (do dflags <- getCmdLineState+                    putCmdLineState $! f dflags)++updM :: (DynFlags -> DynP DynFlags) -> DynP ()+updM f = do dflags <- liftEwM getCmdLineState+            dflags' <- f dflags+            liftEwM $ putCmdLineState $! dflags'++--------------- Constructor functions for OptKind -----------------+noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+noArg fn = NoArg (upd fn)++noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+noArgM fn = NoArg (updM fn)++hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+hasArg fn = HasArg (upd . fn)++sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+sepArg fn = SepArg (upd . fn)++intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffix fn = IntSuffix (\n -> upd (fn n))++intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffixM fn = IntSuffix (\n -> updM (fn n))++word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+word64Suffix fn = Word64Suffix (\n -> upd (fn n))++floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+floatSuffix fn = FloatSuffix (\n -> upd (fn n))++optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)+              -> OptKind (CmdLineP DynFlags)+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))++setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)+setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)++--------------------------+addWayDynP :: Way -> DynP ()+addWayDynP = upd . addWay'++addWay' :: Way -> DynFlags -> DynFlags+addWay' w dflags0 =+   let platform = targetPlatform dflags0+       dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }+       dflags2 = foldr setGeneralFlag' dflags1+                       (wayGeneralFlags platform w)+       dflags3 = foldr unSetGeneralFlag' dflags2+                       (wayUnsetGeneralFlags platform w)+   in dflags3++removeWayDynP :: Way -> DynP ()+removeWayDynP w = upd (\dfs -> dfs { targetWays_ = removeWay w (targetWays_ dfs) })++--------------------------+setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()+setGeneralFlag   f = upd (setGeneralFlag' f)+unSetGeneralFlag f = upd (unSetGeneralFlag' f)++setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag'   d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedGFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setGeneralFlag recursively, in case the implied flags+        --     implies further flags++unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag' d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]+   -- In general, when you un-set f, we don't un-set the things it implies.+   -- There are however some exceptions, e.g., -fno-strictness implies+   -- -fno-worker-wrapper.+   --+   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags+   --     imply further flags.++--------------------------+setWarningGroup :: WarningGroup -> DynP ()+setWarningGroup g = do+    mapM_ setWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_custom++unSetWarningGroup :: WarningGroup -> DynP ()+unSetWarningGroup g = do+    mapM_ unSetWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_custom++setWErrorWarningGroup :: WarningGroup -> DynP ()+setWErrorWarningGroup g =+  do { setWarningGroup g+     ; setFatalWarningGroup g }++setFatalWarningGroup :: WarningGroup -> DynP ()+setFatalWarningGroup g = do+    mapM_ setFatalWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_fatal_custom++unSetFatalWarningGroup :: WarningGroup -> DynP ()+unSetFatalWarningGroup g = do+    mapM_ unSetFatalWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_fatal_custom+++setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()+setWarningFlag   f = upd (\dfs -> wopt_set dfs f)+unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)++setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()+setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)+unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)++setWErrorFlag :: WarningFlag -> DynP ()+setWErrorFlag flag =+  do { setWarningFlag flag+     ; setFatalWarningFlag flag }+++setCustomWarningFlag, unSetCustomWarningFlag :: WarningCategory -> DynP ()+setCustomWarningFlag   f = upd (\dfs -> wopt_set_custom dfs f)+unSetCustomWarningFlag f = upd (\dfs -> wopt_unset_custom dfs f)++setCustomFatalWarningFlag, unSetCustomFatalWarningFlag :: WarningCategory -> DynP ()+setCustomFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal_custom dfs f)+unSetCustomFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal_custom dfs f)++setCustomWErrorFlag :: WarningCategory -> DynP ()+setCustomWErrorFlag flag =+  do { setCustomWarningFlag flag+     ; setCustomFatalWarningFlag flag }+++--------------------------+setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()+setExtensionFlag f = upd (setExtensionFlag' f)+unSetExtensionFlag f = upd (unSetExtensionFlag' f)++setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags+setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps+  where+    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)++--------------------------++alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags+alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }++--------------------------+setDumpFlag' :: DumpFlag -> DynP ()+setDumpFlag' dump_flag+  = do upd (\dfs -> dopt_set dfs dump_flag)+       when want_recomp forceRecompile+    where -- Certain dumpy-things are really interested in what's going+          -- on during recompilation checking, so in those cases we+          -- don't want to turn it off.+          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,+                                             Opt_D_dump_hi_diffs,+                                             Opt_D_no_debug_output]++forceRecompile :: DynP ()+-- Whenever we -ddump, force recompilation (by switching off the+-- recompilation checker), else you don't see the dump! However,+-- don't switch it off in --make mode, else *everything* gets+-- recompiled which probably isn't what you want+forceRecompile = do dfs <- liftEwM getCmdLineState+                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)+        where+          force_recomp dfs = isOneShot (ghcMode dfs)+++setVerbosity :: Maybe Int -> DynP ()+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })++setDebugLevel :: Maybe Int -> DynP ()+setDebugLevel mb_n =+  upd (\dfs -> exposeSyms $ dfs{ debugLevel = n })+  where+    n = mb_n `orElse` 2+    exposeSyms+      | n > 2     = setGeneralFlag' Opt_ExposeInternalSymbols+      | otherwise = id++addPkgDbRef :: PkgDbRef -> DynP ()+addPkgDbRef p = upd $ \s ->+  s { packageDBFlags = PackageDB p : packageDBFlags s }++removeUserPkgDb :: DynP ()+removeUserPkgDb = upd $ \s ->+  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }++removeGlobalPkgDb :: DynP ()+removeGlobalPkgDb = upd $ \s ->+ s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }++clearPkgDb :: DynP ()+clearPkgDb = upd $ \s ->+  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }++parsePackageFlag :: String                 -- the flag+                 -> ReadP PackageArg       -- type of argument+                 -> String                 -- string to parse+                 -> PackageFlag+parsePackageFlag flag arg_parse str+ = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)+  where doc = flag ++ " " ++ str+        parse = do+            pkg_arg <- tok arg_parse+            let mk_expose = ExposePackage doc pkg_arg+            ( do _ <- tok $ string "with"+                 fmap (mk_expose . ModRenaming True) parseRns+             <++ fmap (mk_expose . ModRenaming False) parseRns+             <++ return (mk_expose (ModRenaming True [])))+        parseRns = do _ <- tok $ R.char '('+                      rns <- tok $ sepBy parseItem (tok $ R.char ',')+                      _ <- tok $ R.char ')'+                      return rns+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (orig, new)+              ++++             return (orig, orig))+        tok m = m >>= \x -> skipSpaces >> return x++exposePackage, exposePackageId, hidePackage,+        exposePluginPackage, exposePluginPackageId,+        ignorePackage,+        trustPackage, distrustPackage :: String -> DynP ()+exposePackage p = upd (exposePackage' p)+exposePackageId p =+  upd (\s -> s{ packageFlags =+    parsePackageFlag "-package-id" parseUnitArg p : packageFlags s })+exposePluginPackage p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })+exposePluginPackageId p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s })+hidePackage p =+  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })+ignorePackage p =+  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })++trustPackage p = exposePackage p >> -- both trust and distrust also expose a package+  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })+distrustPackage p = exposePackage p >>+  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })++exposePackage' :: String -> DynFlags -> DynFlags+exposePackage' p dflags+    = dflags { packageFlags =+            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }++parsePackageArg :: ReadP PackageArg+parsePackageArg =+    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))++parseUnitArg :: ReadP PackageArg+parseUnitArg =+    fmap UnitIdArg parseUnit++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 }++{-+Note [Filepaths and Multiple Home Units]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is common to assume that a package is compiled in the directory where its+cabal file resides. Thus, all paths used in the compiler are assumed to be relative+to this directory. When there are multiple home units the compiler is often+not operating in the standard directory and instead where the cabal.project+file is located. In this case the `-working-dir` option can be passed which specifies+the path from the current directory to the directory the unit assumes to be it's root,+normally the directory which contains the cabal file.++When the flag is passed, any relative paths used by the compiler are offset+by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and+the location of input files.++-}++augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath+augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp+augmentByWorkingDirectory _ fp = fp++setPackageName :: String -> DynFlags -> DynFlags+setPackageName p d = d { thisPackageName =  Just p }++addHiddenModule :: String -> DynP ()+addHiddenModule p =+  upd (\s -> s{ hiddenModules  = Set.insert (mkModuleName p) (hiddenModules s) })++addReexportedModule :: String -> DynP ()+addReexportedModule p =+  upd (\s -> s{ reexportedModules  = (parseReexportedModule p) : (reexportedModules s) })++parseReexportedModule :: String                 -- string to parse+                      -> ReexportedModule+parseReexportedModule str+ = case filter ((=="").snd) (readP_to_S parseItem str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse reexported module flag: " ++ str)+  where+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (ReexportedModule orig new))+              ++++             return (ReexportedModule orig orig)++        tok m = m >>= \x -> skipSpaces >> return x+++-- If we're linking a binary, then only backends that produce object+-- code are allowed (requests for other target types are ignored).+setBackend :: Backend -> DynP ()+setBackend l = upd $ \ dfs ->+  if ghcLink dfs /= LinkBinary || backendWritesFiles l+  then dfs{ backend = l }+  else dfs++-- Changes the target only if we're compiling object code.  This is+-- used by -fasm and -fllvm, which switch from one to the other, but+-- not from bytecode to object-code.  The idea is that -fasm/-fllvm+-- can be safely used in an OPTIONS_GHC pragma.+setObjBackend :: Backend -> DynP ()+setObjBackend l = updM set+  where+   set dflags+     | backendWritesFiles (backend dflags)+       = return $ dflags { backend = l }+     | otherwise = return dflags++setOptLevel :: Int -> DynFlags -> DynP DynFlags+setOptLevel n dflags = return (updOptLevel n dflags)++setCallerCcFilters :: String -> DynP ()+setCallerCcFilters arg =+  case parseCallerCcFilter arg of+    Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d }+    Left err -> addErr err++setMainIs :: String -> DynP ()+setMainIs arg = parse parse_main_f arg+  where+    parse callback str = case unP parseIdentifier (p_state str) of+      PFailed _      -> addErr $ "Can't parse -main-is \"" ++ arg ++ "\" as an identifier or module."+      POk _ (L _ re) -> callback re++    -- dummy parser state.+    p_state str = initParserState+              (mkParserOpts mempty emptyDiagOpts False False False True)+              (stringToStringBuffer str)+              (mkRealSrcLoc (mkFastString []) 1 1)++    parse_main_f (Unqual occ)+      | isVarOcc occ = upd $ \d -> d { mainFunIs = main_f occ }+    parse_main_f (Qual (ModuleName mod) occ)+      | isVarOcc occ = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod+                                     , mainFunIs = main_f occ }+    -- append dummy "function" to parse A.B as the module A.B+    -- and not the Data constructor B from the module A+    parse_main_f _ = parse parse_mod (arg ++ ".main")++    main_f = Just . occNameString++    parse_mod (Qual (ModuleName mod) _) = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod }+    -- we appended ".m" and any parse error was caught. We are Qual or something went very wrong+    parse_mod _ = error "unreachable"++addLdInputs :: Option -> DynFlags -> DynFlags+addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}++-- -----------------------------------------------------------------------------+-- Load dynflags from environment files.++setFlagsFromEnvFile :: FilePath -> String -> DynP ()+setFlagsFromEnvFile envfile content = do+  setGeneralFlag Opt_HideAllPackages+  parseEnvFile envfile content++parseEnvFile :: FilePath -> String -> DynP ()+parseEnvFile envfile = mapM_ parseEntry . lines+  where+    parseEntry str = case words str of+      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))+        -- relative package dbs are interpreted relative to the env file+        where envdir = takeDirectory envfile+              db     = drop 11 str+      ["clear-package-db"]  -> clearPkgDb+      ["hide-package", pkg]  -> hidePackage pkg+      ["global-package-db"] -> addPkgDbRef GlobalPkgDb+      ["user-package-db"]   -> addPkgDbRef UserPkgDb+      ["package-id", pkgid] -> exposePackageId pkgid+      (('-':'-':_):_)       -> return () -- comments+      -- and the original syntax introduced in 7.10:+      [pkgid]               -> exposePackageId pkgid+      []                    -> return ()+      _                     -> throwGhcException $ CmdLineError $+                                    "Can't parse environment file entry: "+                                 ++ envfile ++ ": " ++ str+++-----------------------------------------------------------------------------+-- Paths & Libraries++addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()++-- -i on its own deletes the import paths+addImportPath "" = upd (\s -> s{importPaths = []})+addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})++addLibraryPath p =+  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})++addIncludePath p =+  upd (\s -> s{includePaths =+                  addGlobalInclude (includePaths s) (splitPathList p)})++addFrameworkPath p =+  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})++#if !defined(mingw32_HOST_OS)+split_marker :: Char+split_marker = ':'   -- not configurable (ToDo)+#endif++splitPathList :: String -> [String]+splitPathList s = filter notNull (splitUp s)+                -- empty paths are ignored: there might be a trailing+                -- ':' in the initial list, for example.  Empty paths can+                -- cause confusion when they are translated into -I options+                -- for passing to gcc.+  where+#if !defined(mingw32_HOST_OS)+    splitUp xs = split split_marker xs+#else+     -- Windows: 'hybrid' support for DOS-style paths in directory lists.+     --+     -- That is, if "foo:bar:baz" is used, this interpreted as+     -- consisting of three entries, 'foo', 'bar', 'baz'.+     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted+     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"+     --+     -- Notice that no attempt is made to fully replace the 'standard'+     -- split marker ':' with the Windows / DOS one, ';'. The reason being+     -- that this will cause too much breakage for users & ':' will+     -- work fine even with DOS paths, if you're not insisting on being silly.+     -- So, use either.+    splitUp []             = []+    splitUp (x:':':div:xs) | div `elem` dir_markers+                           = ((x:':':div:p): splitUp rs)+                           where+                              (p,rs) = findNextPath xs+          -- we used to check for existence of the path here, but that+          -- required the IO monad to be threaded through the command-line+          -- parser which is quite inconvenient.  The+    splitUp xs = cons p (splitUp rs)+               where+                 (p,rs) = findNextPath xs++                 cons "" xs = xs+                 cons x  xs = x:xs++    -- will be called either when we've consumed nought or the+    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of+    -- finding the next split marker.+    findNextPath xs =+        case break (`elem` split_markers) xs of+           (p, _:ds) -> (p, ds)+           (p, xs)   -> (p, xs)++    split_markers :: [Char]+    split_markers = [':', ';']++    dir_markers :: [Char]+    dir_markers = ['/', '\\']+#endif++-- -----------------------------------------------------------------------------+-- tmpDir, where we store temporary files.++setTmpDir :: FilePath -> DynFlags -> DynFlags+setTmpDir dir d = d { tmpDir = TempDir (normalise dir) }+  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't+  -- seem necessary now --SDM 7/2/2008++-----------------------------------------------------------------------------+-- RTS opts++setRtsOpts :: String -> DynP ()+setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}++setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()+setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}++-----------------------------------------------------------------------------+-- Hpc stuff++setOptHpcDir :: String -> DynP ()+setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}++-----------------------------------------------------------------------------+-- Via-C compilation stuff++-- There are some options that we need to pass to gcc when compiling+-- Haskell code via C, but are only supported by recent versions of+-- gcc.  The configure script decides which of these options we need,+-- and puts them in the "settings" file in $topdir. The advantage of+-- having these in a separate file is that the file can be created at+-- install-time depending on the available gcc version, and even+-- re-generated later if gcc is upgraded.+--+-- The options below are not dependent on the version of gcc, only the+-- platform.++picCCOpts :: DynFlags -> [String]+picCCOpts dflags =+      case platformOS (targetPlatform dflags) of+      OSDarwin+          -- Apple prefers to do things the other way round.+          -- PIC is on by default.+          -- -mdynamic-no-pic:+          --     Turn off PIC code generation.+          -- -fno-common:+          --     Don't generate "common" symbols - these are unwanted+          --     in dynamic libraries.++       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]+       | otherwise           -> ["-mdynamic-no-pic"]+      OSMinGW32 -- no -fPIC for Windows+       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]+       | otherwise           -> []+      _+      -- we need -fPIC for C files when we are compiling with -dynamic,+      -- otherwise things like stub.c files don't get compiled+      -- correctly.  They need to reference data in the Haskell+      -- objects, but can't without -fPIC.  See+      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code+       | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn ->+          ["-fPIC", "-U__PIC__", "-D__PIC__"] +++          -- Clang defaults to -fvisibility=hidden for wasm targets,+          -- but we need these compile-time flags to generate PIC+          -- objects that can be properly linked by wasm-ld using+          -- --export-dynamic; without these flags we would need+          -- -Wl,--export-all at .so link-time which will export+          -- internal symbols as well, and that severely pollutes the+          -- global symbol namespace.+          (if platformArch (targetPlatform dflags) == ArchWasm32+            then [ "-fvisibility=default", "-fvisibility-inlines-hidden" ]+            else [])+      -- gcc may be configured to have PIC on by default, let's be+      -- explicit here, see #15847+       | otherwise -> ["-fno-PIC"]++pieCCLDOpts :: DynFlags -> [String]+pieCCLDOpts dflags+      | gopt Opt_PICExecutable dflags       = ["-pie"]+        -- See Note [No PIE when linking]+      | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]+      | otherwise                           = []+++{-+Note [No PIE when linking]+~~~~~~~~~~~~~~~~~~~~~~~~~~+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by+default in their gcc builds. This is incompatible with -r as it implies that we+are producing an executable. Consequently, we must manually pass -no-pie to gcc+when joining object files or linking dynamic libraries. Unless, of course, the+user has explicitly requested a PIE executable with -pie. See #12759.+-}++picPOpts :: DynFlags -> [String]+picPOpts dflags+ | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]+ | otherwise           = []++-- -----------------------------------------------------------------------------+-- Compiler Info++compilerInfo :: DynFlags -> [(String, String)]+compilerInfo dflags+    = -- We always make "Project name" be first to keep parsing in+      -- other languages simple, i.e. when looking for other fields,+      -- you don't have to worry whether there is a leading '[' or not+      ("Project name",                 cProjectName)+      -- Next come the settings, so anything else can be overridden+      -- in the settings file (as "lookup" uses the first match for the+      -- key)+    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))+          (rawSettings dflags)+   ++ [("Project version",             projectVersion dflags),+       ("Project Git commit id",       cProjectGitCommitId),+       ("Project Version Int",         cProjectVersionInt),+       ("Project Patch Level",         cProjectPatchLevel),+       ("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),+       ("target has RTS linker",       showBool $ platformHasRTSLinker platform),+       ("Target default backend",      show     $ platformDefaultBackend platform),+       -- Whether or not we support @-dynamic-too@+       ("Support dynamic-too",         showBool $ not isWindows),+       -- Whether or not we support the @-j@ flag with @--make@.+       ("Support parallel --make",     "YES"),+       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in+       -- installed package info.+       ("Support reexported-modules",  "YES"),+       -- Whether or not we support extended @-package foo (Foo)@ syntax.+       ("Support thinning and renaming package flags", "YES"),+       -- Whether or not we support Backpack.+       ("Support Backpack", "YES"),+       -- If true, we require that the 'id' field in installed package info+       -- match what is passed to the @-this-unit-id@ flag for modules+       -- built in it+       ("Requires unified installed package IDs", "YES"),+       -- Whether or not we support the @-this-package-key@ flag.  Prefer+       -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@+       -- flag has been removed, otherwise it breaks Cabal...+       ("Uses package keys",           "YES"),+       -- Whether or not we support the @-this-unit-id@ flag+       ("Uses unit IDs",               "YES"),+       -- Whether or not GHC was compiled using -dynamic+       ("GHC Dynamic",                 showBool hostIsDynamic),+       -- Whether or not GHC was compiled using -prof+       ("GHC Profiled",                showBool hostIsProfiled),+       ("Debug on",                    showBool debugIsOn),+       ("LibDir",                      topDir dflags),+       -- This is always an absolute path, unlike "Relative Global Package DB" which is+       -- in the settings file.+       ("Global Package DB",           globalPackageDatabasePath dflags)+      ]+  where+    showBool True  = "YES"+    showBool False = "NO"+    platform  = targetPlatform dflags+    isWindows = platformOS platform == OSMinGW32+    useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags+    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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a number of number of DynFlags configurations which either+do not make sense or lead to unimplemented or buggy codepaths in the+compiler. makeDynFlagsConsistent is responsible for verifying the validity+of a set of DynFlags, fixing any issues, and reporting them back to the+caller.++GHCi and -O+---------------++When using optimization, the compiler can introduce several things+(such as unboxed tuples) into the intermediate code, which GHCi later+chokes on since the bytecode interpreter can't handle this (and while+this is arguably a bug these aren't handled, there are no plans to fix+it.)++While the driver pipeline always checks for this particular erroneous+combination when parsing flags, we also need to check when we update+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, 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!+makeDynFlagsConsistent dflags+ -- Disable -dynamic-too on Windows (#8228, #7134, #5987)+ | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn    = "-dynamic-too is not supported on Windows"+      in loop dflags' warn+ -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise+ -- you get two dynamic object files (.o and .dyn_o). (#20436)+ | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn = "-dynamic-too is ignored when using -dynamic"+      in loop dflags' warn++ | gopt Opt_SplitSections dflags+ , platformHasSubsectionsViaSymbols (targetPlatform dflags)+    = let dflags' = gopt_unset dflags Opt_SplitSections+          warn = "-fsplit-sections is not useful on this platform " +++                 "since it uses subsections-via-symbols. Ignoring."+      in loop dflags' warn++   -- Via-C backend only supports unregisterised ABI. Switch to a backend+   -- supporting it if possible.+ | backendUnregisterisedAbiOnly (backend dflags) &&+   not (platformUnregisterised (targetPlatform dflags))+    = let b = platformDefaultBackend (targetPlatform dflags)+      in if backendSwappableWithViaC b then+           let dflags' = dflags { backend = b }+               warn = "Target platform doesn't use unregisterised ABI, so using " +++                      backendDescription b ++ " rather than " +++                      backendDescription (backend dflags)+           in loop dflags' warn+         else+           pgmError (backendDescription (backend dflags) +++                     " supports only unregisterised ABI but target platform doesn't use it.")++ | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags))+    = let dflags' = gopt_unset dflags Opt_Hpc+          warn = "Hpc can't be used with " ++ backendDescription (backend dflags) +++                 ". Ignoring -fhpc."+      in loop dflags' warn++ | backendSwappableWithViaC (backend dflags) &&+   platformUnregisterised (targetPlatform dflags)+    = loop (dflags { backend = viaCBackend })+           "Target platform uses unregisterised ABI, so compiling via C"++ | backendNeedsPlatformNcgSupport (backend dflags) &&+   not (platformNcgSupported $ targetPlatform dflags)+      = let dflags' = dflags { backend = llvmBackend }+            warn = "Native code generator doesn't support target platform, so using LLVM"+        in loop dflags' warn++ | not (osElfTarget os) && gopt Opt_PIE dflags+    = loop (gopt_unset dflags Opt_PIE)+           "Position-independent only supported on ELF platforms"+ | os == OSDarwin &&+   arch == ArchX86_64 &&+   not (gopt Opt_PIC dflags)+    = loop (gopt_set dflags Opt_PIC)+           "Enabling -fPIC as it is always on for this platform"++ | backendForcesOptimization0 (backend dflags)+ , gopt Opt_UnoptimizedCoreForInterpreter dflags+ , let (dflags', changed) = updOptLevelChanged 0 dflags+ , changed+    = loop dflags' $+      "Ignoring optimization flags since they are experimental for the " +++      backendDescription (backend dflags) +++      ". Pass -fno-unoptimized-core-for-interpreter to enable this feature."++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , backendWritesFiles (backend dflags)+ , ways dflags `hasNotWay` WayProf+    = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}+         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"++ | gopt Opt_ByteCode dflags || gopt Opt_ByteCodeAndObjectCode dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , ways dflags `hasNotWay` WayProf+    = loop (gopt_set dflags Opt_ExternalInterpreter)+         "Enabling external interpreter, because GHC is profiled and bytecode is being used for TH"++ | LinkMergedObj <- ghcLink dflags+ , Nothing <- outputFile dflags+    = pgmError "--output must be specified when using --merge-objs"++ | 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, 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+++setUnsafeGlobalDynFlags :: DynFlags -> IO ()+setUnsafeGlobalDynFlags dflags = do+   writeIORef v_unsafeHasPprDebug (hasPprDebug dflags)+   writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags)+   writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags)+++-- -----------------------------------------------------------------------------++-- | Indicate if cost-centre profiling is enabled+sccProfilingEnabled :: DynFlags -> Bool+sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)++-- | Indicate whether we need to generate source notes+needSourceNotes :: DynFlags -> Bool+needSourceNotes dflags = debugLevel dflags > 0+                       || gopt Opt_InfoTableMap dflags++                       -- Source ticks are used to approximate the location of+                       -- overloaded call cost centers+                       || gopt Opt_ProfLateoverloadedCallsCCs dflags++-- -----------------------------------------------------------------------------+-- Linker/compiler information++-- | Should we use `-XLinker -rpath` when linking or not?+-- See Note [-fno-use-rpaths]+useXLinkerRPath :: DynFlags -> OS -> Bool+-- wasm shared libs don't have RPATH at all and wasm-ld doesn't accept+-- any RPATH-related flags+useXLinkerRPath dflags _ | ArchWasm32 <- platformArch $ targetPlatform dflags = False+useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS]+useXLinkerRPath dflags _ = gopt Opt_RPath dflags++{-+Note [-fno-use-rpaths]+~~~~~~~~~~~~~~~~~~~~~~++First read, Note [Dynamic linking on macOS] to understand why on darwin we never+use `-XLinker -rpath`.++The specification of `Opt_RPath` is as follows:++The default case `-fuse-rpaths`:+* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath+  afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin+  as things stand but it wasn't documented in the user guide before this patch how+  `-fuse-rpaths` should behave and the fact it was always disabled on darwin.+* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable,+  this is the normal way you should set the rpath.++The case of `-fno-use-rpaths`+* Never inject anything into the rpath.++When this was first implemented, `Opt_RPath` was disabled on darwin, but+the rpath was still always augmented by `runInjectRPaths`, and there was no way to+stop this. This was problematic because you couldn't build an executable in CI+with a clean rpath.++-}++-- -----------------------------------------------------------------------------+-- RTS hooks++-- Convert sizes like "3.5M" into integers+decodeSize :: String -> Integer+decodeSize str+  | c == ""      = truncate n+  | c == "K" || c == "k" = truncate (n * 1000)+  | c == "M" || c == "m" = truncate (n * 1000 * 1000)+  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)+  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))+  where (m, c) = span pred str+        n      = readRational m+        pred c = isDigit c || c == '.'++foreign import ccall unsafe "ghc_lib_parser_setHeapSize"       setHeapSize       :: Int -> IO ()+foreign import ccall unsafe "ghc_lib_parser_enableTimingStats" enableTimingStats :: IO ()++outputFile :: DynFlags -> Maybe String+outputFile dflags+   | dynamicNow dflags = dynOutputFile_ dflags+   | otherwise         = outputFile_    dflags++objectSuf :: DynFlags -> String+objectSuf dflags+   | dynamicNow dflags = dynObjectSuf_ dflags+   | otherwise         = objectSuf_    dflags  -- | Pretty-print the difference between 2 DynFlags. --
compiler/GHC/Hs.hs view
@@ -19,6 +19,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data+{-# LANGUAGE DataKinds #-}  module GHC.Hs (         module Language.Haskell.Syntax,@@ -60,7 +61,7 @@ import GHC.Utils.Outputable import GHC.Types.Fixity         ( Fixity ) import GHC.Types.SrcLoc-import GHC.Unit.Module.Warnings ( WarningTxt )+import GHC.Unit.Module.Warnings  -- libraries: import Data.Data hiding ( Fixity )@@ -69,24 +70,13 @@ data XModulePs   = XModulePs {       hsmodAnn :: EpAnn AnnsModule,-      hsmodLayout :: LayoutInfo GhcPs,+      hsmodLayout :: EpLayout,         -- ^ Layout info for the module.-        -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.-      hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)),+        -- For incomplete modules (e.g. the output of parseHeader), it is EpNoLayout.+      hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs),         -- ^ reason\/explanation for warning/deprecation of this module-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'-        --                                   ,'GHC.Parser.Annotation.AnnClose'-        ----        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation       hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)         -- ^ Haddock module info and description, unparsed-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'-        --                                   ,'GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    }    deriving Data @@ -95,15 +85,21 @@ type instance XCModule GhcTc = DataConCantHappen type instance XXModule p = DataConCantHappen -type instance Anno ModuleName = SrcSpanAnnA- deriving instance Data (HsModule GhcPs)  data AnnsModule   = AnnsModule {-    am_main :: [AddEpAnn],-    am_decls :: AnnList+    am_sig :: EpToken "signature",+    am_mod :: EpToken "module",+    am_where :: EpToken "where",+    am_decls :: [TrailingAnn],                 -- ^ Semis before the start of top decls+    am_cs :: [LEpaComment],                    -- ^ Comments before start of top decl,+                                               --   used in exact printing only+    am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- ^ End of file and end of prior token     } deriving (Data, Eq)++instance NoAnn AnnsModule where+  noAnn = AnnsModule NoEpTok NoEpTok NoEpTok [] [] Nothing  instance Outputable (HsModule GhcPs) where     ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc }
+ compiler/GHC/Hs/Basic.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Fixity+module GHC.Hs.Basic+   ( module Language.Haskell.Syntax.Basic+   ) where++import GHC.Prelude++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data ()++import Language.Haskell.Syntax.Basic++instance Outputable LexicalFixity where+  ppr Prefix = text "Prefix"+  ppr Infix  = text "Infix"++instance Outputable FixityDirection where+    ppr InfixL = text "infixl"+    ppr InfixR = text "infixr"+    ppr InfixN = text "infix"++instance Outputable Fixity where+    ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]+++instance Binary Fixity where+    put_ bh (Fixity aa ab) = do+            put_ bh aa+            put_ bh ab+    get bh = do+          aa <- get bh+          ab <- get bh+          return (Fixity aa ab)++------------------------++instance Binary FixityDirection where+    put_ bh InfixL =+            putByte bh 0+    put_ bh InfixR =+            putByte bh 1+    put_ bh InfixN =+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> return InfixL+              1 -> return InfixR+              _ -> return InfixN
compiler/GHC/Hs/Binds.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- used to pass the phase to ppr_mult_ann since MultAnn is a type family {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -24,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@@ -45,13 +50,11 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var-import GHC.Data.Bag-import GHC.Data.BooleanFormula (LBooleanFormula)-import GHC.Types.Name.Reader import GHC.Types.Name  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc ((<||>))  import Data.Function import Data.List (sortBy)@@ -70,8 +73,8 @@ -- the ...LR datatypes are parameterized by two id types, -- one for the left and one for the right. -type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = EpAnn AnnList-type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = EpAnn AnnList+type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where"))+type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen @@ -84,7 +87,7 @@       [(RecFlag, LHsBinds idL)]       [LSig GhcRn] -type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey+type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag type instance XXValBindsLR (GhcPass pL) pR             = NHsValBindsLR (GhcPass pL) @@ -113,26 +116,52 @@ -- type         Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. -type instance XPatBind    GhcPs (GhcPass pR) = EpAnn [AddEpAnn]+type instance XPatBind    GhcPs (GhcPass pR) = NoExtField type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] type instance XPatBind    GhcTc (GhcPass pR) =     ( Type                  -- Type of the GRHSs     , ( [CoreTickish]       -- Ticks to put on the rhs, if any       , [[CoreTickish]] ) ) -- and ticks to put on the bound variables. -type instance XVarBind    (GhcPass pL) (GhcPass pR) = NoExtField+type instance XVarBind (GhcPass pL) (GhcPass pR) = XVarBindGhc pL pR+type family XVarBindGhc pL pR where+  XVarBindGhc 'Typechecked 'Typechecked = NoExtField+  XVarBindGhc _     _                   = DataConCantHappen+ type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField  type instance XXHsBindsLR GhcPs pR = DataConCantHappen type instance XXHsBindsLR GhcRn pR = DataConCantHappen type instance XXHsBindsLR GhcTc pR = AbsBinds -type instance XPSB         (GhcPass idL) GhcPs = EpAnn [AddEpAnn]+type instance XPSB         (GhcPass idL) GhcPs = AnnPSB type instance XPSB         (GhcPass idL) GhcRn = NameSet -- Post renaming, FVs. See Note [Bind free vars] type instance XPSB         (GhcPass idL) GhcTc = NameSet  type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen +data AnnPSB+  = AnnPSB {+      ap_pattern :: EpToken "pattern",+      ap_openc   :: Maybe (EpToken "{"),+      ap_closec  :: Maybe (EpToken "}"),+      ap_larrow  :: Maybe (EpUniToken "<-" "←"),+      ap_equal   :: Maybe (EpToken "=")+    } deriving Data++instance NoAnn AnnPSB where+  noAnn = AnnPSB noAnn noAnn noAnn noAnn noAnn++setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc+setTcMultAnn mult (HsLinearAnn _)   = HsLinearAnn mult+setTcMultAnn mult (HsExplicitMult _ p) = HsExplicitMult mult p+setTcMultAnn mult (HsUnannotated _) = HsUnannotated mult++getTcMultAnn :: HsMultAnn GhcTc -> Mult+getTcMultAnn (HsLinearAnn mult)   = mult+getTcMultAnn (HsExplicitMult mult _) = mult+getTcMultAnn (HsUnannotated mult) = mult+ -- ---------------------------------------------------------------------  -- | Typechecked, generalised bindings, used in the output to the type checker.@@ -427,7 +456,7 @@     = getPprDebug $ \case         -- Print with sccs showing         True  -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)-        False -> pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)+        False -> pprDeclList (pprLHsBindsForUser (concat (map snd sccs)) sigs)    where      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds      pp_rec Recursive    = text "rec"@@ -437,7 +466,7 @@             => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds   | isEmptyLHsBinds binds = empty-  | otherwise = pprDeclList (map ppr (bagToList binds))+  | otherwise = pprDeclList (map ppr binds)  pprLHsBindsForUser :: (OutputableBndrId idL,                        OutputableBndrId idR,@@ -455,7 +484,7 @@      decls :: [(SrcSpan, SDoc)]     decls = [(locA loc, ppr sig)  | L loc sig <- sigs] ++-            [(locA loc, ppr bind) | L loc bind <- bagToList binds]+            [(locA loc, ppr bind) | L loc bind <- binds]      sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls @@ -483,20 +512,20 @@ isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs  emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)-emptyValBindsIn  = ValBinds NoAnnSortKey emptyBag []+emptyValBindsIn  = ValBinds NoAnnSortKey [] [] emptyValBindsOut = XValBindsLR (NValBinds [] [])  emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR-emptyLHsBinds = emptyBag+emptyLHsBinds = []  isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool-isEmptyLHsBinds = isEmptyBag+isEmptyLHsBinds = null  ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)                -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)-  = ValBinds NoAnnSortKey (ds1 `unionBags` ds2) (sigs1 ++ sigs2)+  = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))                (XValBindsLR (NValBinds ds2 sigs2))   = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))@@ -511,8 +540,9 @@                 (OutputableBndrId idL, OutputableBndrId idR)              => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })-  = pprPatBind pat grhss+ppr_monobind (PatBind { pat_lhs = pat, pat_mult = mult_ann, pat_rhs = grhss })+  = pprHsMultAnn @idL mult_ann+    <+> pprPatBind pat grhss ppr_monobind (VarBind { var_id = var, var_rhs = rhs })   = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun,@@ -540,10 +570,6 @@  ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (XHsBindsLR b) = case ghcPass @idL of-#if __GLASGOW_HASKELL__ <= 900-  GhcPs -> dataConCantHappen b-  GhcRn -> dataConCantHappen b-#endif   GhcTc -> ppr_absbinds b     where       ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars@@ -586,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@@ -601,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@@ -618,10 +644,9 @@          then pp_when_debug          else pp_no_debug -instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where+instance Outputable (XRecGhc (IdGhcP p)) => Outputable (RecordPatSynField (GhcPass p)) where     ppr (RecordPatSynField { recordPatSynField = v }) = ppr v - {- ************************************************************************ *                                                                      *@@ -645,7 +670,7 @@ isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds  -- EPA annotations in GhcPs, dictionary Id in GhcTc-type instance XCIPBind GhcPs = EpAnn [AddEpAnn]+type instance XCIPBind GhcPs = EpToken "=" type instance XCIPBind GhcRn = NoExtField type instance XCIPBind GhcTc = Id type instance XXIPBind    (GhcPass p) = DataConCantHappen@@ -670,24 +695,95 @@ ************************************************************************ -} -type instance XTypeSig          (GhcPass p) = EpAnn AnnSig-type instance XPatSynSig        (GhcPass p) = EpAnn AnnSig-type instance XClassOpSig       (GhcPass p) = EpAnn AnnSig-type instance XFixSig           (GhcPass p) = EpAnn [AddEpAnn]-type instance XInlineSig        (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecSig          (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecInstSig      (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-type instance XMinimalSig       (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-type instance XSCCFunSig        (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-    -- SourceText: Note [Pragma source text] in GHC.Types.SourceText+type instance XTypeSig          (GhcPass p) = AnnSig+type instance XPatSynSig        (GhcPass p) = AnnSig+type instance XClassOpSig       (GhcPass p) = AnnSig+type instance XFixSig           (GhcPass p) = ((EpaLocation, Maybe EpaLocation), SourceText)+type instance XInlineSig        (GhcPass p) = (EpaLocation, EpToken "#-}", ActivationAnn)+type instance XSpecSig          (GhcPass p) = AnnSpecSig+type instance XSpecInstSig      (GhcPass p) = ((EpaLocation, EpToken "instance", EpToken "#-}"), SourceText)+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 type instance XXSig             GhcTc = IdSig -type instance XFixitySig  (GhcPass p) = NoExtField+type instance XFixitySig  GhcPs = NamespaceSpecifier+type instance XFixitySig  GhcRn = NamespaceSpecifier+type instance XFixitySig  GhcTc = NoExtField type instance XXFixitySig (GhcPass p) = DataConCantHappen +data AnnSpecSig+  = AnnSpecSig {+      ass_open   :: EpaLocation,+      ass_close  :: EpToken "#-}",+      ass_dcolon :: Maybe TokDcolon, -- Only for old SpecSig, remove when it goes+      ass_act    :: ActivationAnn+    } deriving Data++instance NoAnn AnnSpecSig where+  noAnn = AnnSpecSig noAnn noAnn noAnn noAnn++data ActivationAnn+  = ActivationAnn {+      aa_openc  :: EpToken "[",+      aa_closec :: EpToken "]",+      aa_tilde  :: Maybe (EpToken "~"),+      aa_val    :: Maybe EpaLocation+    } deriving (Data, Eq)++instance NoAnn ActivationAnn where+  noAnn = ActivationAnn noAnn noAnn noAnn noAnn+++-- | Optional namespace specifier for fixity signatures,+--  WARNINIG and DEPRECATED pragmas.+--+-- Examples:+--+--   {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-}+--                            -- ↑ DataNamespaceSpecifier+--+--   {-# DEPRECATED type D "This type was deprecated" #-}+--                -- ↑ TypeNamespaceSpecifier+--+--   infixr 6 data $+--          -- ↑ DataNamespaceSpecifier+data NamespaceSpecifier+  = NoNamespaceSpecifier+  | TypeNamespaceSpecifier (EpToken "type")+  | DataNamespaceSpecifier (EpToken "data")+  deriving (Eq, Data)++-- | Check if namespace specifiers overlap, i.e. if they are equal or+-- if at least one of them doesn't specify a namespace+overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool+overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True+overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True+overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True+overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True+overlappingNamespaceSpecifiers _ _ = False++-- | Check if namespace is covered by a namespace specifier:+--     * NoNamespaceSpecifier covers both namespaces+--     * TypeNamespaceSpecifier covers the type namespace only+--     * DataNamespaceSpecifier covers the data namespace only+coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool+coveredByNamespaceSpecifier NoNamespaceSpecifier = const True+coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace+coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace+instance Outputable NamespaceSpecifier where+  ppr NoNamespaceSpecifier = empty+  ppr TypeNamespaceSpecifier{} = text "type"+  ppr DataNamespaceSpecifier{} = text "data"+ -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record the desired Id -- itself, replete with its name, type and IdDetails. Otherwise it's@@ -697,33 +793,58 @@  data AnnSig   = AnnSig {-      asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option-      asRest   :: [AddEpAnn]+      asDcolon  :: EpUniToken "::" "∷",+      asPattern :: Maybe (EpToken "pattern"),+      asDefault :: Maybe (EpToken "default")       } deriving Data +instance NoAnn AnnSig where+  noAnn = AnnSig noAnn noAnn noAnn  -- | 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 [] @@ -745,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 -> text src+        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)@@ -773,7 +909,7 @@           GhcTc -> ppr fn ppr_sig (CompleteMatchSig (_, src) cs mty)   = pragSrcBrackets src "{-# COMPLETE"-      ((hsep (punctuate comma (map ppr_n (unLoc cs))))+      ((hsep (punctuate comma (map ppr_n cs)))         <+> opt_sig)   where     opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty@@ -792,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@@ -818,8 +955,13 @@  instance OutputableBndrId p        => Outputable (FixitySig (GhcPass p)) where-  ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]+  ppr (FixitySig ns_spec names fixity) = sep [ppr fixity, ppr_ns_spec, pprops]     where+      ppr_ns_spec =+        case ghcPass @p of+          GhcPs -> ppr ns_spec+          GhcRn -> ppr ns_spec+          GhcTc -> empty       pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)  pragBrackets :: SDoc -> SDoc@@ -828,7 +970,7 @@ -- | Using SourceText in case the pragma was spelled differently or used mixed -- case pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc-pragSrcBrackets (SourceText src) _   doc = text src <+> doc <+> text "#-}"+pragSrcBrackets (SourceText src) _   doc = ftext src <+> doc <+> text "#-}" pragSrcBrackets NoSourceText     alt doc = text alt <+> doc <+> text "#-}"  pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc@@ -849,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)+ {- ************************************************************************ *                                                                      *@@ -865,15 +1054,8 @@ type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA---- For CompleteMatchSig-type instance Anno [LocatedN RdrName] = SrcSpan-type instance Anno [LocatedN Name]    = SrcSpan-type instance Anno [LocatedN Id]      = SrcSpan+type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO  type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = SrcAnn NoEpAnns-type instance Anno (LocatedN RdrName) = SrcSpan-type instance Anno (LocatedN Name) = SrcSpan-type instance Anno (LocatedN Id) = SrcSpan+type instance Anno StringLiteral = EpAnnCO
compiler/GHC/Hs/Decls.hs view
@@ -6,10 +6,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension  {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+{-# LANGUAGE InstanceSigs #-}  {- (c) The University of Glasgow 2006@@ -29,6 +31,11 @@    -- ** Class or type declarations   TyClDecl(..), LTyClDecl, DataDeclRn(..),+  AnnDataDefn(..),+  AnnClassDecl(..),+  AnnSynDecl(..),+  AnnFamilyDecl(..),+  AnnClsInstDecl(..),   TyClGroup(..),   tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,   tyClGroupKindSigs,@@ -36,7 +43,7 @@   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,   tyFamInstDeclName, tyFamInstDeclLName,-  countTyClDecls, pprTyClDeclFlavour,+  countTyClDecls, tyClDeclFlavour,   tyClDeclLName, tyClDeclTyVars,   hsDeclHasCusk, famResultKindSignature,   FamilyDecl(..), LFamilyDecl,@@ -49,11 +56,11 @@   TyFamDefltDecl, LTyFamDefltDecl,   DataFamInstDecl(..), LDataFamInstDecl,   pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,-  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,   LClsInstDecl, ClsInstDecl(..),    -- ** Standalone deriving declarations-  DerivDecl(..), LDerivDecl,+  DerivDecl(..), LDerivDecl, AnnDerivDecl,   -- ** Deriving strategies   DerivStrategy(..), LDerivStrategy,   derivStrategyName, foldDerivStrategy, mapDerivStrategy,@@ -74,12 +81,14 @@   CImportSpec(..),   -- ** Data-constructor declarations   ConDecl(..), LConDecl,-  HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,+  HsConDeclH98Details, HsConDeclGADTDetails(..),+  AnnConDeclH98(..), AnnConDeclGADT(..),+  hsConDeclTheta,   getConNames, getRecConArgs_maybe,   -- ** Document comments   DocDecl(..), LDocDecl, docDeclDoc,   -- ** Deprecations-  WarnDecl(..),  LWarnDecl,+  WarnDecl(..), LWarnDecl,   WarnDecls(..), LWarnDecls,   -- ** Annotations   AnnDecl(..), LAnnDecl,@@ -101,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@@ -110,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@@ -124,12 +134,12 @@ import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type-import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour)) import GHC.Types.ForeignCall+import GHC.Unit.Module.Warnings -import GHC.Data.Bag import GHC.Data.Maybe import Data.Data (Data)+import Data.List (concatMap) import Data.Foldable (toList)  {-@@ -170,12 +180,12 @@       [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) partitionBindsAndSigs = go   where-    go [] = (emptyBag, [], [], [], [], [])+    go [] = ([], [], [], [], [], [])     go ((L l decl) : ds) =       let (bs, ss, ts, tfis, dfis, docs) = go ds in       case decl of         ValD _ b-          -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs)+          -> (L l b : bs, ss, ts, tfis, dfis, docs)         SigD _ s           -> (bs, L l s : ss, ts, tfis, dfis, docs)         TyClD _ (FamDecl _ t)@@ -221,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@@ -336,11 +360,11 @@  type instance XFamDecl      (GhcPass _) = NoExtField -type instance XSynDecl      GhcPs = EpAnn [AddEpAnn]+type instance XSynDecl      GhcPs = AnnSynDecl type instance XSynDecl      GhcRn = NameSet -- FVs type instance XSynDecl      GhcTc = NameSet -- FVs -type instance XDataDecl     GhcPs = EpAnn [AddEpAnn]+type instance XDataDecl     GhcPs = NoExtField type instance XDataDecl     GhcRn = DataDeclRn type instance XDataDecl     GhcTc = DataDeclRn @@ -350,17 +374,63 @@              , tcdFVs      :: NameSet }   deriving Data -type instance XClassDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey)+type instance XClassDecl    GhcPs =+  ( AnnClassDecl+  , EpLayout              -- See Note [Class EpLayout]+  , AnnSortKey DeclTag )  -- TODO:AZ:tidy up AnnSortKey -  -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl    GhcRn = NameSet -- FVs type instance XClassDecl    GhcTc = NameSet -- FVs  type instance XXTyClDecl    (GhcPass _) = DataConCantHappen -type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn]+type instance XCTyFamInstDecl (GhcPass _) = (EpToken "type", EpToken "instance") type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen +data AnnDataDefn+  = AnnDataDefn {+      andd_openp    :: [EpToken "("],+      andd_closep   :: [EpToken ")"],+      andd_type     :: EpToken "type",+      andd_newtype  :: EpToken "newtype",+      andd_data     :: EpToken "data",+      andd_instance :: EpToken "instance",+      andd_dcolon   :: TokDcolon,+      andd_where    :: EpToken "where",+      andd_openc    :: EpToken "{",+      andd_closec   :: EpToken "}",+      andd_equal    :: EpToken "="+  } deriving Data++instance NoAnn AnnDataDefn where+  noAnn = AnnDataDefn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn++data AnnClassDecl+  = AnnClassDecl {+      acd_class  :: EpToken "class",+      acd_openp  :: [EpToken "("],+      acd_closep :: [EpToken ")"],+      acd_vbar   :: EpToken "|",+      acd_where  :: EpToken "where",+      acd_openc  :: EpToken "{",+      acd_closec :: EpToken "}",+      acd_semis  :: [EpToken ";"]+  } deriving Data++instance NoAnn AnnClassDecl where+  noAnn = AnnClassDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn++data AnnSynDecl+  = AnnSynDecl {+    asd_opens  :: [EpToken "("],+    asd_closes :: [EpToken ")"],+    asd_type   :: EpToken "type",+    asd_equal  :: EpToken "="+  } deriving Data++instance NoAnn AnnSynDecl where+  noAnn = AnnSynDecl noAnn noAnn noAnn noAnn+ ------------- Pretty printing FamilyDecls -----------  pprFlavour :: FamilyInfo pass -> SDoc@@ -390,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@@ -448,7 +522,7 @@                     tcdFDs  = fds,                     tcdSigs = sigs, tcdMeths = methods,                     tcdATs = ats, tcdATDefs = at_defs})-      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part+      | null sigs && null methods && null ats && null at_defs -- No "where" part       = top_matter        | otherwise       -- Laid out@@ -476,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))@@ -497,18 +571,23 @@                   , 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 -type instance XCFunDep    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCFunDep    (GhcPass _) = TokRarrow type instance XXFunDep    (GhcPass _) = DataConCantHappen  pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc@@ -526,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  @@ -542,13 +628,31 @@ type instance XTyVarSig         (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen -type instance XCFamilyDecl    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCFamilyDecl    (GhcPass _) = AnnFamilyDecl type instance XXFamilyDecl    (GhcPass _) = DataConCantHappen +data AnnFamilyDecl+  = AnnFamilyDecl {+      afd_openp  :: [EpToken "("],+      afd_closep :: [EpToken ")"],+      afd_type   :: EpToken "type",+      afd_data   :: EpToken "data",+      afd_family :: EpToken "family",+      afd_dcolon :: TokDcolon,+      afd_equal  :: EpToken "=",+      afd_vbar   :: EpToken "|",+      afd_where  :: EpToken "where",+      afd_openc  :: EpToken "{",+      afd_dotdot :: EpToken "..",+      afd_closec :: EpToken "}"+  } deriving Data +instance NoAnn AnnFamilyDecl where+  noAnn = AnnFamilyDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn+ ------------- 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)@@ -558,18 +662,18 @@ famResultKindSignature (NoSig _) = Nothing famResultKindSignature (KindSig _ ki) = Just ki famResultKindSignature (TyVarSig _ bndr) =-  case unLoc bndr of-    UserTyVar _ _ _ -> Nothing-    KindedTyVar _ _ _ ki -> Just ki+  case hsBndrKind (unLoc bndr) of+    HsBndrNoKind _  -> Nothing+    HsBndrKind _ ki -> Just ki  -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))-resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig+resultVariableName (TyVarSig _ sig) = hsLTyVarName sig resultVariableName _                = Nothing  ------------- Pretty printing FamilyDecls ----------- -type instance XCInjectivityAnn  (GhcPass _) = EpAnn [AddEpAnn]+type instance XCInjectivityAnn  (GhcPass _) = TokRarrow type instance XXInjectivityAnn  (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -595,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 ->@@ -613,10 +717,10 @@ *                                                                      * ********************************************************************* -} -type instance XCHsDataDefn    (GhcPass _) = NoExtField+type instance XCHsDataDefn    (GhcPass _) = AnnDataDefn type instance XXHsDataDefn    (GhcPass _) = DataConCantHappen -type instance XCHsDerivingClause    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCHsDerivingClause    (GhcPass _) = EpToken "deriving" type instance XXHsDerivingClause    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -652,7 +756,7 @@   ppr (DctSingle _ ty) = ppr ty   ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn]+type instance XStandaloneKindSig GhcPs = (EpToken "type", TokDcolon) type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField @@ -661,11 +765,44 @@ standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn]-type instance XConDeclH98  (GhcPass _) = EpAnn [AddEpAnn]+type instance XConDeclGADT GhcPs = AnnConDeclGADT+type instance XConDeclGADT GhcRn = NoExtField+type instance XConDeclGADT GhcTc = NoExtField +type instance XConDeclH98  GhcPs = AnnConDeclH98+type instance XConDeclH98  GhcRn = NoExtField+type instance XConDeclH98  GhcTc = NoExtField+ type instance XXConDecl (GhcPass _) = DataConCantHappen +type instance XPrefixConGADT       (GhcPass _) = NoExtField++type instance XRecConGADT          GhcPs = TokRarrow+type instance XRecConGADT          GhcRn = NoExtField+type instance XRecConGADT          GhcTc = NoExtField++type instance XXConDeclGADTDetails (GhcPass _) = DataConCantHappen++data AnnConDeclH98+  = AnnConDeclH98 {+    acdh_forall  :: TokForall,+    acdh_dot :: EpToken ".",+    acdh_darrow :: TokDarrow+  } deriving Data++instance NoAnn AnnConDeclH98 where+  noAnn = AnnConDeclH98 noAnn noAnn noAnn++data AnnConDeclGADT+  = AnnConDeclGADT {+    acdg_openp  :: [EpToken "("],+    acdg_closep :: [EpToken ")"],+    acdg_dcolon :: TokDcolon+  } deriving Data++instance NoAnn AnnConDeclGADT where+  noAnn = AnnConDeclGADT noAnn noAnn noAnn+ -- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98  {con_name  = name}  = [name]@@ -674,14 +811,14 @@ -- | 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   InfixCon{}  -> Nothing getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of   PrefixConGADT{} -> Nothing-  RecConGADT flds _ -> Just flds+  RecConGADT _ flds -> Just flds  hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing            = []@@ -703,7 +840,7 @@       | isTypeDataDefnCons condecls = text "type"       | otherwise = empty     pp_ct = case mb_ct of-               Nothing   -> empty+               Nothing -> empty                Just ct -> ppr ct     pp_sig = case mb_sig of                Nothing   -> empty@@ -731,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@@ -755,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 @@ -790,15 +931,22 @@ ************************************************************************ -} -type instance XCFamEqn    (GhcPass _) r = EpAnn [AddEpAnn]+type instance XCFamEqn    (GhcPass _) r = ([EpToken "("], [EpToken ")"], EpToken "=") type instance XXFamEqn    (GhcPass _) r = DataConCantHappen -type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA- ----------------- Class instances ------------- -type instance XCClsInstDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up-type instance XCClsInstDecl    GhcRn = NoExtField+type instance XCClsInstDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)+                                             -- The warning of the deprecated instance+                                             -- See Note [Implementation of deprecated instances]+                                             -- in GHC.Tc.Solver.Dict+                                       , AnnClsInstDecl+                                       , AnnSortKey DeclTag) -- For sorting the additional annotations+                                        -- TODO:AZ:tidy up+type instance XCClsInstDecl    GhcRn = Maybe (LWarningTxt GhcRn)+                                           -- The warning of the deprecated instance+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict type instance XCClsInstDecl    GhcTc = NoExtField  type instance XXClsInstDecl    (GhcPass _) = DataConCantHappen@@ -815,6 +963,31 @@  type instance XXInstDecl    (GhcPass _) = DataConCantHappen +data AnnClsInstDecl+  = AnnClsInstDecl {+    acid_instance :: EpToken "instance",+    acid_where    :: EpToken "where",+    acid_openc    :: EpToken "{",+    acid_semis    :: [EpToken ";"],+    acid_closec   :: EpToken "}"+  } deriving Data++instance NoAnn AnnClsInstDecl where+  noAnn = AnnClsInstDecl noAnn noAnn noAnn noAnn noAnn++cidDeprecation :: forall p. IsPass p+               => ClsInstDecl (GhcPass p)+               -> Maybe (WarningTxt (GhcPass p))+cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)+  where+    decl_deprecation :: GhcPass p  -> ClsInstDecl (GhcPass p)+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))+    decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } )+      = depr+    decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })+      = depr+    decl_deprecation _ _ = Nothing+ instance OutputableBndrId p        => Outputable (TyFamInstDecl (GhcPass p)) where   ppr = pprTyFamInstDecl TopLevel@@ -867,7 +1040,7 @@ pprHsFamInstLHS :: (OutputableBndrId p)    => IdP (GhcPass p)    -> HsOuterFamEqnTyVarBndrs (GhcPass p)-   -> HsTyPats (GhcPass p)+   -> HsFamEqnPats (GhcPass p)    -> LexicalFixity    -> Maybe (LHsContext (GhcPass p))    -> SDoc@@ -878,11 +1051,11 @@  instance OutputableBndrId p        => Outputable (ClsInstDecl (GhcPass p)) where-    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds-                     , cid_sigs = sigs, cid_tyfam_insts = ats-                     , cid_overlap_mode = mbOverlap-                     , cid_datafam_insts = adts })-      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part+    ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds+                         , cid_sigs = sigs, cid_tyfam_insts = ats+                         , cid_overlap_mode = mbOverlap+                         , cid_datafam_insts = adts })+      | null sigs, null ats, null adts, null binds  -- No "where" part       = top_matter        | otherwise       -- Laid out@@ -892,8 +1065,9 @@                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++                pprLHsBindsForUser binds sigs ]       where-        top_matter = text "instance" <+> ppOverlapPragma mbOverlap-                                             <+> ppr inst_ty+        top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid)+                                     <+> ppOverlapPragma mbOverlap+                                     <+> ppr inst_ty  ppDerivStrategy :: OutputableBndrId p                 => Maybe (LDerivStrategy (GhcPass p)) -> SDoc@@ -911,9 +1085,10 @@     Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"     Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"     Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"+    Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet   where     maybe_stext NoSourceText     alt = text alt-    maybe_stext (SourceText src) _   = text src <+> text "#-}"+    maybe_stext (SourceText src) _   = ftext src <+> text "#-}"   instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where@@ -934,14 +1109,10 @@     do_one (L _ (TyFamInstD {}))                              = []  -- | Convert a 'NewOrData' to a 'TyConFlavour'-newOrDataToFlavour :: NewOrData -> TyConFlavour+newOrDataToFlavour :: NewOrData -> TyConFlavour tc 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@@ -958,19 +1129,43 @@ ************************************************************************ -} -type instance XCDerivDecl    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCDerivDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)+                                           -- The warning of the deprecated derivation+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+                                     , AnnDerivDecl )+type instance XCDerivDecl    GhcRn = ( Maybe (LWarningTxt GhcRn)+                                           -- The warning of the deprecated derivation+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+                                     , AnnDerivDecl )+type instance XCDerivDecl    GhcTc = AnnDerivDecl type instance XXDerivDecl    (GhcPass _) = DataConCantHappen -type instance Anno OverlapMode = SrcSpanAnnP+type AnnDerivDecl = (EpToken "deriving", EpToken "instance") +derivDeprecation :: forall p. IsPass p+               => DerivDecl (GhcPass p)+               -> Maybe (WarningTxt (GhcPass p))+derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)+  where+    decl_deprecation :: GhcPass p  -> DerivDecl (GhcPass p)+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))+    decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })+      = depr+    decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })+      = depr+    decl_deprecation _ _ = Nothing+ instance OutputableBndrId p        => Outputable (DerivDecl (GhcPass p)) where-    ppr (DerivDecl { deriv_type = ty+    ppr (deriv@DerivDecl { deriv_type = ty                    , deriv_strategy = ds                    , deriv_overlap_mode = o })         = hsep [ text "deriving"                , ppDerivStrategy ds                , text "instance"+               , maybe empty ppr (derivDeprecation deriv)                , ppOverlapPragma o                , ppr ty ] @@ -982,15 +1177,15 @@ ************************************************************************ -} -type instance XStockStrategy    GhcPs = EpAnn [AddEpAnn]+type instance XStockStrategy    GhcPs = EpToken "stock" type instance XStockStrategy    GhcRn = NoExtField type instance XStockStrategy    GhcTc = NoExtField -type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn]+type instance XAnyClassStrategy GhcPs = EpToken "anyclass" type instance XAnyClassStrategy GhcRn = NoExtField type instance XAnyClassStrategy GhcTc = NoExtField -type instance XNewtypeStrategy  GhcPs = EpAnn [AddEpAnn]+type instance XNewtypeStrategy  GhcPs = EpToken "newtype" type instance XNewtypeStrategy  GhcRn = NoExtField type instance XNewtypeStrategy  GhcTc = NoExtField @@ -998,7 +1193,7 @@ type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs)+data XViaStrategyPs = XViaStrategyPs (EpToken "via") (LHsSigType GhcPs)  instance OutputableBndrId p         => Outputable (DerivStrategy (GhcPass p)) where@@ -1037,7 +1232,7 @@ ************************************************************************ -} -type instance XCDefaultDecl    GhcPs = EpAnn [AddEpAnn]+type instance XCDefaultDecl    GhcPs = (EpToken "default", EpToken "(", EpToken ")") type instance XCDefaultDecl    GhcRn = NoExtField type instance XCDefaultDecl    GhcTc = NoExtField @@ -1045,8 +1240,8 @@  instance OutputableBndrId p        => Outputable (DefaultDecl (GhcPass p)) where-    ppr (DefaultDecl _ tys)-      = text "default" <+> parens (interpp'SP tys)+    ppr (DefaultDecl _ cl tys)+      = text "default" <+> maybe id ((<+>) . ppr) cl (parens (interpp'SP tys))  {- ************************************************************************@@ -1056,22 +1251,23 @@ ************************************************************************ -} -type instance XForeignImport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignImport   GhcPs = (EpToken "foreign", EpToken "import", TokDcolon) type instance XForeignImport   GhcRn = NoExtField type instance XForeignImport   GhcTc = Coercion -type instance XForeignExport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignExport   GhcPs = (EpToken "foreign", EpToken "export", TokDcolon) type instance XForeignExport   GhcRn = NoExtField type instance XForeignExport   GhcTc = Coercion  type instance XXForeignDecl    (GhcPass _) = DataConCantHappen -type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity+type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity type instance XXForeignImport  (GhcPass _) = DataConCantHappen -type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity+type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity type instance XXForeignExport  (GhcPass _) = DataConCantHappen + -- pretty printing of foreign declarations  instance OutputableBndrId p@@ -1125,39 +1321,35 @@ ************************************************************************ -} -type instance XCRuleDecls    GhcPs = (EpAnn [AddEpAnn], SourceText)+type instance XCRuleDecls    GhcPs = ((EpaLocation, EpToken "#-}"), SourceText) type instance XCRuleDecls    GhcRn = SourceText type instance XCRuleDecls    GhcTc = SourceText  type instance XXRuleDecls    (GhcPass _) = DataConCantHappen -type instance XHsRule       GhcPs = (EpAnn 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 (AddEpAnn, AddEpAnn)-                 -- ^ The locations of 'forall' and '.' for forall'd type vars-                 -- Using AddEpAnn to capture possible unicode variants-       , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)-                 -- ^ The locations of 'forall' and '.' for forall'd term vars-                 -- Using AddEpAnn to capture possible unicode variants-       , ra_rest :: [AddEpAnn]+       { ra_tyanns :: Maybe (TokForall, EpToken ".")+       , ra_tmanns :: Maybe (TokForall, EpToken ".")+       , ra_equal  :: EpToken "="+       , ra_rest :: ActivationAnn        } deriving (Data, Eq) +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 _) = EpAnn [AddEpAnn]-type instance XRuleBndrSig  (GhcPass _) = EpAnn [AddEpAnn]-type instance XXRuleBndr    (GhcPass _) = DataConCantHappen- instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where   ppr (HsRules { rds_ext = ext                , rds_rules = rules })@@ -1172,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) @@ -1206,20 +1388,20 @@ ************************************************************************ -} -type instance XWarnings      GhcPs = (EpAnn [AddEpAnn], SourceText)+type instance XWarnings      GhcPs = ((EpaLocation, EpToken "#-}"), SourceText) type instance XWarnings      GhcRn = SourceText type instance XWarnings      GhcTc = SourceText  type instance XXWarnDecls    (GhcPass _) = DataConCantHappen -type instance XWarning      (GhcPass _) = EpAnn [AddEpAnn]+type instance XWarning      (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]")) type instance XXWarnDecl    (GhcPass _) = DataConCantHappen   instance OutputableBndrId p         => Outputable (WarnDecls (GhcPass p)) where     ppr (Warnings ext decls)-      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"+      = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}"       where src = case ghcPass @p of               GhcPs | (_, SourceText src) <- ext -> src               GhcRn | SourceText src <- ext -> src@@ -1228,9 +1410,15 @@  instance OutputableBndrId p        => Outputable (WarnDecl (GhcPass p)) where-    ppr (Warning _ thing txt)-      = hsep ( punctuate comma (map ppr thing))+    ppr (Warning (ns_spec, _) thing txt)+      = ppr_category+              <+> ppr ns_spec+              <+> hsep (punctuate comma (map ppr thing))               <+> ppr txt+      where+        ppr_category = case txt of+                         WarningTxt (Just cat) _ _ -> ppr cat+                         _ -> empty  {- ************************************************************************@@ -1240,7 +1428,7 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText)+type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) type instance XXAnnDecl     (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where@@ -1262,14 +1450,12 @@ ************************************************************************ -} -type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn]+type instance XCRoleAnnotDecl GhcPs = (EpToken "type", EpToken "role") type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField  type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen -type instance Anno (Maybe Role) = SrcAnn NoEpAnns- instance OutputableBndr (IdP (GhcPass p))        => Outputable (RoleAnnotDecl (GhcPass p)) where   ppr (RoleAnnotDecl _ ltycon roles)@@ -1294,16 +1480,16 @@ type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA-type instance Anno (FamilyResultSig (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO type instance Anno CType = SrcSpanAnnP-type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno Bool = SrcAnn NoEpAnns-type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL+type instance Anno Bool = EpAnnCO+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@@ -1313,18 +1499,17 @@ type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP-type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns-type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (SourceText, RuleName) = EpAnnCO type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (Maybe Role) = SrcAnn NoEpAnns-type instance Anno CCallConv   = SrcSpan-type instance Anno Safety      = SrcSpan-type instance Anno CExportSpec = SrcSpan+type instance Anno (Maybe Role) = EpAnnCO+type instance Anno CCallConv   = EpaLocation+type instance Anno Safety      = EpaLocation+type instance Anno CExportSpec = EpaLocation
compiler/GHC/Hs/Doc.hs view
@@ -123,8 +123,8 @@ data DocStructureItem   = DsiSectionHeading !Int !(HsDoc GhcRn)   | DsiDocChunk !(HsDoc GhcRn)-  | DsiNamedChunkRef !(String)-  | DsiExports !Avails+  | DsiNamedChunkRef !String+  | DsiExports !DetOrdAvails   | DsiModExport       !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple                             -- modules with a single export declaration. E.g.@@ -133,7 +133,12 @@                             -- > module M (module X) where                             -- > import R0 as X                             -- > import R1 as X-      !Avails+                            --+                            -- Invariant: This list of ModuleNames must be+                            -- sorted to guarantee interface file determinism.+      !DetOrdAvails+                            -- ^ Invariant: This list of Avails must be sorted+                            -- to guarantee interface file determinism.  instance Binary DocStructureItem where   put_ bh = \case@@ -196,6 +201,8 @@ data Docs = Docs   { docs_mod_hdr      :: Maybe (HsDoc GhcRn)     -- ^ Module header.+  , docs_exports      :: UniqMap Name (HsDoc GhcRn)+     -- ^ Docs attached to module exports.   , docs_decls        :: UniqMap Name [HsDoc GhcRn]     -- ^ Docs for declarations: functions, data types, instances, methods etc.     -- A list because sometimes subsequent haddock comments can be combined into one@@ -216,16 +223,17 @@   }  instance NFData Docs where-  rnf (Docs mod_hdr decls args structure named_chunks haddock_opts language extentions)-    = rnf mod_hdr `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks+  rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions)+    = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks     `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions     `seq` ()  instance Binary Docs where   put_ bh docs = do     put_ bh (docs_mod_hdr docs)-    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_decls docs)-    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_exports docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs)     put_ bh (docs_structure docs)     put_ bh (Map.toList $ docs_named_chunks docs)     put_ bh (docs_haddock_opts docs)@@ -233,6 +241,7 @@     put_ bh (docs_extensions docs)   get bh = do     mod_hdr <- get bh+    exports <- listToUniqMap <$> get bh     decls <- listToUniqMap <$> get bh     args <- listToUniqMap <$> get bh     structure <- get bh@@ -241,7 +250,8 @@     language <- get bh     exts <- get bh     pure Docs { docs_mod_hdr = mod_hdr-              , docs_decls =  decls+              , docs_exports = exports+              , docs_decls = decls               , docs_args = args               , docs_structure = structure               , docs_named_chunks = named_chunks@@ -254,6 +264,7 @@   ppr docs =       vcat         [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr+        , pprField (ppr . fmap pprHsDocDebug) "export docs" docs_exports         , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls         , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args         , pprField (vcat . map ppr) "documentation structure" docs_structure@@ -283,6 +294,7 @@ emptyDocs :: Docs emptyDocs = Docs   { docs_mod_hdr = Nothing+  , docs_exports = emptyUniqMap   , docs_decls = emptyUniqMap   , docs_args = emptyUniqMap   , docs_structure = []
+ 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/DocString.hs view
@@ -21,6 +21,7 @@   , renderHsDocStrings   , exactPrintHsDocString   , pprWithDocString+  , printDecorator   ) where  import GHC.Prelude
compiler/GHC/Hs/Dump.hs view
@@ -4,7 +4,12 @@ -} {-# LANGUAGE RankNTypes #-} {-# 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.@@ -34,6 +39,7 @@  import Data.Data hiding (Fixity) import qualified Data.ByteString as B+import GHC.TypeLits  -- | Should source spans be removed from output. data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan@@ -57,28 +63,39 @@     showAstData' =       generic               `ext1Q` list+              `extQ` list_epaLocation+              `extQ` list_epTokenOpenP+              `extQ` list_epTokenCloseP               `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan-              `extQ` annotation               `extQ` annotationModule-              `extQ` annotationAddEpAnn               `extQ` annotationGrhsAnn-              `extQ` annotationEpAnnHsCase               `extQ` annotationAnnList+              `extQ` annotationAnnListWhere+              `extQ` annotationAnnListCommas+              `extQ` annotationAnnListIE               `extQ` annotationEpAnnImportDecl-              `extQ` annotationAnnParen-              `extQ` annotationTrailingAnn-              `extQ` annotationEpaLocation               `extQ` annotationNoEpAnns-              `extQ` addEpAnn+              `extQ` annotationExprBracket+              `extQ` annotationTypedBracket+              `extQ` epTokenOC+              `extQ` epTokenCC+              `extQ` epTokenInstance+              `extQ` epTokenForall+              `extQ` annParen+              `extQ` annClassDecl+              `extQ` annSynDecl+              `extQ` annDataDefn+              `extQ` annFamilyDecl+              `extQ` annClsInstDecl               `extQ` lit `extQ` litr `extQ` litt               `extQ` sourceText               `extQ` deltaPos-              `extQ` epaAnchor+              `extQ` epaLocation+              `extQ` maybe_epaLocation               `extQ` bytestring               `extQ` name `extQ` occName `extQ` moduleName `extQ` var               `extQ` dataCon               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-              `extQ` fixity               `ext2Q` located               `extQ` srcSpanAnnA               `extQ` srcSpanAnnL@@ -101,6 +118,24 @@             bytestring :: B.ByteString -> SDoc             bytestring = text . normalize_newlines . show +            list_epaLocation :: [EpaLocation] -> SDoc+            list_epaLocation ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[EpaLocation]"+              NoBlankEpAnnotations -> list ls++            list_epTokenOpenP :: [EpToken "("] -> SDoc+            list_epTokenOpenP ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[EpToken \"(\"]"+              NoBlankEpAnnotations -> list ls++            list_epTokenCloseP :: [EpToken ")"] -> SDoc+            list_epTokenCloseP ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[EpToken \"(\"]"+              NoBlankEpAnnotations -> list ls+             list []    = brackets empty             list [x]   = brackets (showAstData' x)             list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)@@ -137,18 +172,26 @@                                                , generic s ]              sourceText :: SourceText -> SDoc-            sourceText NoSourceText = parens $ text "NoSourceText"+            sourceText NoSourceText = case bs of+              BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"+              _            -> parens $ text "NoSourceText"             sourceText (SourceText src) = case bs of-              NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src-              BlankSrcSpanFile -> parens $ text "SourceText" <+> text src-              _                -> parens $ text "SourceText" <+> text "blanked"+              BlankSrcSpan     -> parens $ text "SourceText" <+> text "blanked"+              _                -> parens $ text "SourceText" <+> ftext src -            epaAnchor :: EpaLocation -> SDoc-            epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r-            epaAnchor (EpaDelta d cs) = case ba of-              NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs-              BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"+            epaLocation :: EpaLocation -> SDoc+            epaLocation (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s+            epaLocation (EpaDelta s d cs) = case ba of+              NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstData' cs+              BlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> text "blanked" +            maybe_epaLocation :: Maybe EpaLocation -> SDoc+            maybe_epaLocation ml = case ba of+              NoBlankEpAnnotations -> case ml of+                Nothing -> parens $ text "Nothing"+                Just l -> parens (text "Just" $$ showAstData' l)+              BlankEpAnnotations -> parens $ text "Maybe EpaLocation:" <+> text "blanked"+             deltaPos :: DeltaPos -> SDoc             deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c             deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c@@ -166,35 +209,123 @@             srcSpan :: SrcSpan -> SDoc             srcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))-             BlankSrcSpanFile -> braces $ char ' ' <>-                             (hang (pprUserSpan False ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' '              realSrcSpan :: RealSrcSpan -> SDoc             realSrcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))-             BlankSrcSpanFile -> braces $ char ' ' <>-                             (hang (pprUserRealSpan False ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' ' +            annParen :: AnnParen -> SDoc+            annParen ap = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen"+             NoBlankEpAnnotations -> parens (case ap of+                                      (AnnParens       o c) -> text "AnnParens"       $$ vcat [showAstData' o, showAstData' c]+                                      (AnnParensHash   o c) -> text "AnnParensHash"   $$ vcat [showAstData' o, showAstData' c]+                                      (AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c]+                                      ) -            addEpAnn :: AddEpAnn -> SDoc-            addEpAnn (AddEpAnn a s) = case ba of+            annClassDecl :: AnnClassDecl -> SDoc+            annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnClassDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnClassDecl"+                        $$ vcat [showAstData' c, showAstData' ops, showAstData' cps,+                                 showAstData' v, showAstData' w, showAstData' oc,+                                 showAstData' cc, showAstData' s]++            annSynDecl :: AnnSynDecl -> SDoc+            annSynDecl (AnnSynDecl ops cps t e) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnSynDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnSynDecl"+                        $$ vcat [showAstData' ops, showAstData' cps,+                                 showAstData' t, showAstData' e]++            annDataDefn :: AnnDataDefn -> SDoc+            annDataDefn (AnnDataDefn a b c d e f g h i j k) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnDataDefn"+             NoBlankEpAnnotations ->+              parens $ text "AnnDataDefn"+                        $$ vcat [showAstData' a, showAstData' b, showAstData' c,+                                 showAstData' d, showAstData' e, showAstData' f,+                                 showAstData' g, showAstData' h, showAstData' i,+                                 showAstData' j, showAstData' k]++            annFamilyDecl :: AnnFamilyDecl -> SDoc+            annFamilyDecl (AnnFamilyDecl a b c d e f g h i j k l) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnFamilyDecl"+                        $$ vcat [showAstData' a, showAstData' b, showAstData' c,+                                 showAstData' d, showAstData' e, showAstData' f,+                                 showAstData' g, showAstData' h, showAstData' i,+                                 showAstData' j, showAstData' k, showAstData' l]++            annClsInstDecl :: AnnClsInstDecl -> SDoc+            annClsInstDecl (AnnClsInstDecl a b c d e) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnClsInstDecl"+                        $$ vcat [showAstData' a, showAstData' b, showAstData' c,+                                 showAstData' d, showAstData' e]+++            annotationExprBracket :: BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|") -> SDoc+            annotationExprBracket = annotationBracket++            annotationTypedBracket :: BracketAnn (EpToken "[||") (EpToken "[e||") -> SDoc+            annotationTypedBracket = annotationBracket++            annotationBracket ::forall n h .(Data n, Data h, Typeable n, Typeable h)+              => BracketAnn n h -> SDoc+            annotationBracket a = case ba of              BlankEpAnnotations -> parens-                                      $ text "blanked:" <+> text "AddEpAnn"+                                      $ text "blanked:" <+> text "BracketAnn"              NoBlankEpAnnotations ->-              parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s+              parens $ case a of+                BracketNoE  t -> text "BracketNoE"  <+> showAstData' t+                BracketHasE t -> text "BracketHasE" <+> showAstData' t +            epTokenOC :: EpToken "{" -> SDoc+            epTokenOC  = epToken'++            epTokenCC :: EpToken "}" -> SDoc+            epTokenCC = epToken'++            epTokenInstance :: EpToken "instance" -> SDoc+            epTokenInstance = epToken'++            epTokenForall :: TokForall -> SDoc+            epTokenForall = epUniToken'++            epToken' :: KnownSymbol sym => EpToken sym -> SDoc+            epToken' (EpTok s) = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpToken"+             NoBlankEpAnnotations ->+              parens $ text "EpTok" <+> epaLocation s+            epToken' NoEpTok = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpToken"+             NoBlankEpAnnotations ->+              parens $ text "NoEpTok"++            epUniToken' :: EpUniToken sym1 sym2 -> SDoc+            epUniToken' (EpUniTok s f) = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpUniToken"+             NoBlankEpAnnotations ->+              parens $ text "EpUniTok" <+> epaLocation s <+> ppr f+            epUniToken' NoEpUniTok = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpUniToken"+             NoBlankEpAnnotations ->+              parens $ text "NoEpUniTok"++             var  :: Var -> SDoc             var v      = braces $ text "Var:" <+> ppr v @@ -220,11 +351,6 @@                           text "NameSet:"                        $$ (list . nameSetElemsStable $ ns) -            fixity :: Fixity -> SDoc-            fixity fx =  braces $-                         text "Fixity:"-                     <+> ppr fx-             located :: (Data a, Data b) => GenLocated a b -> SDoc             located (L ss a)               = parens (text "L"@@ -233,35 +359,26 @@              -- ------------------------- -            annotation :: EpAnn [AddEpAnn] -> SDoc-            annotation = annotation' (text "EpAnn [AddEpAnn]")-             annotationModule :: EpAnn AnnsModule -> SDoc             annotationModule = annotation' (text "EpAnn AnnsModule") -            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc-            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")-             annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc             annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") -            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc-            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")--            annotationAnnList :: EpAnn AnnList -> SDoc-            annotationAnnList = annotation' (text "EpAnn AnnList")+            annotationAnnList :: EpAnn (AnnList ()) -> SDoc+            annotationAnnList = annotation' (text "EpAnn (AnnList ())") -            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc-            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")+            annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc+            annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))") -            annotationAnnParen :: EpAnn AnnParen -> SDoc-            annotationAnnParen = annotation' (text "EpAnn AnnParen")+            annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc+            annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") -            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc-            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")+            annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc+            annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))") -            annotationEpaLocation :: EpAnn EpaLocation -> SDoc-            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")+            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc+            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")              annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc             annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")@@ -275,32 +392,32 @@              -- ------------------------- -            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc+            srcSpanAnnA :: EpAnn AnnListItem -> SDoc             srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") -            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc+            srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc             srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") -            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc+            srcSpanAnnP :: EpAnn AnnPragma -> SDoc             srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") -            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc+            srcSpanAnnC :: EpAnn AnnContext -> SDoc             srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") -            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc+            srcSpanAnnN :: EpAnn NameAnn -> SDoc             srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")              locatedAnn'' :: forall a. (Typeable a, Data a)-              => SDoc -> SrcSpanAnn' a -> SDoc+              => SDoc -> EpAnn a -> SDoc             locatedAnn'' tag ss = parens $               case cast ss of-                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->+                Just (ann :: EpAnn a) ->                   case ba of                     BlankEpAnnotations                       -> parens (text "blanked:" <+> tag)                     NoBlankEpAnnotations-                      -> text "SrcSpanAnn" <+> showAstData' ann-                              <+> srcSpan s+                      -> text (showConstr (toConstr ann))+                                          $$ vcat (gmapQ showAstData' ann)                 Nothing -> text "locatedAnn:unmatched" <+> tag                            <+> (parens $ text (showConstr (toConstr ss)))
compiler/GHC/Hs/Expr.hs view
@@ -32,2151 +32,2691 @@ -- friends: import GHC.Prelude -import GHC.Hs.Decls() -- import instances-import GHC.Hs.Pat-import GHC.Hs.Lit-import Language.Haskell.Syntax.Extension-import Language.Haskell.Syntax.Basic (FieldLabelString(..))-import GHC.Hs.Extension-import GHC.Hs.Type-import GHC.Hs.Binds-import GHC.Parser.Annotation---- others:-import GHC.Tc.Types.Evidence-import GHC.Types.Name-import GHC.Types.Name.Reader-import GHC.Types.Name.Set-import GHC.Types.Basic-import GHC.Types.Fixity-import GHC.Types.SourceText-import GHC.Types.SrcLoc-import GHC.Types.Tickish (CoreTickish)-import GHC.Core.ConLike-import GHC.Unit.Module (ModuleName)-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Data.FastString-import GHC.Core.Type-import GHC.Builtin.Types (mkTupleStr)-import GHC.Tc.Utils.TcType (TcType, TcTyVar)-import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)--import GHCi.RemoteTypes ( ForeignRef )-import qualified Language.Haskell.TH as TH (Q)---- libraries:-import Data.Data hiding (Fixity(..))-import qualified Data.Data as Data (Fixity(..))-import qualified Data.Kind-import Data.Maybe (isJust)-import Data.Foldable ( toList )-import Data.List (uncons)-import Data.Bifunctor (first)--{- *********************************************************************-*                                                                      *-                Expressions proper-*                                                                      *-********************************************************************* -}---- | Post-Type checking Expression------ PostTcExpr is an evidence expression attached to the syntax tree by the--- type checker (c.f. postTcType).-type PostTcExpr  = HsExpr GhcTc---- | Post-Type checking Table------ We use a PostTcTable where there are a bunch of pieces of evidence, more--- than is convenient to keep individually.-type PostTcTable = [(Name, PostTcExpr)]------------------------------- Defining SyntaxExpr in two stages allows for better type inference, because--- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,--- noSyntaxExpr would be ambiguous.-type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p--type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where-  SyntaxExprGhc 'Parsed      = NoExtField-  SyntaxExprGhc 'Renamed     = SyntaxExprRn-  SyntaxExprGhc 'Typechecked = SyntaxExprTc---- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].-data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)-    -- Why is the payload not just a Name?-    -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"-                  | NoSyntaxExprRn---- | An expression with wrappers, used for rebindable syntax------ This should desugar to------ > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)--- >                         (syn_arg_wraps[1] arg1) ...------ where the actual arguments come from elsewhere in the AST.-data SyntaxExprTc = SyntaxExprTc { syn_expr      :: HsExpr GhcTc-                                 , syn_arg_wraps :: [HsWrapper]-                                 , syn_res_wrap  :: HsWrapper }-                  | NoSyntaxExprTc  -- See Note [NoSyntaxExpr]---- | This is used for rebindable-syntax pieces that are too polymorphic--- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)-noExpr :: HsExpr (GhcPass p)-noExpr = HsLit noComments (HsString (SourceText  "noExpr") (fsLit "noExpr"))--noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)-                              -- Before renaming, and sometimes after-                              -- See Note [NoSyntaxExpr]-noSyntaxExpr = case ghcPass @p of-  GhcPs -> noExtField-  GhcRn -> NoSyntaxExprRn-  GhcTc -> NoSyntaxExprTc---- | Make a 'SyntaxExpr GhcRn' from an expression--- Used only in getMonadFailOp.--- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"-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>"--instance Outputable SyntaxExprTc where-  ppr (SyntaxExprTc { syn_expr      = expr-                    , syn_arg_wraps = arg_wraps-                    , syn_res_wrap  = res_wrap })-    = sdocOption sdocPrintExplicitCoercions $ \print_co ->-      getPprDebug $ \debug ->-      if debug || print_co-      then ppr expr <> braces (pprWithCommas ppr arg_wraps)-                    <> braces (ppr res_wrap)-      else ppr expr--  ppr NoSyntaxExprTc = text "<no syntax expr>"---- | HsWrap appears only in typechecker output-data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper-                            (hs_syn GhcTc) -- the thing that is wrapped--deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)---- -----------------------------------------------------------------------data HsBracketTc = HsBracketTc-  { hsb_quote   :: HsQuote GhcRn        -- See Note [The life cycle of a TH quotation]-  , hsb_ty      :: Type-  , hsb_wrap    :: Maybe QuoteWrapper   -- The wrapper to apply type and dictionary argument to the quote.-  , hsb_splices :: [PendingTcSplice]    -- Output of the type checker is the *original*-                                        -- renamed expression, plus-                                        -- _typechecked_ splices to be-                                        -- pasted back in by the desugarer-  }--type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]-type instance XTypedBracket GhcRn = NoExtField-type instance XTypedBracket GhcTc = HsBracketTc-type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn]-type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]-                                                        -- Output of the renamer is the *original* renamed expression,-                                                        -- plus _renamed_ splices to be type checked-type instance XUntypedBracket GhcTc = HsBracketTc---- ------------------------------------------------------------------------- API Annotations types--data EpAnnHsCase = EpAnnHsCase-      { hsCaseAnnCase :: EpaLocation-      , hsCaseAnnOf   :: EpaLocation-      , hsCaseAnnsRest :: [AddEpAnn]-      } deriving Data--data EpAnnUnboundVar = EpAnnUnboundVar-     { hsUnboundBackquotes :: (EpaLocation, EpaLocation)-     , hsUnboundHole       :: EpaLocation-     } deriving Data--type instance XVar           (GhcPass _) = NoExtField---- Record selectors at parse time are HsVar; they convert to HsRecSel--- on renaming.-type instance XRecSel              GhcPs = DataConCantHappen-type instance XRecSel              GhcRn = NoExtField-type instance XRecSel              GhcTc = NoExtField--type instance XLam           (GhcPass _) = NoExtField---- OverLabel not present in GhcTc pass; see GHC.Rename.Expr--- Note [Handling overloaded and rebindable constructs]-type instance XOverLabel     GhcPs = EpAnnCO-type instance XOverLabel     GhcRn = EpAnnCO-type instance XOverLabel     GhcTc = DataConCantHappen---- -----------------------------------------------------------------------type instance XVar           (GhcPass _) = NoExtField--type instance XUnboundVar    GhcPs = EpAnn 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 = EpAnnCO-type instance XIPVar         GhcRn = EpAnnCO-type instance XIPVar         GhcTc = DataConCantHappen-type instance XOverLitE      (GhcPass _) = EpAnnCO-type instance XLitE          (GhcPass _) = EpAnnCO--type instance XLam           (GhcPass _) = NoExtField--type instance XLamCase       (GhcPass _) = EpAnn [AddEpAnn]--type instance XApp           (GhcPass _) = EpAnnCO--type instance XAppTypeE      GhcPs = NoExtField-type instance XAppTypeE      GhcRn = NoExtField-type instance XAppTypeE      GhcTc = Type---- OpApp not present in GhcTc pass; see GHC.Rename.Expr--- Note [Handling overloaded and rebindable constructs]-type instance XOpApp         GhcPs = EpAnn [AddEpAnn]-type instance XOpApp         GhcRn = Fixity-type instance XOpApp         GhcTc = DataConCantHappen---- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr--- Note [Handling overloaded and rebindable constructs]-type instance XSectionL      GhcPs = EpAnnCO-type instance XSectionR      GhcPs = EpAnnCO-type instance XSectionL      GhcRn = EpAnnCO-type instance XSectionR      GhcRn = EpAnnCO-type instance XSectionL      GhcTc = DataConCantHappen-type instance XSectionR      GhcTc = DataConCantHappen---type instance XNegApp        GhcPs = EpAnn [AddEpAnn]-type instance XNegApp        GhcRn = NoExtField-type instance XNegApp        GhcTc = NoExtField--type instance XPar           (GhcPass _) = EpAnnCO--type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn]-type instance XExplicitTuple GhcRn = NoExtField-type instance XExplicitTuple GhcTc = NoExtField--type instance XExplicitSum   GhcPs = EpAnn AnnExplicitSum-type instance XExplicitSum   GhcRn = NoExtField-type instance XExplicitSum   GhcTc = [Type]--type instance XCase          GhcPs = EpAnn EpAnnHsCase-type instance XCase          GhcRn = NoExtField-type instance XCase          GhcTc = NoExtField--type instance XIf            GhcPs = EpAnn AnnsIf-type instance XIf            GhcRn = NoExtField-type instance XIf            GhcTc = NoExtField--type instance XMultiIf       GhcPs = EpAnn [AddEpAnn]-type instance XMultiIf       GhcRn = NoExtField-type instance XMultiIf       GhcTc = Type--type instance XLet           GhcPs = EpAnnCO-type instance XLet           GhcRn = NoExtField-type instance XLet           GhcTc = NoExtField--type instance XDo            GhcPs = EpAnn AnnList-type instance XDo            GhcRn = NoExtField-type instance XDo            GhcTc = Type--type instance XExplicitList  GhcPs = EpAnn AnnList-type instance XExplicitList  GhcRn = NoExtField-type instance XExplicitList  GhcTc = Type--- GhcPs: ExplicitList includes all source-level---   list literals, including overloaded ones--- GhcRn and GhcTc: ExplicitList used only for list literals---   that denote Haskell's built-in lists.  Overloaded lists---   have been expanded away in the renamer--- See Note [Handling overloaded and rebindable constructs]--- in  GHC.Rename.Expr--type instance XRecordCon     GhcPs = EpAnn [AddEpAnn]-type instance XRecordCon     GhcRn = NoExtField-type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function--type instance XRecordUpd     GhcPs = EpAnn [AddEpAnn]-type instance XRecordUpd     GhcRn = NoExtField-type instance XRecordUpd     GhcTc = DataConCantHappen-  -- We desugar record updates in the typechecker.-  -- See [Handling overloaded and rebindable constructs],-  -- and [Record Updates] in GHC.Tc.Gen.Expr.--type instance XGetField     GhcPs = EpAnnCO-type instance XGetField     GhcRn = NoExtField-type instance XGetField     GhcTc = DataConCantHappen--- HsGetField is eliminated by the renamer. See [Handling overloaded--- and rebindable constructs].--type instance XProjection     GhcPs = EpAnn AnnProjection-type instance XProjection     GhcRn = NoExtField-type instance XProjection     GhcTc = DataConCantHappen--- HsProjection is eliminated by the renamer. See [Handling overloaded--- and rebindable constructs].--type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn]-type instance XExprWithTySig GhcRn = NoExtField-type instance XExprWithTySig GhcTc = NoExtField--type instance XArithSeq      GhcPs = EpAnn [AddEpAnn]-type instance XArithSeq      GhcRn = NoExtField-type instance XArithSeq      GhcTc = PostTcExpr--type instance XProc          (GhcPass _) = EpAnn [AddEpAnn]--type instance XStatic        GhcPs = EpAnn [AddEpAnn]-type instance XStatic        GhcRn = NameSet-type instance XStatic        GhcTc = (NameSet, Type)-  -- Free variables and type of expression, this is stored for convenience as wiring in-  -- StaticPtr is a bit tricky (see #20150)--type instance XPragE         (GhcPass _) = NoExtField--type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL-type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA--data AnnExplicitSum-  = AnnExplicitSum {-      aesOpen       :: EpaLocation,-      aesBarsBefore :: [EpaLocation],-      aesBarsAfter  :: [EpaLocation],-      aesClose      :: EpaLocation-      } deriving Data--data AnnFieldLabel-  = AnnFieldLabel {-      afDot :: Maybe EpaLocation-      } deriving Data--data AnnProjection-  = AnnProjection {-      apOpen  :: EpaLocation, -- ^ '('-      apClose :: EpaLocation  -- ^ ')'-      } deriving Data--data AnnsIf-  = AnnsIf {-      aiIf       :: EpaLocation,-      aiThen     :: EpaLocation,-      aiElse     :: EpaLocation,-      aiThenSemi :: Maybe EpaLocation,-      aiElseSemi :: Maybe EpaLocation-      } deriving Data---- -----------------------------------------------------------------------type instance XSCC           (GhcPass _) = (EpAnn AnnPragma, SourceText)-type instance XXPragE        (GhcPass _) = DataConCantHappen--type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel-type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen--type instance XPresent         (GhcPass _) = EpAnn [AddEpAnn]--type instance XMissing         GhcPs = EpAnn EpaLocation-type instance XMissing         GhcRn = NoExtField-type instance XMissing         GhcTc = Scaled Type--type instance XXTupArg         (GhcPass _) = DataConCantHappen--tupArgPresent :: HsTupArg (GhcPass p) -> Bool-tupArgPresent (Present {}) = True-tupArgPresent (Missing {}) = False---{- *********************************************************************-*                                                                      *-            XXExpr: the extension constructor of HsExpr-*                                                                      *-********************************************************************* -}--type instance XXExpr GhcPs = DataConCantHappen-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)-type instance XXExpr GhcTc = XXExprGhcTc--- HsExpansion: see Note [Rebindable syntax and HsExpansion] below---data XXExprGhcTc-  = WrapExpr        -- Type and evidence application and abstractions-      {-# UNPACK #-} !(HsWrap HsExpr)--  | ExpansionExpr   -- See Note [Rebindable syntax and HsExpansion] below-      {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))--  | ConLikeTc      -- Result of typechecking a data-con-                   -- See Note [Typechecking data constructors] in-                   --     GHC.Tc.Gen.Head-                   -- The two arguments describe how to eta-expand-                   -- the data constructor when desugaring-        ConLike [TcTyVar] [Scaled TcType]--  ----------------------------------------  -- Haskell program coverage (Hpc) Support--  | HsTick-     CoreTickish-     (LHsExpr GhcTc)                    -- sub-expression--  | HsBinTick-     Int                                -- module-local tick number for True-     Int                                -- module-local tick number for False-     (LHsExpr GhcTc)                    -- sub-expression---{- *********************************************************************-*                                                                      *-            Pretty-printing expressions-*                                                                      *-********************************************************************* -}--instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where-    ppr expr = pprExpr expr---------------------------- pprExpr, pprLExpr, pprBinds call pprDeeper;--- the underscore versions do not-pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-pprLExpr (L _ e) = pprExpr e--pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc-pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e-          | otherwise                           = pprDeeper (ppr_expr e)--isQuietHsExpr :: HsExpr id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsExpr (HsPar {})        = True--- applications don't display anything themselves-isQuietHsExpr (HsApp {})        = True-isQuietHsExpr (HsAppType {})    = True-isQuietHsExpr (OpApp {})        = True-isQuietHsExpr _ = False--pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)-         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc-pprBinds b = pprDeeper (ppr b)--------------------------ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-ppr_lexpr e = ppr_expr (unLoc e)--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 (HsRecSel _ f)      = pprPrefixOcc f-ppr_expr (HsIPVar _ v)       = ppr v-ppr_expr (HsOverLabel _ s l) = char '#' <> case s of-                                             NoSourceText -> ppr l-                                             SourceText src -> text src-ppr_expr (HsLit _ lit)       = ppr lit-ppr_expr (HsOverLit _ lit)   = ppr lit-ppr_expr (HsPar _ _ e _)     = parens (ppr_lexpr e)--ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]--ppr_expr e@(HsApp {})        = ppr_apps e []-ppr_expr e@(HsAppType {})    = ppr_apps e []--ppr_expr (OpApp _ e1 op e2)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly--  where-    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens-    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear--    pp_prefixly-      = hang (ppr op) 2 (sep [pp_e1, pp_e2])--    pp_infixly pp_op-      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])--ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e--ppr_expr (SectionL _ expr op)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly-  where-    pp_expr = pprDebugParendExpr opPrec expr--    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])-                       4 (hsep [pp_expr, text "x_ )"])--    pp_infixly v = (sep [pp_expr, v])--ppr_expr (SectionR _ op expr)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly-  where-    pp_expr = pprDebugParendExpr opPrec expr--    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])-                       4 (pp_expr <> rparen)--    pp_infixly v = sep [v, pp_expr]--ppr_expr (ExplicitTuple _ exprs boxity)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `MkSolo x`, not `(x)`-  | [Present _ expr] <- exprs-  , Boxed <- boxity-  = hsep [text (mkTupleStr Boxed dataName 1), ppr expr]-  | otherwise-  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))-  where-    ppr_tup_args []               = []-    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es-    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es--    punc (Present {} : _) = comma <> space-    punc (Missing {} : _) = comma-    punc (XTupArg {} : _) = comma <> space-    punc []               = empty--ppr_expr (ExplicitSum _ alt arity expr)-  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"-  where-    ppr_bars n = hsep (replicate n (char '|'))--ppr_expr (HsLam _ matches)-  = pprMatches matches--ppr_expr (HsLamCase _ lc_variant matches)-  = sep [ sep [lamCaseKeyword lc_variant],-          nest 2 (pprMatches matches) ]--ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))-  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],-          pp_alts ]-  where-    pp_alts | null alts = text "{}"-            | otherwise = nest 2 (pprMatches matches)--ppr_expr (HsIf _ e1 e2 e3)-  = sep [hsep [text "if", nest 2 (ppr e1), text "then"],-         nest 4 (ppr e2),-         text "else",-         nest 4 (ppr e3)]--ppr_expr (HsMultiIf _ alts)-  = hang (text "if") 3  (vcat (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) ]-        ppr_alt (L _ (XGRHS x)) = ppr x---- special case: let ... in let ...-ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _)))-  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),-         ppr_lexpr expr]--ppr_expr (HsLet _ _ binds _ expr)-  = sep [hang (text "let") 2 (pprBinds binds),-         hang (text "in")  2 (ppr expr)]--ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts--ppr_expr (ExplicitList _ exprs)-  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))--ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })-  = hang pp_con 2 (ppr rbinds)-  where-    -- con :: ConLikeP (GhcPass p)-    -- so we need case analysis to know to print it-    pp_con = case ghcPass @p of-               GhcPs -> ppr con-               GhcRn -> ppr con-               GhcTc -> ppr con--ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })-  = case flds of-      Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))-      Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))--ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })-  = ppr fexp <> dot <> ppr field--ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds))))--ppr_expr (ExprWithTySig _ expr sig)-  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)-         4 (ppr sig)--ppr_expr (ArithSeq _ _ info) = brackets (ppr info)--ppr_expr (HsTypedSplice ext e)   =-    case ghcPass @p of-      GhcPs -> pprTypedSplice Nothing e-      GhcRn -> pprTypedSplice (Just ext) e-      GhcTc -> pprTypedSplice Nothing e-ppr_expr (HsUntypedSplice ext s) =-    case ghcPass @p of-      GhcPs -> pprUntypedSplice True Nothing s-      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s-      GhcRn | HsUntypedSpliceTop _ e  <- ext -> ppr e-      GhcTc -> dataConCantHappen ext--ppr_expr (HsTypedBracket b e)-  = case ghcPass @p of-    GhcPs -> thTyBrackets (ppr e)-    GhcRn -> thTyBrackets (ppr e)-    GhcTc | HsBracketTc _  _ty _wrap ps <- b ->-      thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps-ppr_expr (HsUntypedBracket b q)-  = case ghcPass @p of-    GhcPs -> ppr q-    GhcRn -> case b of-      [] -> ppr q-      ps -> ppr q $$ text "pending(rn)" <+> ppr ps-    GhcTc | HsBracketTc rnq  _ty _wrap ps <- b ->-      ppr rnq `ppr_with_pending_tc_splices` ps--ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))-  = hsep [text "proc", ppr pat, text "->", ppr cmd]--ppr_expr (HsStatic _ e)-  = hsep [text "static", ppr e]--ppr_expr (XExpr x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-#endif-  GhcRn -> ppr x-  GhcTc -> ppr x--instance Outputable XXExprGhcTc where-  ppr (WrapExpr (HsWrap co_fn e))-    = pprHsWrapper co_fn (\_parens -> pprExpr e)--  ppr (ExpansionExpr e)-    = ppr e -- e is an HsExpansion, we print the original-            -- expression (LHsExpr GhcPs), not the-            -- desugared one (LHsExpr GhcTc).--  ppr (ConLikeTc con _ _) = pprPrefixOcc con-   -- Used in error messages generated by-   -- the pattern match overlap checker--  ppr (HsTick tickish exp) =-    pprTicks (ppr exp) $-      ppr tickish <+> ppr_lexpr exp--  ppr (HsBinTick tickIdTrue tickIdFalse exp) =-    pprTicks (ppr exp) $-      hcat [text "bintick<",-            ppr tickIdTrue,-            text ",",-            ppr tickIdFalse,-            text ">(",-            ppr exp, text ")"]--ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc-ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)-ppr_infix_expr (HsRecSel _ f)       = Just (pprInfixOcc f)-ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)-ppr_infix_expr (XExpr x)            = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 901-                                        GhcPs -> Nothing-#endif-                                        GhcRn -> ppr_infix_expr_rn x-                                        GhcTc -> ppr_infix_expr_tc x-ppr_infix_expr _ = Nothing--ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc-ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a--ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc-ppr_infix_expr_tc (WrapExpr (HsWrap _ e))          = ppr_infix_expr e-ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a-ppr_infix_expr_tc (ConLikeTc {})                   = Nothing-ppr_infix_expr_tc (HsTick {})                      = Nothing-ppr_infix_expr_tc (HsBinTick {})                   = Nothing--ppr_apps :: (OutputableBndrId p)-         => HsExpr (GhcPass p)-         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]-         -> SDoc-ppr_apps (HsApp _ (L _ fun) arg)        args-  = ppr_apps fun (Left arg : args)-ppr_apps (HsAppType _ (L _ fun) _ arg)  args-  = ppr_apps fun (Right arg : args)-ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))-  where-    pp (Left arg)                             = ppr arg-    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))-    --   = char '@' <> pprHsType arg-    pp (Right arg)-      = text "@" <> ppr arg---pprDebugParendExpr :: (OutputableBndrId p)-                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc-pprDebugParendExpr p expr-  = getPprDebug $ \case-      True  -> pprParendLExpr p expr-      False -> pprLExpr         expr--pprParendLExpr :: (OutputableBndrId p)-               => PprPrec -> LHsExpr (GhcPass p) -> SDoc-pprParendLExpr p (L _ e) = pprParendExpr p e--pprParendExpr :: (OutputableBndrId p)-              => PprPrec -> HsExpr (GhcPass p) -> SDoc-pprParendExpr p expr-  | hsExprNeedsParens p expr = parens (pprExpr expr)-  | otherwise                = pprExpr expr-        -- Using pprLExpr makes sure that we go 'deeper'-        -- I think that is usually (always?) right---- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs--- parentheses under precedence @p@.-hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool-hsExprNeedsParens prec = go-  where-    go :: HsExpr (GhcPass p) -> Bool-    go (HsVar{})                      = False-    go (HsUnboundVar{})               = False-    go (HsIPVar{})                    = False-    go (HsOverLabel{})                = False-    go (HsLit _ l)                    = hsLitNeedsParens prec l-    go (HsOverLit _ ol)               = hsOverLitNeedsParens prec ol-    go (HsPar{})                      = False-    go (HsApp{})                      = prec >= appPrec-    go (HsAppType {})                 = prec >= appPrec-    go (OpApp{})                      = prec >= opPrec-    go (NegApp{})                     = prec > topPrec-    go (SectionL{})                   = True-    go (SectionR{})                   = True-    -- Special-case unary boxed tuple applications so that they are-    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)-    -- See Note [One-tuples] in GHC.Builtin.Types-    go (ExplicitTuple _ [Present{}] Boxed)-                                      = prec >= appPrec-    go (ExplicitTuple{})              = False-    go (ExplicitSum{})                = False-    go (HsLam{})                      = prec > topPrec-    go (HsLamCase{})                  = prec > topPrec-    go (HsCase{})                     = prec > topPrec-    go (HsIf{})                       = prec > topPrec-    go (HsMultiIf{})                  = prec > topPrec-    go (HsLet{})                      = prec > topPrec-    go (HsDo _ sc _)-      | isDoComprehensionContext sc   = False-      | otherwise                     = prec > topPrec-    go (ExplicitList{})               = False-    go (RecordUpd{})                  = False-    go (ExprWithTySig{})              = prec >= sigPrec-    go (ArithSeq{})                   = False-    go (HsPragE{})                    = prec >= appPrec-    go (HsTypedSplice{})              = False-    go (HsUntypedSplice{})            = False-    go (HsTypedBracket{})             = False-    go (HsUntypedBracket{})           = False-    go (HsProc{})                     = prec > topPrec-    go (HsStatic{})                   = prec >= appPrec-    go (RecordCon{})                  = False-    go (HsRecSel{})                   = False-    go (HsProjection{})               = True-    go (HsGetField{})                 = False-    go (XExpr x) = case ghcPass @p of-                     GhcTc -> go_x_tc x-                     GhcRn -> go_x_rn x-#if __GLASGOW_HASKELL__ <= 900-                     GhcPs -> True-#endif--    go_x_tc :: XXExprGhcTc -> Bool-    go_x_tc (WrapExpr (HsWrap _ e))          = hsExprNeedsParens prec e-    go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a-    go_x_tc (ConLikeTc {})                   = False-    go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e-    go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e--    go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool-    go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a----- | Parenthesize an expression without token information-gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)-gHsPar e = HsPar noAnn noHsTok e noHsTok---- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,--- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.-parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-parenthesizeHsExpr p le@(L loc e)-  | hsExprNeedsParens p e = L loc (gHsPar le)-  | otherwise             = le--stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e-stripParensLHsExpr e = e--stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)-stripParensHsExpr (HsPar _ _ (L _ e) _) = stripParensHsExpr e-stripParensHsExpr e = e--isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool--- True of a single token-isAtomicHsExpr (HsVar {})        = True-isAtomicHsExpr (HsLit {})        = True-isAtomicHsExpr (HsOverLit {})    = True-isAtomicHsExpr (HsIPVar {})      = True-isAtomicHsExpr (HsOverLabel {})  = True-isAtomicHsExpr (HsUnboundVar {}) = True-isAtomicHsExpr (HsRecSel{})      = True-isAtomicHsExpr (XExpr x)-  | GhcTc <- ghcPass @p          = go_x_tc x-  | GhcRn <- ghcPass @p          = go_x_rn x-  where-    go_x_tc (WrapExpr      (HsWrap _ e))     = isAtomicHsExpr e-    go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a-    go_x_tc (ConLikeTc {})                   = True-    go_x_tc (HsTick {}) = False-    go_x_tc (HsBinTick {}) = False--    go_x_rn (HsExpanded a _) = isAtomicHsExpr a--isAtomicHsExpr _ = False--instance Outputable (HsPragE (GhcPass p)) where-  ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) =-    pprWithSourceText st (text "{-# SCC")-     -- no doublequotes if stl empty, for the case where the SCC was written-     -- without quotes.-    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"---{- *********************************************************************-*                                                                      *-             HsExpansion and rebindable syntax-*                                                                      *-********************************************************************* -}--{- Note [Rebindable syntax and HsExpansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We implement rebindable syntax (RS) support by performing a desugaring-in the renamer. We transform GhcPs expressions and patterns affected by-RS into the appropriate desugared form, but **annotated with the original-expression/pattern**.--Let us consider a piece of code like:--    {-# LANGUAGE RebindableSyntax #-}-    ifThenElse :: Char -> () -> () -> ()-    ifThenElse _ _ _ = ()-    x = if 'a' then () else True--The parsed AST for the RHS of x would look something like (slightly simplified):--    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))--Upon seeing such an AST with RS on, we could transform it into a-mere function call, as per the RS rules, equivalent to the-following function application:--    ifThenElse 'a' () True--which doesn't typecheck. But GHC would report an error about-not being able to match the third argument's type (Bool) with the-expected type: (), in the expression _as desugared_, i.e in-the aforementioned function application. But the user never-wrote a function application! This would be pretty bad.--To remedy this, instead of transforming the original HsIf-node into mere applications of 'ifThenElse', we keep the-original 'if' expression around too, using the TTG-XExpr extension point to allow GHC to construct an-'HsExpansion' value that will keep track of the original-expression in its first field, and the desugared one in the-second field. The resulting renamed AST would look like:--    L locif (XExpr-      (HsExpanded-        (HsIf (L loca 'a')-              (L loctrue ())-              (L locfalse True)-        )-        (App (L generatedSrcSpan-                (App (L generatedSrcSpan-                        (App (L generatedSrcSpan (Var ifThenElse))-                             (L loca 'a')-                        )-                     )-                     (L loctrue ())-                )-             )-             (L locfalse True)-        )-      )-    )--When comes the time to typecheck the program, we end up calling-tcMonoExpr on the AST above. If this expression gives rise to-a type error, then it will appear in a context line and GHC-will pretty-print it using the 'Outputable (HsExpansion a b)'-instance defined below, which *only prints the original-expression*. This is the gist of the idea, but is not quite-enough to recover the error messages that we had with the-SyntaxExpr-based, typechecking/desugaring-to-core time-implementation of rebindable syntax. The key idea is to decorate-some elements of the desugared expression so as to be able to-give them a special treatment when typechecking the desugared-expression, to print a different context line or skip one-altogether.--Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in-TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we-entered generated code, i.e code fabricated by the compiler when rebinding some-syntax. If someone tries to push some error context line while that field is set-to True, the pushing won't actually happen and the context line is just dropped.-Once we 'setSrcSpan' a real span (for an expression that was in the original-source code), we set 'tcl_in_gen_code' back to False, indicating that we-"emerged from the generated code tunnel", and that the expressions we will be-processing are relevant to report in context lines again.--You might wonder why TcLclEnv has both-   tcl_loc         :: RealSrcSpan-   tcl_in_gen_code :: Bool-Could we not store a Maybe RealSrcSpan? The problem is that we still-generate constraints when processing generated code, and a CtLoc must-contain a RealSrcSpan -- otherwise, error messages might appear-without source locations. So tcl_loc keeps the RealSrcSpan of the last-location spotted that wasn't generated; it's as good as we're going to-get in generated code. Once we get to sub-trees that are not-generated, then we update the RealSrcSpan appropriately, and set the-tcl_in_gen_code Bool to False.-------An overview of the constructs that are desugared in this way is laid out in-Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.--A general recipe to follow this approach for new constructs could go as follows:--- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your-  construct, in HsExpr or related syntax data types.-- At renaming-time:-    - take your original node of interest (HsIf above)-    - rename its subexpressions/subpatterns (condition and true/false-      branches above)-    - construct the suitable "rebound"-and-renamed result (ifThenElse call-      above), where the 'SrcSpan' attached to any _fabricated node_ (the-      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'-    - take both the original node and that rebound-and-renamed result and wrap-      them into an expansion construct:-        for expressions, XExpr (HsExpanded <original node> <desugared>)-        for patterns, XPat (HsPatExpanded <original node> <desugared>)- - At typechecking-time:-    - remove any logic that was previously dealing with your rebindable-      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.-    - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we-      typecheck the desugared expression while reporting the original one in-      errors--}--{- Note [Overview of record dot syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This is the note that explains all the moving parts for record dot-syntax.--The language extensions @OverloadedRecordDot@ and-@OverloadedRecordUpdate@ (providing "record dot syntax") are-implemented using the techniques of Note [Rebindable syntax and-HsExpansion].--When OverloadedRecordDot is enabled:-- Field selection expressions-  - e.g. foo.bar.baz-  - Have abstract syntax HsGetField-  - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions-- Field selector expressions e.g. (.x.y)-  - Have abstract syntax HsProjection-  - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions--When OverloadedRecordUpdate is enabled:-- Record update expressions-  - e.g. a{foo.bar=1, quux="corge", baz}-  - Have abstract syntax RecordUpd-    - With rupd_flds containting a Right-    - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)-  - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions-    - Note that this is true for all record updates even for those that do not involve '.'--When OverloadedRecordDot is enabled and RebindableSyntax is not-enabled the name 'getField' is resolved to GHC.Records.getField. When-OverloadedRecordDot is enabled and RebindableSyntax is enabled the-name 'getField' is whatever in-scope name that is.--When OverloadedRecordUpd is enabled and RebindableSyntax is not-enabled it is an error for now (temporary while we wait on native-setField support; see-https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When-OverloadedRecordUpd is enabled and RebindableSyntax is enabled the-names 'getField' and 'setField' are whatever in-scope names they are.--}---- See Note [Rebindable syntax and HsExpansion] just above.-data HsExpansion orig expanded-  = HsExpanded orig expanded-  deriving Data---- | Just print the original expression (the @a@).-instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where-  ppr (HsExpanded orig expanded)-    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])-                 (ppr orig)---{--************************************************************************-*                                                                      *-\subsection{Commands (in arrow abstractions)}-*                                                                      *-************************************************************************--}--type instance XCmdArrApp  GhcPs = EpAnn AddEpAnn-type instance XCmdArrApp  GhcRn = NoExtField-type instance XCmdArrApp  GhcTc = Type--type instance XCmdArrForm GhcPs = EpAnn AnnList-type instance XCmdArrForm GhcRn = NoExtField-type instance XCmdArrForm GhcTc = NoExtField--type instance XCmdApp     (GhcPass _) = EpAnnCO-type instance XCmdLam     (GhcPass _) = NoExtField-type instance XCmdPar     (GhcPass _) = EpAnnCO--type instance XCmdCase    GhcPs = EpAnn EpAnnHsCase-type instance XCmdCase    GhcRn = NoExtField-type instance XCmdCase    GhcTc = NoExtField--type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn]--type instance XCmdIf      GhcPs = EpAnn AnnsIf-type instance XCmdIf      GhcRn = NoExtField-type instance XCmdIf      GhcTc = NoExtField--type instance XCmdLet     GhcPs = EpAnnCO-type instance XCmdLet     GhcRn = NoExtField-type instance XCmdLet     GhcTc = NoExtField--type instance XCmdDo      GhcPs = EpAnn AnnList-type instance XCmdDo      GhcRn = NoExtField-type instance XCmdDo      GhcTc = Type--type instance XCmdWrap    (GhcPass _) = NoExtField--type instance XXCmd       GhcPs = DataConCantHappen-type instance XXCmd       GhcRn = DataConCantHappen-type instance XXCmd       GhcTc = HsWrap HsCmd--type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]-  = SrcSpanAnnL--    -- If   cmd :: arg1 --> res-    --      wrap :: arg1 "->" arg2-    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res---- | Command Syntax Table (for Arrow syntax)-type CmdSyntaxTable p = [(Name, HsExpr p)]--- See Note [CmdSyntaxTable]--{--Note [CmdSyntaxTable]-~~~~~~~~~~~~~~~~~~~~~-Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps-track of the methods needed for a Cmd.--* Before the renamer, this list is an empty list--* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@-  For example, for the 'arr' method-   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)-   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)-             where @arr_22@ is whatever 'arr' is in scope--* After the type checker, it takes the form [(std_name, <expression>)]-  where <expression> is the evidence for the method.  This evidence is-  instantiated with the class, but is still polymorphic in everything-  else.  For example, in the case of 'arr', the evidence has type-         forall b c. (b->c) -> a b c-  where 'a' is the ambient type of the arrow.  This polymorphism is-  important because the desugarer uses the same evidence at multiple-  different types.--This is Less Cool than what we normally do for rebindable syntax, which is to-make fully-instantiated piece of evidence at every use site.  The Cmd way-is Less Cool because-  * The renamer has to predict which methods are needed.-    See the tedious GHC.Rename.Expr.methodNamesCmd.--  * The desugarer has to know the polymorphic type of the instantiated-    method. This is checked by Inst.tcSyntaxName, but is less flexible-    than the rest of rebindable syntax, where the type is less-    pre-ordained.  (And this flexibility is useful; for example we can-    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)--}--data CmdTopTc-  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack-             Type    -- return type of the command-             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]--type instance XCmdTop  GhcPs = NoExtField-type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]-type instance XCmdTop  GhcTc = CmdTopTc---type instance XXCmdTop (GhcPass _) = DataConCantHappen--instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where-    ppr cmd = pprCmd cmd---------------------------- pprCmd and pprLCmd call pprDeeper;--- the underscore versions do not-pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc-pprLCmd (L _ c) = pprCmd c--pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc-pprCmd c | isQuietHsCmd c =            ppr_cmd c-         | otherwise      = pprDeeper (ppr_cmd c)--isQuietHsCmd :: HsCmd id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsCmd (HsCmdPar {}) = True--- applications don't display anything themselves-isQuietHsCmd (HsCmdApp {}) = True-isQuietHsCmd _ = False--------------------------ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc-ppr_lcmd c = ppr_cmd (unLoc c)--ppr_cmd :: forall p. (OutputableBndrId p-                     ) => HsCmd (GhcPass p) -> SDoc-ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c)--ppr_cmd (HsCmdApp _ c e)-  = let (fun, args) = collect_args c [e] in-    hang (ppr_lcmd fun) 2 (sep (map ppr args))-  where-    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)-    collect_args fun args = (fun, args)--ppr_cmd (HsCmdLam _ matches)-  = pprMatches matches--ppr_cmd (HsCmdCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],-          nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdLamCase _ lc_variant matches)-  = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdIf _ _ e ct ce)-  = sep [hsep [text "if", nest 2 (ppr e), text "then"],-         nest 4 (ppr ct),-         text "else",-         nest 4 (ppr ce)]---- special case: let ... in let ...-ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {})))-  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),-         ppr_lcmd cmd]--ppr_cmd (HsCmdLet _ _ binds _ cmd)-  = sep [hang (text "let") 2 (pprBinds binds),-         hang (text "in")  2 (ppr cmd)]--ppr_cmd (HsCmdDo _ (L _ stmts))  = pprArrowExpr stmts--ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)-  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]-ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)-  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]-ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)-  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]-ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)-  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]--ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)-  | HsVar _ (L _ v) <- op-  = ppr_cmd_infix v-  | GhcTc <- ghcPass @p-  , XExpr (ConLikeTc c _ _) <- op-  = ppr_cmd_infix (conLikeName c)-  | otherwise-  = fall_through-  where-    fall_through = hang (text "(|" <+> ppr_expr op)-                      4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")--    ppr_cmd_infix :: OutputableBndr v => v -> SDoc-    ppr_cmd_infix v-      | [arg1, arg2] <- args-      , isJust rn_fix || ps_fix == Infix-      = hang (pprCmdArg (unLoc arg1))-           4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])-      | otherwise-      = fall_through--ppr_cmd (XCmd x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-  GhcRn -> ppr x-#endif-  GhcTc -> case x of-    HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))--pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc-pprCmdArg (HsCmdTop _ cmd)-  = ppr_lcmd cmd--instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where-    ppr = pprCmdArg--{--************************************************************************-*                                                                      *-\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}-*                                                                      *-************************************************************************--}--type instance XMG         GhcPs b = Origin-type instance XMG         GhcRn b = Origin-type instance XMG         GhcTc b = MatchGroupTc--data MatchGroupTc-  = MatchGroupTc-       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn-       , mg_res_ty  :: Type    -- Type of the result, tr-       , mg_origin  :: Origin  -- Origin (Generated vs FromSource)-       } deriving Data--type instance XXMatchGroup (GhcPass _) b = DataConCantHappen--type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]-type instance XXMatch (GhcPass _) b = DataConCantHappen--instance (OutputableBndrId pr, Outputable body)-            => Outputable (Match (GhcPass pr) body) where-  ppr = pprMatch--isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool-isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms---- | Is there only one RHS in this list of matches?-isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool-isSingletonMatchGroup matches-  | [L _ match] <- matches-  , 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 = length (hsLMatchPats alt1)-  | otherwise        = panic "matchGroupArity"--hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]-hsLMatchPats (L _ (Match { m_pats = pats })) = pats---- 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--- item. So this can never be used in practice.-type instance XCGRHSs (GhcPass _) _ = EpAnnComments--type instance XXGRHSs (GhcPass _) _ = DataConCantHappen--data GrhsAnn-  = GrhsAnn {-      ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this?-      ga_sep  :: AddEpAnn -- ^ Match separator location-      } deriving (Data)--type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn-                                   -- Location of matchSeparator-                                   -- TODO:AZ does this belong on the GRHS, or GRHSs?--type instance XXGRHS (GhcPass _) b = DataConCantHappen--pprMatches :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc-pprMatches MG { mg_alts = matches }-    = vcat (map pprMatch (map unLoc (unLoc matches)))-      -- Don't print the type; it's only a place-holder before typechecking---- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext-pprFunBind :: (OutputableBndrId idR)-           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc-pprFunBind matches = pprMatches matches---- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext-pprPatBind :: forall bndr p . (OutputableBndrId bndr,-                               OutputableBndrId p)-           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc-pprPatBind pat grhss- = sep [ppr pat,-       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]--pprMatch :: (OutputableBndrId idR, Outputable body)-         => Match (GhcPass idR) body -> SDoc-pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })-  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)-        , nest 2 (pprGRHSs ctxt grhss) ]-  where-    (herald, other_pats)-        = case ctxt of-            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}-                | SrcStrict <- strictness-                -> assert (null pats)     -- A strict variable binding-                   (char '!'<>pprPrefixOcc fun, pats)--                | Prefix <- fixity-                -> (pprPrefixOcc fun, pats) -- f x y z = e-                                            -- Not pprBndr; the AbsBinds will-                                            -- have printed the signature-                | otherwise-                -> case pats of-                     (p1:p2:rest)-                        | null rest -> (pp_infix, [])           -- x &&& y = e-                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e-                        where-                          pp_infix = pprParendLPat opPrec p1-                                     <+> pprInfixOcc fun-                                     <+> pprParendLPat opPrec p2-                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)--            LambdaExpr -> (char '\\', pats)--            -- We don't simply return (empty, pats) to avoid introducing an-            -- additional `nest 2` via the empty herald-            LamCaseAlt LamCases ->-              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)--            ArrowMatchCtxt (ArrowLamCaseAlt LamCases) ->-              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)--            ArrowMatchCtxt KappaExpr -> (char '\\', pats)--            ArrowMatchCtxt ProcExpr -> (text "proc", pats)--            _ -> case pats of-                   []    -> (empty, [])-                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case-                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)--pprGRHSs :: (OutputableBndrId idR, Outputable body)-         => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc-pprGRHSs ctxt (GRHSs _ grhss binds)-  = vcat (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)-      (text "where" $$ nest 4 (pprBinds binds))--pprGRHS :: (OutputableBndrId idR, Outputable body)-        => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc-pprGRHS ctxt (GRHS _ [] body)- =  pp_rhs ctxt body--pprGRHS ctxt (GRHS _ guards body)- = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]--pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc-pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)--instance Outputable GrhsAnn where-  ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s--{--************************************************************************-*                                                                      *-\subsection{Do stmts and list comprehensions}-*                                                                      *-************************************************************************--}---- Extra fields available post typechecking for RecStmt.-data RecStmtTc =-  RecStmtTc-     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T-     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)-     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1-                                  -- with recS_later_ids and recS_rec_ids,-                                  -- and are the expressions that should be-                                  -- returned by the recursion.-                                  -- They may not quite be the Ids themselves,-                                  -- because the Id may be *polymorphic*, but-                                  -- the returned thing has to be *monomorphic*,-                                  -- so they may be type applications--      , recS_ret_ty :: Type        -- The type of-                                   -- do { stmts; return (a,b,c) }-                                   -- With rebindable syntax the type might not-                                   -- be quite as simple as (m (tya, tyb, tyc)).-      }---type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField--type instance XBindStmt        (GhcPass _) GhcPs b = EpAnn [AddEpAnn]-type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn-type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc--data XBindStmtRn = XBindStmtRn-  { xbsrn_bindOp :: SyntaxExpr GhcRn-  , xbsrn_failOp :: FailOperator GhcRn-  }--data XBindStmtTc = XBindStmtTc-  { xbstc_bindOp :: SyntaxExpr GhcTc-  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S-  , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S-  , xbstc_failOp :: FailOperator GhcTc-  }--type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcTc b = Type--type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcTc b = Type--type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn]--type instance XParStmt         (GhcPass _) GhcPs b = NoExtField-type instance XParStmt         (GhcPass _) GhcRn b = NoExtField-type instance XParStmt         (GhcPass _) GhcTc b = Type--type instance XTransStmt       (GhcPass _) GhcPs b = EpAnn [AddEpAnn]-type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField-type instance XTransStmt       (GhcPass _) GhcTc b = Type--type instance XRecStmt         (GhcPass _) GhcPs b = EpAnn AnnList-type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField-type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc--type instance XXStmtLR         (GhcPass _) (GhcPass _) b = DataConCantHappen--type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen--type instance XApplicativeArgOne GhcPs = NoExtField-type instance XApplicativeArgOne GhcRn = FailOperator GhcRn-type instance XApplicativeArgOne GhcTc = FailOperator GhcTc--type instance XApplicativeArgMany (GhcPass _) = NoExtField-type instance XXApplicativeArg    (GhcPass _) = DataConCantHappen--instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),-          Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))-        => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where-  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts--instance (OutputableBndrId pl, OutputableBndrId pr,-                 Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,-          Outputable body)-         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where-    ppr stmt = pprStmt stmt--pprStmt :: forall idL idR body . (OutputableBndrId idL,-                                  OutputableBndrId idR,-                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,-                                  Outputable body)-        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc-pprStmt (LastStmt _ expr m_dollar_stripped _)-  = whenPprDebug (text "[last]") <+>-      (case m_dollar_stripped of-        Just True -> text "return $"-        Just False -> text "return"-        Nothing -> empty) <+>-      ppr expr-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 (TransStmt { trS_stmts = stmts, trS_by = by-                   , trS_using = using, trS_form = form })-  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])--pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids-                 , recS_later_ids = later_ids })-  = text "rec" <+>-    vcat [ ppr_do_stmts (unLoc segment)-         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids-                            , text "later_ids=" <> ppr later_ids])]--pprStmt (ApplicativeStmt _ args mb_join)-  = getPprStyle $ \style ->-      if userStyle style-         then pp_for_user-         else pp_debug-  where-  -- make all the Applicative stuff invisible in error messages by-  -- flattening the whole ApplicativeStmt nest back to a sequence-  -- of statements.-   pp_for_user = vcat $ concatMap flattenArg args--   -- ppr directly rather than transforming here, because we need to-   -- inject a "return" which is hard when we're polymorphic in the id-   -- type.-   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]-   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args-   flattenStmt stmt = [ppr stmt]--   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]-   flattenArg (_, ApplicativeArgOne _ pat expr isBody)-     | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]-     | otherwise = [pprBindStmt pat expr]-   flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =-     concatMap flattenStmt stmts--   pp_debug =-     let-         ap_expr = sep (punctuate (text " |") (map pp_arg args))-     in-       whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>-       (if lengthAtLeast args 2 then parens else id) ap_expr--   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc-   pp_arg (_, applicativeArg) = ppr applicativeArg--pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc-pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]--instance (OutputableBndrId idL)-      => Outputable (ApplicativeArg (GhcPass idL)) where-  ppr = pprArg--pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc-pprArg (ApplicativeArgOne _ pat expr isBody)-  | isBody = ppr expr -- See Note [Applicative BodyStmt]-  | otherwise = pprBindStmt pat expr-pprArg (ApplicativeArgMany _ stmts return pat ctxt) =-     ppr pat <+>-     text "<-" <+>-     pprDo ctxt (stmts ++-                   [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])--pprTransformStmt :: (OutputableBndrId p)-                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)-                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc-pprTransformStmt bndrs using by-  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))-        , nest 2 (ppr using)-        , nest 2 (pprBy by)]--pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc-pprTransStmt by using ThenForm-  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]-pprTransStmt by using GroupForm-  = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)]--pprBy :: Outputable body => Maybe body -> SDoc-pprBy Nothing  = empty-pprBy (Just e) = text "by" <+> ppr e--pprDo :: (OutputableBndrId p, Outputable body,-                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA-         )-      => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc-pprDo (DoExpr m)    stmts =-  ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts-pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts-pprDo (MDoExpr m)   stmts =-  ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts-pprDo ListComp      stmts = brackets    $ pprComp stmts-pprDo MonadComp     stmts = brackets    $ pprComp stmts--pprArrowExpr :: (OutputableBndrId p, Outputable body,-                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA-         )-      => [LStmt (GhcPass p) body] -> SDoc-pprArrowExpr stmts = text "do"  <+> ppr_do_stmts stmts--ppr_module_name_prefix :: Maybe ModuleName -> SDoc-ppr_module_name_prefix = \case-  Nothing -> empty-  Just module_name -> ppr module_name <> char '.'--ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,-                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,-                 Outputable body)-             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc--- Print a bunch of do stmts-ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)--pprComp :: (OutputableBndrId p, Outputable body,-                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)-        => [LStmt (GhcPass p) body] -> SDoc-pprComp quals     -- Prints:  body | qual1, ..., qualn-  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals-  = if null initStmts-       -- If there are no statements in a list comprehension besides the last-       -- one, we simply treat it like a normal list. This does arise-       -- occasionally in code that GHC generates, e.g., in implementations of-       -- 'range' for derived 'Ix' instances for product datatypes with exactly-       -- one constructor (e.g., see #12583).-       then ppr body-       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)-  | otherwise-  = pprPanic "pprComp" (pprQuals quals)--pprQuals :: (OutputableBndrId p, Outputable body,-                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)-         => [LStmt (GhcPass p) body] -> SDoc--- Show list comprehension qualifiers separated by commas-pprQuals quals = interpp'SP quals--{--************************************************************************-*                                                                      *-                Template Haskell quotation brackets-*                                                                      *-************************************************************************--}---- | Finalizers produced by a splice with--- 'Language.Haskell.TH.Syntax.addModFinalizer'------ See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how--- this is used.----newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]---- A Data instance which ignores the argument of 'ThModFinalizers'.-instance Data ThModFinalizers where-  gunfold _ z _ = z $ ThModFinalizers []-  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix-  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]---- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.--- This is the result of splicing a splice. It is produced by--- the renamer and consumed by the typechecker. It lives only between the two.-data HsUntypedSpliceResult thing  -- 'thing' can be HsExpr or HsType-  = HsUntypedSpliceTop-      { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice.-      , utsplice_result            :: thing           -- ^ The result of splicing; See Note [Lifecycle of a splice]-      }-  | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point--type instance XTypedSplice   GhcPs = (EpAnnCO, EpAnn [AddEpAnn])-type instance XTypedSplice   GhcRn = SplicePointName-type instance XTypedSplice   GhcTc = DelayedSplice--type instance XUntypedSplice GhcPs = EpAnnCO-type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn)-type instance XUntypedSplice GhcTc = DataConCantHappen---- HsUntypedSplice-type instance XUntypedSpliceExpr GhcPs = EpAnn [AddEpAnn]-type instance XUntypedSpliceExpr GhcRn = EpAnn [AddEpAnn]-type instance XUntypedSpliceExpr GhcTc = DataConCantHappen--type instance XQuasiQuote        p = NoExtField--type instance XXUntypedSplice    p = DataConCantHappen---- See Note [Running typed splices in the zonker]--- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice`-data DelayedSplice =-  DelayedSplice-    TcLclEnv          -- The local environment to run the splice in-    (LHsExpr GhcRn)   -- The original renamed expression-    TcType            -- The result type of running the splice, unzonked-    (LHsExpr GhcTc)   -- The typechecked expression to run and splice in the result---- A Data instance which ignores the argument of 'DelayedSplice'.-instance Data DelayedSplice where-  gunfold _ _ _ = panic "DelayedSplice"-  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix-  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]---- See Note [Pending Splices]-type SplicePointName = Name--data UntypedSpliceFlavour-  = UntypedExpSplice-  | UntypedPatSplice-  | UntypedTypeSplice-  | UntypedDeclSplice-  deriving Data---- | Pending Renamer Splice-data PendingRnSplice-  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)---- | Pending Type-checker Splice-data PendingTcSplice-  = PendingTcSplice SplicePointName (LHsExpr GhcTc)---pprPendingSplice :: (OutputableBndrId p)-                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))--pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprTypedSplice n e = ppr_splice (text "$$") n e--pprUntypedSplice :: forall p. (OutputableBndrId p)-                 => Bool -- Whether to precede the splice with "$"-                 -> Maybe SplicePointName -- Used for pretty printing when exists-                 -> HsUntypedSplice (GhcPass p)-                 -> 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)--ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc-ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <>-                           ppr quote <> text "|]"--ppr_splice :: (OutputableBndrId p)-           => SDoc-           -> Maybe SplicePointName-           -> LHsExpr (GhcPass p)-           -> SDoc-ppr_splice herald mn e-    = herald-    <> (case mn of-         Nothing -> empty-         Just splice_name -> whenPprDebug (brackets (ppr splice_name)))-    <> ppr e---type instance XExpBr  GhcPs       = NoExtField-type instance XPatBr  GhcPs       = NoExtField-type instance XDecBrL GhcPs       = NoExtField-type instance XDecBrG GhcPs       = NoExtField-type instance XTypBr  GhcPs       = NoExtField-type instance XVarBr  GhcPs       = NoExtField-type instance XXQuote GhcPs       = DataConCantHappen--type instance XExpBr  GhcRn       = NoExtField-type instance XPatBr  GhcRn       = NoExtField-type instance XDecBrL GhcRn       = NoExtField-type instance XDecBrG GhcRn       = NoExtField-type instance XTypBr  GhcRn       = NoExtField-type instance XVarBr  GhcRn       = NoExtField-type instance XXQuote GhcRn       = DataConCantHappen---- See Note [The life cycle of a TH quotation]-type instance XExpBr  GhcTc       = DataConCantHappen-type instance XPatBr  GhcTc       = DataConCantHappen-type instance XDecBrL GhcTc       = DataConCantHappen-type instance XDecBrG GhcTc       = DataConCantHappen-type instance XTypBr  GhcTc       = DataConCantHappen-type instance XVarBr  GhcTc       = DataConCantHappen-type instance XXQuote GhcTc       = NoExtField--instance OutputableBndrId p-          => Outputable (HsQuote (GhcPass p)) where-  ppr = pprHsQuote-    where-      pprHsQuote :: forall p. (OutputableBndrId p)-                   => HsQuote (GhcPass p) -> SDoc-      pprHsQuote (ExpBr _ e)   = thBrackets empty (ppr e)-      pprHsQuote (PatBr _ p)   = thBrackets (char 'p') (ppr p)-      pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)-      pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))-      pprHsQuote (TypBr _ t)   = thBrackets (char 't') (ppr t)-      pprHsQuote (VarBr _ True n)-        = char '\'' <> pprPrefixOcc (unLoc n)-      pprHsQuote (VarBr _ False n)-        = text "''" <> pprPrefixOcc (unLoc n)-      pprHsQuote (XQuote b)  = case ghcPass @p of-#if __GLASGOW_HASKELL__ <= 900-          GhcPs -> dataConCantHappen b-          GhcRn -> dataConCantHappen b-#endif-          GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)-                   -- See Note [The life cycle of a TH quotation]--thBrackets :: SDoc -> SDoc -> SDoc-thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>-                             pp_body <+> text "|]"--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_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--{--************************************************************************-*                                                                      *-\subsection{Enumerations and list comprehensions}-*                                                                      *-************************************************************************--}--instance OutputableBndrId p-         => Outputable (ArithSeqInfo (GhcPass p)) where-    ppr (From e1)             = hcat [ppr e1, pp_dotdot]-    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]-    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]-    ppr (FromThenTo e1 e2 e3)-      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]--pp_dotdot :: SDoc-pp_dotdot = text " .. "--{--************************************************************************-*                                                                      *-\subsection{HsMatchCtxt}-*                                                                      *-************************************************************************--}--instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where-  ppr m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)-  ppr LambdaExpr              = text "LambdaExpr"-  ppr CaseAlt                 = text "CaseAlt"-  ppr (LamCaseAlt lc_variant) = text "LamCaseAlt" <+> ppr lc_variant-  ppr IfAlt                   = text "IfAlt"-  ppr (ArrowMatchCtxt c)      = text "ArrowMatchCtxt" <+> ppr c-  ppr PatBindRhs              = text "PatBindRhs"-  ppr PatBindGuards           = text "PatBindGuards"-  ppr RecUpd                  = text "RecUpd"-  ppr (StmtCtxt _)            = text "StmtCtxt _"-  ppr ThPatSplice             = text "ThPatSplice"-  ppr ThPatQuote              = text "ThPatQuote"-  ppr PatSyn                  = text "PatSyn"--instance Outputable LamCaseVariant where-  ppr = text . \case-    LamCase  -> "LamCase"-    LamCases -> "LamCases"--lamCaseKeyword :: LamCaseVariant -> SDoc-lamCaseKeyword LamCase  = text "\\case"-lamCaseKeyword LamCases = text "\\cases"--pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc-pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))-  = ppr (src,(n1,n2),(n3,n4))--instance Outputable HsArrowMatchContext where-  ppr ProcExpr                     = text "ProcExpr"-  ppr ArrowCaseAlt                 = text "ArrowCaseAlt"-  ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant-  ppr KappaExpr                    = text "KappaExpr"--pprHsArrType :: HsArrAppType -> SDoc-pprHsArrType HsHigherOrderApp = text "higher order arrow application"-pprHsArrType HsFirstOrderApp  = text "first order arrow application"---------------------instance OutputableBndrId p-      => Outputable (HsStmtContext (GhcPass p)) where-    ppr = pprStmtContext---- Used to generate the string for a *runtime* error message-matchContextErrString :: OutputableBndrId p-                      => HsMatchContext (GhcPass p) -> SDoc-matchContextErrString (FunRhs{mc_fun=L _ fun})      = text "function" <+> ppr fun-matchContextErrString CaseAlt                       = text "case"-matchContextErrString (LamCaseAlt lc_variant)       = lamCaseKeyword lc_variant-matchContextErrString IfAlt                         = text "multi-way if"-matchContextErrString PatBindRhs                    = text "pattern binding"-matchContextErrString PatBindGuards                 = text "pattern binding guards"-matchContextErrString RecUpd                        = text "record update"-matchContextErrString LambdaExpr                    = text "lambda"-matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c-matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString PatSyn                        = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"-matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block"-matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour--matchArrowContextErrString :: HsArrowMatchContext -> SDoc-matchArrowContextErrString ProcExpr                     = text "proc"-matchArrowContextErrString ArrowCaseAlt                 = text "case"-matchArrowContextErrString (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-matchArrowContextErrString KappaExpr                    = text "kappa"--matchDoContextErrString :: HsDoFlavour -> SDoc-matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"-matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")-matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")-matchDoContextErrString ListComp     = text "list comprehension"-matchDoContextErrString MonadComp    = text "monad comprehension"--pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)-               => Match (GhcPass idR) body -> SDoc-pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)-                                        <> colon)-                             4 (pprMatch match)--pprStmtInCtxt :: (OutputableBndrId idL,-                  OutputableBndrId idR,-                  OutputableBndrId ctx,-                  Outputable body,-                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)-              => HsStmtContext (GhcPass ctx)-              -> StmtLR (GhcPass idL) (GhcPass idR) body-              -> SDoc-pprStmtInCtxt ctxt (LastStmt _ e _ _)-  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"-  = hang (text "In the expression:") 2 (ppr e)--pprStmtInCtxt ctxt stmt-  = 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--matchSeparator :: HsMatchContext p -> SDoc-matchSeparator FunRhs{}         = text "="-matchSeparator CaseAlt          = text "->"-matchSeparator LamCaseAlt{}     = text "->"-matchSeparator IfAlt            = text "->"-matchSeparator LambdaExpr       = text "->"-matchSeparator ArrowMatchCtxt{} = text "->"-matchSeparator PatBindRhs       = text "="-matchSeparator PatBindGuards    = text "="-matchSeparator StmtCtxt{}       = text "<-"-matchSeparator RecUpd           = text "=" -- This can be printed by the pattern-                                       -- match checker trace-matchSeparator ThPatSplice  = panic "unused"-matchSeparator ThPatQuote   = panic "unused"-matchSeparator PatSyn       = panic "unused"--pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                => HsMatchContext p -> SDoc-pprMatchContext ctxt-  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt-  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt-  where-    want_an (FunRhs {})                = True  -- Use "an" in front-    want_an (ArrowMatchCtxt ProcExpr)  = True-    want_an (ArrowMatchCtxt KappaExpr) = True-    want_an _                          = False--pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                    => HsMatchContext p -> SDoc-pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for"-                                                <+> quotes (ppr (unXRec @(NoGhcTc p) fun))-pprMatchContextNoun CaseAlt                 = text "case alternative"-pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant-                                              <+> text "alternative"-pprMatchContextNoun IfAlt                   = text "multi-way if alternative"-pprMatchContextNoun RecUpd                  = text "record-update construct"-pprMatchContextNoun ThPatSplice             = text "Template Haskell pattern splice"-pprMatchContextNoun ThPatQuote              = text "Template Haskell pattern quotation"-pprMatchContextNoun PatBindRhs              = text "pattern binding"-pprMatchContextNoun PatBindGuards           = text "pattern binding guards"-pprMatchContextNoun LambdaExpr              = text "lambda abstraction"-pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c-pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"-                                              $$ pprAStmtContext ctxt-pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"--pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                     => HsMatchContext p -> SDoc-pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for"-                                               <+> quotes (ppr (unXRec @(NoGhcTc p) fun))-pprMatchContextNouns PatBindGuards           = text "pattern binding guards"-pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c-pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"-                                               $$ pprAStmtContext ctxt-pprMatchContextNouns ctxt                    = pprMatchContextNoun ctxt <> char 's'--pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc-pprArrowMatchContextNoun ProcExpr                     = text "arrow proc pattern"-pprArrowMatchContextNoun ArrowCaseAlt                 = text "case alternative within arrow notation"-pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-                                                        <+> text "alternative within arrow notation"-pprArrowMatchContextNoun KappaExpr                    = text "arrow kappa abstraction"--pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc-pprArrowMatchContextNouns ArrowCaseAlt                 = text "case alternatives within arrow notation"-pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-                                                         <+> text "alternatives within arrow notation"-pprArrowMatchContextNouns ctxt                         = pprArrowMatchContextNoun ctxt <> char 's'--------------------pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                                => HsStmtContext p -> SDoc-pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour-pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt--------------------pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour-pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt-pprStmtContext ArrowExpr       = text "'do' block in an arrow command"---- Drop the inner contexts when reporting errors, else we get---     Unexpected transform statement---     in a transformed branch of---          transformed branch of---          transformed branch of monad comprehension-pprStmtContext (ParStmtCtxt c) =-  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])-             (pprStmtContext c)-pprStmtContext (TransStmtCtxt c) =-  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])-             (pprStmtContext c)--pprStmtCat :: Stmt (GhcPass p) body -> SDoc-pprStmtCat (TransStmt {})       = text "transform"-pprStmtCat (LastStmt {})        = text "return expression"-pprStmtCat (BodyStmt {})        = text "body"-pprStmtCat (BindStmt {})        = text "binding"-pprStmtCat (LetStmt {})         = text "let"-pprStmtCat (RecStmt {})         = text "rec"-pprStmtCat (ParStmt {})         = text "parallel"-pprStmtCat (ApplicativeStmt {}) = text "applicative"--pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc-pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour-  where-    pp_an = text "an"-    pp_a  = text "a"-    article = case flavour of-                  MDoExpr Nothing -> pp_an-                  GhciStmtCtxt  -> pp_an-                  _             -> pp_a-pprHsDoFlavour (DoExpr m)      = prependQualified m (text "'do' block")-pprHsDoFlavour (MDoExpr m)     = prependQualified m (text "'mdo' block")-pprHsDoFlavour ListComp        = text "list comprehension"-pprHsDoFlavour MonadComp       = text "monad comprehension"-pprHsDoFlavour GhciStmtCtxt    = text "interactive GHCi command"--prependQualified :: Maybe ModuleName -> SDoc -> SDoc-prependQualified Nothing  t = t-prependQualified (Just _) t = text "qualified" <+> t--{--************************************************************************-*                                                                      *-FieldLabelStrings-*                                                                      *-************************************************************************--}--instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where-  ppr (FieldLabelStrings flds) =-    hcat (punctuate dot (map (ppr . unXRec @p) flds))--instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where-  pprInfixOcc = pprFieldLabelStrings-  pprPrefixOcc = pprFieldLabelStrings--instance (UnXRec p,  Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where-  pprInfixOcc = pprInfixOcc . unLoc-  pprPrefixOcc = pprInfixOcc . unLoc--pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc-pprFieldLabelStrings (FieldLabelStrings flds) =-    hcat (punctuate dot (map (ppr . unXRec @p) flds))--pprPrefixFastString :: FastString -> SDoc-pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)--instance UnXRec p => Outputable (DotFieldOcc p) where-  ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s-  ppr XDotFieldOcc{} = text "XDotFieldOcc"--{--************************************************************************-*                                                                      *-\subsection{Anno instances}-*                                                                      *-************************************************************************--}--type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA-type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL-type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL--type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA--type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]-  = SrcSpanAnnL-type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL-type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnL-type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA-type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA-type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns-type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcAnn NoEpAnns-type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA--type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA--type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnL--type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno FieldLabelString                = SrcSpanAnnN--type instance Anno FastString                      = SrcAnn NoEpAnns-  -- Used in HsQuasiQuote and perhaps elsewhere--type instance Anno (DotFieldOcc (GhcPass p))       = SrcAnn NoEpAnns--instance (Anno a ~ SrcSpanAnn' (EpAnn an))+import GHC.Hs.Basic() -- import instances+import GHC.Hs.Decls() -- import instances+import GHC.Hs.Pat+import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Basic (FieldLabelString(..))+import GHC.Hs.Extension+import GHC.Hs.Type+import GHC.Hs.Binds+import GHC.Parser.Annotation++-- others:+import GHC.Tc.Types.Evidence+import GHC.Types.Id.Info ( RecSelParent )+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+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+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Core.Type+import GHC.Builtin.Types (mkTupleStr)+import GHC.Tc.Utils.TcType (TcType, TcTyVar)+import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)++import GHCi.RemoteTypes ( ForeignRef )+import qualified GHC.Boot.TH.Syntax as TH (Q)++-- libraries:+import Data.Data hiding (Fixity(..))+import qualified Data.Data as Data (Fixity(..))+import qualified Data.Kind+import Data.Maybe (isJust)+import Data.Foldable ( toList )+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Void (Void)+import qualified Data.Set as S+{- *********************************************************************+*                                                                      *+                Expressions proper+*                                                                      *+********************************************************************* -}++-- | Post-Type checking Expression+--+-- PostTcExpr is an evidence expression attached to the syntax tree by the+-- type checker (c.f. postTcType).+type PostTcExpr  = HsExpr GhcTc++-- | Post-Type checking Table+--+-- We use a PostTcTable where there are a bunch of pieces of evidence, more+-- than is convenient to keep individually.+type PostTcTable = [(Name, PostTcExpr)]++-------------------------++-- Defining SyntaxExpr in two stages allows for better type inference, because+-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,+-- noSyntaxExpr would be ambiguous.+type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p++type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where+  SyntaxExprGhc 'Parsed      = NoExtField+  SyntaxExprGhc 'Renamed     = SyntaxExprRn+  SyntaxExprGhc 'Typechecked = SyntaxExprTc++-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].+data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)+    -- Why is the payload not just a Name?+    -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+                  | NoSyntaxExprRn++-- | An expression with wrappers, used for rebindable syntax+--+-- This should desugar to+--+-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)+-- >                         (syn_arg_wraps[1] arg1) ...+--+-- where the actual arguments come from elsewhere in the AST.+data SyntaxExprTc = SyntaxExprTc { syn_expr      :: HsExpr GhcTc+                                 , syn_arg_wraps :: [HsWrapper]+                                 , syn_res_wrap  :: HsWrapper }+                  | NoSyntaxExprTc  -- See Note [NoSyntaxExpr]++-- | This is used for rebindable-syntax pieces that are too polymorphic+-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)+noExpr :: HsExpr (GhcPass p)+noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))++noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)+                              -- Before renaming, and sometimes after+                              -- See Note [NoSyntaxExpr]+noSyntaxExpr = case ghcPass @p of+  GhcPs -> noExtField+  GhcRn -> NoSyntaxExprRn+  GhcTc -> NoSyntaxExprTc++-- | Make a 'SyntaxExpr GhcRn' from an expression+-- Used only in getMonadFailOp.+-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn+mkSyntaxExpr = SyntaxExprRn++instance Outputable SyntaxExprRn where+  ppr (SyntaxExprRn expr) = ppr expr+  ppr NoSyntaxExprRn      = text "<no syntax expr>"++instance Outputable SyntaxExprTc where+  ppr (SyntaxExprTc { syn_expr      = expr+                    , syn_arg_wraps = arg_wraps+                    , syn_res_wrap  = res_wrap })+    = sdocOption sdocPrintExplicitCoercions $ \print_co ->+      getPprDebug $ \debug ->+      if debug || print_co+      then ppr expr <> braces (pprWithCommas ppr arg_wraps)+                    <> braces (ppr res_wrap)+      else ppr expr++  ppr NoSyntaxExprTc = text "<no syntax expr>"++-- | HsWrap appears only in typechecker output+data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper+                            (hs_syn GhcTc) -- the thing that is wrapped++deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)++-- ---------------------------------------------------------------------++data HsBracketTc = HsBracketTc+  { hsb_quote   :: HsQuote GhcRn        -- See Note [The life cycle of a TH quotation]+  , hsb_ty      :: Type+  , hsb_wrap    :: Maybe QuoteWrapper   -- The wrapper to apply type and dictionary argument to the quote.+  , hsb_splices :: [PendingTcSplice]    -- Output of the type checker is the *original*+                                        -- renamed expression, plus+                                        -- _typechecked_ splices to be+                                        -- pasted back in by the desugarer+  }++type instance XTypedBracket GhcPs = (BracketAnn (EpToken "[||") (EpToken "[e||"), EpToken "||]")+type instance XTypedBracket GhcRn = NoExtField+type instance XTypedBracket GhcTc = HsBracketTc+type instance XUntypedBracket GhcPs = NoExtField+type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]+                                                        -- Output of the renamer is the *original* renamed expression,+                                                        -- plus _renamed_ splices to be type checked+type instance XUntypedBracket GhcTc = HsBracketTc++data BracketAnn noE hasE+  = BracketNoE noE+  | BracketHasE hasE+  deriving Data++instance (NoAnn n, NoAnn h) => NoAnn (BracketAnn n h) where+  noAnn = BracketNoE noAnn++-- ---------------------------------------------------------------------++-- API Annotations types++data EpAnnHsCase = EpAnnHsCase+      { hsCaseAnnCase :: EpToken "case"+      , hsCaseAnnOf   :: EpToken "of"+      } deriving Data++instance NoAnn EpAnnHsCase where+  noAnn = EpAnnHsCase noAnn noAnn++data EpAnnLam = EpAnnLam+      { epl_lambda :: EpToken "\\"      -- ^ Location of '\' keyword+      , epl_case   :: Maybe EpaLocation -- ^ Location of 'case' or+                                        -- 'cases' keyword, depending+                                        -- on related 'HsLamVariant'.+      } deriving Data++instance NoAnn EpAnnLam where+  noAnn = EpAnnLam noAnn noAnn++-- Record selectors at parse time are HsVar; they convert to HsRecSel+-- on renaming.+type instance XRecSel              GhcPs = DataConCantHappen+type instance XRecSel              GhcRn = NoExtField+type instance XRecSel              GhcTc = NoExtField++-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOverLabel     GhcPs = SourceText+type instance XOverLabel     GhcRn = SourceText+type instance XOverLabel     GhcTc = DataConCantHappen++-- ---------------------------------------------------------------------++type instance XVar           (GhcPass _) = NoExtField++type instance XIPVar         GhcPs = NoExtField+type instance XIPVar         GhcRn = NoExtField+type instance XIPVar         GhcTc = DataConCantHappen+type instance XOverLitE      (GhcPass _) = NoExtField+type instance XLitE          (GhcPass _) = NoExtField+type instance XLam           (GhcPass _) = EpAnnLam+type instance XApp           (GhcPass _) = NoExtField++type instance XAppTypeE      GhcPs = EpToken "@"+type instance XAppTypeE      GhcRn = NoExtField+type instance XAppTypeE      GhcTc = Type++-- OpApp not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOpApp         GhcPs = NoExtField+type instance XOpApp         GhcRn = Fixity+type instance XOpApp         GhcTc = DataConCantHappen++-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XSectionL      GhcPs = NoExtField+type instance XSectionR      GhcPs = NoExtField+type instance XSectionL      GhcRn = NoExtField+type instance XSectionR      GhcRn = NoExtField+type instance XSectionL      GhcTc = DataConCantHappen+type instance XSectionR      GhcTc = DataConCantHappen+++type instance XNegApp        GhcPs = EpToken "-"+type instance XNegApp        GhcRn = NoExtField+type instance XNegApp        GhcTc = NoExtField++type instance XPar           GhcPs = (EpToken "(", EpToken ")")+type instance XPar           GhcRn = NoExtField+type instance XPar           GhcTc = NoExtField++type instance XExplicitTuple GhcPs = (EpaLocation, EpaLocation)+type instance XExplicitTuple GhcRn = NoExtField+type instance XExplicitTuple GhcTc = NoExtField++type instance XExplicitSum   GhcPs = AnnExplicitSum+type instance XExplicitSum   GhcRn = NoExtField+type instance XExplicitSum   GhcTc = [Type]++type instance XCase          GhcPs = EpAnnHsCase+type instance XCase          GhcRn = HsMatchContextRn+type instance XCase          GhcTc = HsMatchContextRn++type instance XIf            GhcPs = AnnsIf+type instance XIf            GhcRn = NoExtField+type instance XIf            GhcTc = NoExtField++type instance XMultiIf       GhcPs = (EpToken "if", EpToken "{", EpToken "}")+type instance XMultiIf       GhcRn = NoExtField+type instance XMultiIf       GhcTc = Type++type instance XLet           GhcPs = (EpToken "let", EpToken "in")+type instance XLet           GhcRn = NoExtField+type instance XLet           GhcTc = NoExtField++type instance XDo            GhcPs = AnnList EpaLocation+type instance XDo            GhcRn = NoExtField+type instance XDo            GhcTc = Type++type instance XExplicitList  GhcPs = AnnList ()+type instance XExplicitList  GhcRn = NoExtField+type instance XExplicitList  GhcTc = Type+-- GhcPs: ExplicitList includes all source-level+--   list literals, including overloaded ones+-- GhcRn and GhcTc: ExplicitList used only for list literals+--   that denote Haskell's built-in lists.  Overloaded lists+--   have been expanded away in the renamer+-- See Note [Handling overloaded and rebindable constructs]+-- in  GHC.Rename.Expr++type instance XRecordCon     GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XRecordCon     GhcRn = NoExtField+type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function++type instance XRecordUpd     GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XRecordUpd     GhcRn = NoExtField+type instance XRecordUpd     GhcTc = DataConCantHappen+  -- We desugar record updates in the typechecker.+  -- See [Handling overloaded and rebindable constructs],+  -- and [Record Updates] in GHC.Tc.Gen.Expr.++-- | Information about the parent of a record update:+--+--  - the parent type constructor or pattern synonym,+--  - the relevant con-likes,+--  - the field labels.+data family HsRecUpdParent x++data instance HsRecUpdParent GhcPs+data instance HsRecUpdParent GhcRn+  = RnRecUpdParent+  { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt+  , rnRecUpdCons   :: UniqSet ConLikeName }+data instance HsRecUpdParent GhcTc+  = TcRecUpdParent+  { tcRecUpdParent :: RecSelParent+  , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt+  , tcRecUpdCons   :: UniqSet ConLike }++type instance XLHsRecUpdLabels GhcPs = NoExtField+type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn)+                                      -- Possible parents for the record update.+type instance XLHsRecUpdLabels GhcTc = DataConCantHappen++type instance XLHsOLRecUpdLabels p = NoExtField++type instance XGetField     GhcPs = NoExtField+type instance XGetField     GhcRn = NoExtField+type instance XGetField     GhcTc = DataConCantHappen+-- HsGetField is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XProjection     GhcPs = AnnProjection+type instance XProjection     GhcRn = NoExtField+type instance XProjection     GhcTc = DataConCantHappen+-- HsProjection is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XExprWithTySig GhcPs = TokDcolon+type instance XExprWithTySig GhcRn = NoExtField+type instance XExprWithTySig GhcTc = NoExtField++type instance XArithSeq      GhcPs = AnnArithSeq+type instance XArithSeq      GhcRn = NoExtField+type instance XArithSeq      GhcTc = PostTcExpr++type instance XProc          (GhcPass _) = (EpToken "proc", TokRarrow)++type instance XStatic        GhcPs = EpToken "static"+type instance XStatic        GhcRn = NameSet+type instance XStatic        GhcTc = (NameSet, Type)+  -- Free variables and type of expression, this is stored for convenience as wiring in+  -- StaticPtr is a bit tricky (see #20150)++type instance XEmbTy         GhcPs = EpToken "type"+type instance XEmbTy         GhcRn = NoExtField+type instance XEmbTy         GhcTc = DataConCantHappen+  -- 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++type instance XQual          GhcPs = NoExtField+type instance XQual          GhcRn = NoExtField+type instance XQual          GhcTc = DataConCantHappen++type instance XFunArr        GhcPs = NoExtField+type instance XFunArr        GhcRn = NoExtField+type instance XFunArr        GhcTc = DataConCantHappen++type instance XPragE         (GhcPass _) = NoExtField++type instance XFunRhs  = AnnFunRhs++type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW+type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA++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,+      aesBarsBefore :: [EpToken "|"],+      aesBarsAfter  :: [EpToken "|"],+      aesClose      :: EpaLocation+      } deriving Data++instance NoAnn AnnExplicitSum where+  noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn++data AnnFieldLabel+  = AnnFieldLabel {+      afDot :: Maybe (EpToken ".")+      } deriving Data++instance NoAnn AnnFieldLabel where+  noAnn = AnnFieldLabel Nothing++data AnnProjection+  = AnnProjection {+      apOpen  :: EpToken "(",+      apClose :: EpToken ")"+      } deriving Data++instance NoAnn AnnProjection where+  noAnn = AnnProjection noAnn noAnn++data AnnArithSeq+  = AnnArithSeq {+      aas_open   :: EpToken "[",+      aas_comma  :: Maybe (EpToken ","),+      aas_dotdot :: EpToken "..",+      aas_close  :: EpToken "]"+      } deriving Data++instance NoAnn AnnArithSeq where+  noAnn = AnnArithSeq noAnn noAnn noAnn noAnn++data AnnsIf+  = AnnsIf {+      aiIf       :: EpToken "if",+      aiThen     :: EpToken "then",+      aiElse     :: EpToken "else",+      aiThenSemi :: Maybe (EpToken ";"),+      aiElseSemi :: Maybe (EpToken ";")+      } deriving Data++instance NoAnn AnnsIf where+  noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing++data AnnFunRhs+  = AnnFunRhs {+       afr_strict :: EpToken "!",+       afr_opens  :: [EpToken "("],+       afr_closes :: [EpToken ")"]+  } deriving Data++instance NoAnn AnnFunRhs where+  noAnn = AnnFunRhs noAnn noAnn noAnn++-- ---------------------------------------------------------------------++type instance XSCC           (GhcPass _) = (AnnPragma, SourceText)+type instance XXPragE        (GhcPass _) = DataConCantHappen++type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel+type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen++type instance XPresent         (GhcPass _) = NoExtField++type instance XMissing         GhcPs = EpAnn Bool -- True for empty last comma+type instance XMissing         GhcRn = NoExtField+type instance XMissing         GhcTc = Scaled Type++type instance XXTupArg         (GhcPass _) = DataConCantHappen++tupArgPresent :: HsTupArg (GhcPass p) -> Bool+tupArgPresent (Present {}) = True+tupArgPresent (Missing {}) = False++tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p))+tupArgPresent_maybe (Present _ e) = Just e+tupArgPresent_maybe (Missing {})  = Nothing++tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]+tupArgsPresent_maybe = traverse tupArgPresent_maybe+++{- *********************************************************************+*                                                                      *+            XXExpr: the extension constructor of HsExpr+*                                                                      *+********************************************************************* -}++type instance XXExpr GhcPs = DataConCantHappen+type instance XXExpr GhcRn = XXExprGhcRn+type instance XXExpr GhcTc = XXExprGhcTc+-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below+++{- *********************************************************************+*                                                                      *+              Generating code for ExpandedThingRn+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++-- | The different source constructs that we use to instantiate the "original" field+--   in an `XXExprGhcRn original expansion`+data HsThingRn = OrigExpr (HsExpr GhcRn)+               | OrigStmt (ExprLStmt GhcRn)+               | OrigPat  (LPat GhcRn)++isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool+isHsThingRnExpr (OrigExpr{}) = True+isHsThingRnExpr _ = False++isHsThingRnStmt (OrigStmt{}) = True+isHsThingRnStmt _ = False++isHsThingRnPat (OrigPat{}) = True+isHsThingRnPat _ = False++data XXExprGhcRn+  = ExpandedThingRn { xrn_orig     :: HsThingRn       -- The original source thing+                    , xrn_expanded :: HsExpr GhcRn }  -- The compiler generated expanded thing++  | PopErrCtxt                                     -- A hint for typechecker to pop+    {-# UNPACK #-} !(LHsExpr GhcRn)                -- the top of the error context stack+                                                   -- Does not presist post renaming phase+                                                   -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]+                                                   -- in `GHC.Tc.Gen.Do`+  | HsRecSelRn  (FieldOcc GhcRn)   -- ^ Variable pointing to record selector+                           -- See Note [Non-overloaded record field selectors] and+                           -- Note [Record selectors in the AST]++++-- | Wrap a located expression with a `PopErrCtxt`+mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)++-- | Wrap a located expression with a PopSrcExpr with an appropriate location+mkPopErrCtxtExprAt :: SrcSpanAnnA ->  LHsExpr GhcRn -> LHsExpr GhcRn+mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original expression and+--   expanded expressions.+mkExpandedExpr+  :: HsExpr GhcRn         -- ^ source expression+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression+mkExpandedStmt+  :: ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)++mkExpandedPatRn+  :: LPat   GhcRn      -- ^ source pattern+  -> HsExpr GhcRn      -- ^ expanded expression+  -> HsExpr GhcRn      -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression an associate with a provided location+mkExpandedStmtAt+  :: SrcSpanAnnA          -- ^ Location for the expansion expression+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped located 'XXExprGhcRn'+mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr++-- | Wrap the expanded version of the expression with a pop.+mkExpandedStmtPopAt+  :: SrcSpanAnnA          -- ^ Location for the expansion statement+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr+++data XXExprGhcTc+  = WrapExpr        -- Type and evidence application and abstractions+      HsWrapper (HsExpr GhcTc)++  | ExpandedThingTc                         -- See Note [Rebindable syntax and XXExprGhcRn]+                                            -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+         { xtc_orig     :: HsThingRn        -- The original user written thing+         , xtc_expanded :: HsExpr GhcTc }   -- The expanded typechecked expression++  | ConLikeTc      -- Result of typechecking a data-con+                   -- See Note [Typechecking data constructors] in+                   --     GHC.Tc.Gen.Head+                   -- The two arguments describe how to eta-expand+                   -- the data constructor when desugaring+        ConLike [TcTyVar] [Scaled TcType]++  ---------------------------------------+  -- Haskell program coverage (Hpc) Support++  | HsTick+     CoreTickish+     (LHsExpr GhcTc)                    -- sub-expression++  | HsBinTick+     Int                                -- module-local tick number for True+     Int                                -- module-local tick number for False+     (LHsExpr GhcTc)                    -- sub-expression++  | HsRecSelTc  (FieldOcc GhcTc) -- ^ Variable pointing to record selector+                             -- See Note [Non-overloaded record field selectors] and+                             -- Note [Record selectors in the AST]+++-- | Build a 'XXExprGhcRn' out of an extension constructor,+--   and the two components of the expansion: original and+--   expanded typechecked expressions.+mkExpandedExprTc+  :: HsExpr GhcRn           -- ^ source expression+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)++-- | Build a 'XXExprGhcRn' out of an extension constructor.+--   The two components of the expansion are: original statement and+--   expanded typechecked expression.+mkExpandedStmtTc+  :: ExprLStmt GhcRn        -- ^ source do statement+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)++{- *********************************************************************+*                                                                      *+            Pretty-printing expressions+*                                                                      *+********************************************************************* -}++instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where+    ppr expr = pprExpr expr++-----------------------+-- pprExpr, pprLExpr, pprBinds call pprDeeper;+-- the underscore versions do not+pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+pprLExpr (L _ e) = pprExpr e++pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e+          | otherwise                           = pprDeeper (ppr_expr e)++isQuietHsExpr :: HsExpr id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsExpr (HsPar {})        = True+-- applications don't display anything themselves+isQuietHsExpr (HsApp {})        = True+isQuietHsExpr (HsAppType {})    = True+isQuietHsExpr (OpApp {})        = True+isQuietHsExpr _ = False++pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)+         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc+pprBinds b = pprDeeper (ppr b)++-----------------------+ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+ppr_lexpr e = ppr_expr (unLoc e)++ppr_expr :: forall p. (OutputableBndrId p)+         => HsExpr (GhcPass p) -> SDoc+ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v+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+               GhcRn -> helper s+               GhcTc -> dataConCantHappen s+    where helper s =+            char '#' <> case s of+                          NoSourceText -> ppr l+                          SourceText src -> ftext src+ppr_expr (HsLit _ lit)       = ppr lit+ppr_expr (HsOverLit _ lit)   = ppr lit+ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)++ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]++ppr_expr e@(HsApp {})        = ppr_apps e []+ppr_expr e@(HsAppType {})    = ppr_apps e []++ppr_expr (OpApp _ e1 op e2)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly++  where+    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens+    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear++    pp_prefixly+      = hang (ppr op) 2 (sep [pp_e1, pp_e2])++    pp_infixly pp_op+      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])++ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e++ppr_expr (SectionL _ expr op)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])+                       4 (hsep [pp_expr, text "x_ )"])++    pp_infixly v = (sep [pp_expr, v])++ppr_expr (SectionR _ op expr)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])+                       4 (pp_expr <> rparen)++    pp_infixly v = sep [v, pp_expr]++ppr_expr (ExplicitTuple _ exprs boxity)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `MkSolo x`, not `(x)`+  | [Present _ expr] <- exprs+  , Boxed <- boxity+  = hsep [text (mkTupleStr Boxed dataName 1), ppr expr]+  | otherwise+  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))+  where+    ppr_tup_args []               = []+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es++    punc (Present {} : _) = comma <> space+    punc (Missing {} : _) = comma+    punc (XTupArg {} : _) = comma <> space+    punc []               = empty++ppr_expr (ExplicitSum _ alt arity expr)+  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"+  where+    ppr_bars n = hsep (replicate n (char '|'))++ppr_expr (HsLam _ lam_variant matches)+  = case lam_variant of+       LamSingle -> pprMatches matches+       _         -> sep [ sep [lamCaseKeyword lam_variant]+                        , nest 2 (pprMatches matches) ]++ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],+          pp_alts ]+  where+    pp_alts | null alts = text "{}"+            | otherwise = nest 2 (pprMatches matches)++ppr_expr (HsIf _ e1 e2 e3)+  = sep [hsep [text "if", nest 2 (ppr e1), text "then"],+         nest 4 (ppr e2),+         text "else",+         nest 4 (ppr e3)]++ppr_expr (HsMultiIf _ alts)+  = hang (text "if") 3  (vcat $ toList $ NE.map ppr_alt alts)+  where ppr_alt (L _ (GRHS _ guards 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 ...+ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _)))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),+         ppr_lexpr expr]++ppr_expr (HsLet _ binds expr)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr expr)]++ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts++ppr_expr (ExplicitList _ exprs)+  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))++ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })+  = hang pp_con 2 (ppr rbinds)+  where+    -- con :: ConLikeP (GhcPass p)+    -- so we need case analysis to know to print it+    pp_con = case ghcPass @p of+               GhcPs -> ppr con+               GhcRn -> ppr con+               GhcTc -> ppr con++ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })+  = case flds of+      RegularRecUpdFields { recUpdFields= rbinds } ->+        hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))+      OverloadedRecUpdFields { olRecUpdFields = pbinds } ->+        hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))++ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })+  = ppr fexp <> dot <> ppr field++ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds))))++ppr_expr (ExprWithTySig _ expr sig)+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)+         4 (ppr sig)++ppr_expr (ArithSeq _ _ info) = brackets (ppr info)++ppr_expr (HsTypedSplice ext e)   =+    case ghcPass @p of+      GhcPs -> pprTypedSplice Nothing 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+      GhcPs -> pprUntypedSplice True Nothing s+      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s+      GhcRn | HsUntypedSpliceTop _ e  <- ext -> ppr e+      GhcTc -> dataConCantHappen ext++ppr_expr (HsTypedBracket b e)+  = case ghcPass @p of+    GhcPs -> thTyBrackets (ppr e)+    GhcRn -> thTyBrackets (ppr e)+    GhcTc | HsBracketTc _  _ty _wrap ps <- b ->+      thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps+ppr_expr (HsUntypedBracket b q)+  = case ghcPass @p of+    GhcPs -> ppr q+    GhcRn -> case b of+      [] -> ppr q+      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, arrow, ppr cmd]++ppr_expr (HsStatic _ e)+  = hsep [text "static", ppr e]++ppr_expr (HsEmbTy _ ty)+  = hsep [text "type", ppr ty]++ppr_expr (HsQual _ ctxt ty)+  = sep [ppr_context ctxt, ppr_lexpr ty]+  where+    ppr_context (L _ ctxt) =+      case ctxt of+        []       -> parens empty             <+> darrow+        [L _ ty] -> ppr_expr ty              <+> darrow+        _        -> parens (interpp'SP ctxt) <+> darrow++ppr_expr (HsForAll _ tele ty)+  = sep [pprHsForAll tele Nothing, ppr_lexpr ty]++ppr_expr (HsFunArr _ arr arg res)+  = sep [ppr_lexpr arg, pprHsArrow arr <+> ppr_lexpr res]++ppr_expr (XExpr x) = case ghcPass @p of+  GhcRn -> ppr x+  GhcTc -> ppr x++instance Outputable HsThingRn where+  ppr thing+    = case thing of+        OrigExpr x -> ppr_builder "<OrigExpr>:" x+        OrigStmt x -> ppr_builder "<OrigStmt>:" x+        OrigPat x  -> ppr_builder "<OrigPat>:" x++    where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)++instance Outputable XXExprGhcRn where+  ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+  ppr (PopErrCtxt e)        = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)+  ppr (HsRecSelRn f)        = pprPrefixOcc f++instance Outputable XXExprGhcTc where+  ppr (WrapExpr co_fn e)+    = pprHsWrapper co_fn (\_parens -> pprExpr e)++  ppr (ExpandedThingTc o e)+    = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+            -- e is the expanded expression, we print the original+            -- expression (HsExpr GhcRn), not the+            -- expanded typechecked one (HsExpr GhcTc),+            -- unless we are in ppr's debug mode printed both++  ppr (ConLikeTc con _ _) = pprPrefixOcc con+   -- Used in error messages generated by+   -- the pattern match overlap checker++  ppr (HsTick tickish exp) =+    pprTicks (ppr exp) $+      ppr tickish <+> ppr_lexpr exp++  ppr (HsBinTick tickIdTrue tickIdFalse exp) =+    pprTicks (ppr exp) $+      hcat [text "bintick<",+            ppr tickIdTrue,+            text ",",+            ppr tickIdFalse,+            text ">(",+            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 (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+ppr_infix_expr _ = Nothing++ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc+ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing+ppr_infix_expr_rn (PopErrCtxt (L _ a))      = ppr_infix_expr a+ppr_infix_expr_rn (HsRecSelRn f)            = Just (pprInfixOcc f)++ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc+ppr_infix_expr_tc (WrapExpr _ e)    = ppr_infix_expr e+ppr_infix_expr_tc (ExpandedThingTc thing _)  = ppr_infix_hs_expansion thing+ppr_infix_expr_tc (ConLikeTc {})             = Nothing+ppr_infix_expr_tc (HsTick {})                = Nothing+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++ppr_apps :: (OutputableBndrId p)+         => HsExpr (GhcPass p)+         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]+         -> SDoc+ppr_apps (HsApp _ (L _ fun) arg)        args+  = ppr_apps fun (Left arg : args)+ppr_apps (HsAppType _ (L _ fun) arg)    args+  = ppr_apps fun (Right arg : args)+ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))+  where+    pp (Left arg)                             = ppr arg+    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))+    --   = char '@' <> pprHsType arg+    pp (Right arg)+      = text "@" <> ppr arg++pprDebugParendExpr :: (OutputableBndrId p)+                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprDebugParendExpr p expr+  = getPprDebug $ \case+      True  -> pprParendLExpr p expr+      False -> pprLExpr         expr++pprParendLExpr :: (OutputableBndrId p)+               => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprParendLExpr p (L _ e) = pprParendExpr p e++pprParendExpr :: (OutputableBndrId p)+              => PprPrec -> HsExpr (GhcPass p) -> SDoc+pprParendExpr p expr+  | hsExprNeedsParens p expr = parens (pprExpr expr)+  | otherwise                = pprExpr expr+        -- Using pprLExpr makes sure that we go 'deeper'+        -- I think that is usually (always?) right++-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs+-- parentheses under precedence @p@.+hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool+hsExprNeedsParens prec = go+  where+    go :: HsExpr (GhcPass p) -> Bool+    go (HsVar{})                      = False+    go (HsIPVar{})                    = False+    go (HsOverLabel{})                = False+    go (HsLit _ l)                    = hsLitNeedsParens prec l+    go (HsOverLit _ ol)               = hsOverLitNeedsParens prec ol+    go (HsPar{})                      = False+    go (HsApp{})                      = prec >= appPrec+    go (HsAppType {})                 = prec >= appPrec+    go (OpApp{})                      = prec >= opPrec+    go (NegApp{})                     = prec > topPrec+    go (SectionL{})                   = True+    go (SectionR{})                   = True+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go (ExplicitTuple _ [Present{}] Boxed)+                                      = prec >= appPrec+    go (ExplicitTuple{})              = False+    go (ExplicitSum{})                = False+    go (HsLam{})                      = prec > topPrec+    go (HsCase{})                     = prec > topPrec+    go (HsIf{})                       = prec > topPrec+    go (HsMultiIf{})                  = prec > topPrec+    go (HsLet{})                      = prec > topPrec+    go (HsDo _ sc _)+      | isDoComprehensionContext sc   = False+      | otherwise                     = prec > topPrec+    go (ExplicitList{})               = False+    go (RecordUpd{})                  = False+    go (ExprWithTySig{})              = prec >= sigPrec+    go (ArithSeq{})                   = False+    go (HsPragE{})                    = prec >= appPrec+    go (HsTypedSplice{})              = False+    go (HsUntypedSplice{})            = False+    go (HsTypedBracket{})             = False+    go (HsUntypedBracket{})           = False+    go (HsProc{})                     = prec > topPrec+    go (HsStatic{})                   = prec >= appPrec+    go (RecordCon{})                  = False+    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+    go (XExpr x) = case ghcPass @p of+                     GhcTc -> go_x_tc x+                     GhcRn -> go_x_rn x++    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr _ e)                   = hsExprNeedsParens prec e+    go_x_tc (ExpandedThingTc thing _)        = hsExpandedNeedsParens thing+    go_x_tc (ConLikeTc {})                   = False+    go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e+    go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e+    go_x_tc (HsRecSelTc{})                   = False++    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _)    = hsExpandedNeedsParens thing+    go_x_rn (PopErrCtxt (L _ a))         = hsExprNeedsParens prec a+    go_x_rn (HsRecSelRn{})               = False++    hsExpandedNeedsParens :: HsThingRn -> Bool+    hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e+    hsExpandedNeedsParens _            = False++-- | Parenthesize an expression without token information+gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+gHsPar e = HsPar x e+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField++-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.+parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+parenthesizeHsExpr p le@(L loc e)+  | hsExprNeedsParens p e = L loc (gHsPar le)+  | otherwise             = le++stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e+stripParensLHsExpr e = e++stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)+stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e+stripParensHsExpr e = e++isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool+-- True of a single token+isAtomicHsExpr (HsVar {})        = True+isAtomicHsExpr (HsLit {})        = True+isAtomicHsExpr (HsOverLit {})    = True+isAtomicHsExpr (HsIPVar {})      = True+isAtomicHsExpr (HsOverLabel {})  = True+isAtomicHsExpr (HsHole{})        = True+isAtomicHsExpr (XExpr x)+  | GhcTc <- ghcPass @p          = go_x_tc x+  | GhcRn <- ghcPass @p          = go_x_rn x+  where+    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr _ e)            = isAtomicHsExpr e+    go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing+    go_x_tc (ConLikeTc {})            = True+    go_x_tc (HsTick {})               = False+    go_x_tc (HsBinTick {})            = False+    go_x_tc (HsRecSelTc{})            = True++    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing+    go_x_rn (PopErrCtxt (L _ a))      = isAtomicHsExpr a+    go_x_rn (HsRecSelRn{})            = True++    isAtomicExpandedThingRn :: HsThingRn -> Bool+    isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e+    isAtomicExpandedThingRn _            = False++isAtomicHsExpr _ = False++instance Outputable (HsPragE (GhcPass p)) where+  ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) =+    pprWithSourceText st (text "{-# SCC")+     -- no doublequotes if stl empty, for the case where the SCC was written+     -- without quotes.+    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"+++{- *********************************************************************+*                                                                      *+             XXExprGhcRn and rebindable syntax+*                                                                      *+********************************************************************* -}++{- Note [Rebindable syntax and XXExprGhcRn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We implement rebindable syntax (RS) support by performing a desugaring+in the renamer. We transform GhcPs expressions and patterns affected by+RS into the appropriate desugared form, but **annotated with the original+expression/pattern**.++Let us consider a piece of code like:++    {-# LANGUAGE RebindableSyntax #-}+    ifThenElse :: Char -> () -> () -> ()+    ifThenElse _ _ _ = ()+    x = if 'a' then () else True++The parsed AST for the RHS of x would look something like (slightly simplified):++    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))++Upon seeing such an AST with RS on, we could transform it into a+mere function call, as per the RS rules, equivalent to the+following function application:++    ifThenElse 'a' () True++which doesn't typecheck. But GHC would report an error about+not being able to match the third argument's type (Bool) with the+expected type: (), in the expression _as desugared_, i.e in+the aforementioned function application. But the user never+wrote a function application! This would be pretty bad.++To remedy this, instead of transforming the original HsIf+node into mere applications of 'ifThenElse', we keep the+original 'if' expression around too, using the TTG+XExpr extension point to allow GHC to construct an+'XXExprGhcRn' value that will keep track of the original+expression in its first field, and the desugared one in the+second field. The resulting renamed AST would look like:++    L locif (XExpr+      (ExpandedThingRn+        (HsIf (L loca 'a')+              (L loctrue ())+              (L locfalse True)+        )+        (App (L generatedSrcSpan+                (App (L generatedSrcSpan+                        (App (L generatedSrcSpan (Var ifThenElse))+                             (L loca 'a')+                        )+                     )+                     (L loctrue ())+                )+             )+             (L locfalse True)+        )+      )+    )++When comes the time to typecheck the program, we end up calling+tcMonoExpr on the AST above. If this expression gives rise to+a type error, then it will appear in a context line and GHC+will pretty-print it using the 'Outputable (XXExprGhcRn a b)'+instance defined below, which *only prints the original+expression*. This is the gist of the idea, but is not quite+enough to recover the error messages that we had with the+SyntaxExpr-based, typechecking/desugaring-to-core time+implementation of rebindable syntax. The key idea is to decorate+some elements of the desugared expression so as to be able to+give them a special treatment when typechecking the desugared+expression, to print a different context line or skip one+altogether.++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in+TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we+entered generated code, i.e code fabricated by the compiler when rebinding some+syntax. If someone tries to push some error context line while that field is set+to True, the pushing won't actually happen and the context line is just dropped.+Once we 'setSrcSpan' a real span (for an expression that was in the original+source code), we set 'tcl_in_gen_code' back to False, indicating that we+"emerged from the generated code tunnel", and that the expressions we will be+processing are relevant to report in context lines again.++You might wonder why TcLclEnv has both+   tcl_loc         :: RealSrcSpan+   tcl_in_gen_code :: Bool+Could we not store a Maybe RealSrcSpan? The problem is that we still+generate constraints when processing generated code, and a CtLoc must+contain a RealSrcSpan -- otherwise, error messages might appear+without source locations. So tcl_loc keeps the RealSrcSpan of the last+location spotted that wasn't generated; it's as good as we're going to+get in generated code. Once we get to sub-trees that are not+generated, then we update the RealSrcSpan appropriately, and set the+tcl_in_gen_code Bool to False.++---++An overview of the constructs that are desugared in this way is laid out in+Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.++A general recipe to follow this approach for new constructs could go as follows:++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your+  construct, in HsExpr or related syntax data types.+- At renaming-time:+    - take your original node of interest (HsIf above)+    - rename its subexpressions/subpatterns (condition and true/false+      branches above)+    - construct the suitable "rebound"-and-renamed result (ifThenElse call+      above), where the 'SrcSpan' attached to any _fabricated node_ (the+      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'+    - take both the original node and that rebound-and-renamed result and wrap+      them into an expansion construct:+        for expressions, XExpr (ExpandedThingRn <original node> <desugared>)+        for patterns, XPat (HsPatExpanded <original node> <desugared>)+ - At typechecking-time:+    - remove any logic that was previously dealing with your rebindable+      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.+    - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we+      typecheck the desugared expression while reporting the original one in+      errors+-}++{- Note [Overview of record dot syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is the note that explains all the moving parts for record dot+syntax.++The language extensions @OverloadedRecordDot@ and+@OverloadedRecordUpdate@ (providing "record dot syntax") are+implemented using the techniques of Note [Rebindable syntax and+XXExprGhcRn].++When OverloadedRecordDot is enabled:+- Field selection expressions+  - e.g. foo.bar.baz+  - Have abstract syntax HsGetField+  - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions+- Field selector expressions e.g. (.x.y)+  - Have abstract syntax HsProjection+  - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions++When OverloadedRecordUpdate is enabled:+- Record update expressions+  - e.g. a{foo.bar=1, quux="corge", baz}+  - Have abstract syntax RecordUpd+    - With rupd_flds containting a Right+    - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)+  - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions+    - Note that this is true for all record updates even for those that do not involve '.'++When OverloadedRecordDot is enabled and RebindableSyntax is not+enabled the name 'getField' is resolved to GHC.Records.getField. When+OverloadedRecordDot is enabled and RebindableSyntax is enabled the+name 'getField' is whatever in-scope name that is.++When OverloadedRecordUpd is enabled and RebindableSyntax is not+enabled it is an error for now (temporary while we wait on native+setField support; see+https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When+OverloadedRecordUpd is enabled and RebindableSyntax is enabled the+names 'getField' and 'setField' are whatever in-scope names they are.+-}+++{-+************************************************************************+*                                                                      *+\subsection{Commands (in arrow abstractions)}+*                                                                      *+************************************************************************+-}++type instance XCmdArrApp  GhcPs = (IsUnicodeSyntax, EpaLocation)+type instance XCmdArrApp  GhcRn = NoExtField+type instance XCmdArrApp  GhcTc = Type++type instance XCmdArrForm GhcPs = AnnList ()+-- | fixity (filled in by the renamer), for forms that were converted from+-- OpApp's by the renamer+type instance XCmdArrForm GhcRn = Maybe Fixity+type instance XCmdArrForm GhcTc = Maybe Fixity++type instance XCmdApp     (GhcPass _) = NoExtField+type instance XCmdLam     (GhcPass _) = NoExtField++type instance XCmdPar     GhcPs = (EpToken "(", EpToken ")")+type instance XCmdPar     GhcRn = NoExtField+type instance XCmdPar     GhcTc = NoExtField++type instance XCmdCase    GhcPs = EpAnnHsCase+type instance XCmdCase    GhcRn = NoExtField+type instance XCmdCase    GhcTc = NoExtField++type instance XCmdLamCase (GhcPass _) = EpAnnLam++type instance XCmdIf      GhcPs = AnnsIf+type instance XCmdIf      GhcRn = NoExtField+type instance XCmdIf      GhcTc = NoExtField++type instance XCmdLet     GhcPs = (EpToken "let", EpToken "in")+type instance XCmdLet     GhcRn = NoExtField+type instance XCmdLet     GhcTc = NoExtField++type instance XCmdDo      GhcPs = AnnList EpaLocation+type instance XCmdDo      GhcRn = NoExtField+type instance XCmdDo      GhcTc = Type++type instance XCmdWrap    (GhcPass _) = NoExtField++type instance XXCmd       GhcPs = DataConCantHappen+type instance XXCmd       GhcRn = DataConCantHappen+type instance XXCmd       GhcTc = HsWrap HsCmd++    -- If   cmd :: arg1 --> res+    --      wrap :: arg1 "->" arg2+    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res++-- | Command Syntax Table (for Arrow syntax)+type CmdSyntaxTable p = [(Name, HsExpr p)]+-- See Note [CmdSyntaxTable]++{-+Note [CmdSyntaxTable]+~~~~~~~~~~~~~~~~~~~~~+Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps+track of the methods needed for a Cmd.++* Before the renamer, this list is an empty list++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@+  For example, for the 'arr' method+   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)+   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)+             where @arr_22@ is whatever 'arr' is in scope++* After the type checker, it takes the form [(std_name, <expression>)]+  where <expression> is the evidence for the method.  This evidence is+  instantiated with the class, but is still polymorphic in everything+  else.  For example, in the case of 'arr', the evidence has type+         forall b c. (b->c) -> a b c+  where 'a' is the ambient type of the arrow.  This polymorphism is+  important because the desugarer uses the same evidence at multiple+  different types.++This is Less Cool than what we normally do for rebindable syntax, which is to+make fully-instantiated piece of evidence at every use site.  The Cmd way+is Less Cool because+  * The renamer has to predict which methods are needed.+    See the tedious GHC.Rename.Expr.methodNamesCmd.++  * The desugarer has to know the polymorphic type of the instantiated+    method. This is checked by Inst.tcSyntaxName, but is less flexible+    than the rest of rebindable syntax, where the type is less+    pre-ordained.  (And this flexibility is useful; for example we can+    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)+-}++data CmdTopTc+  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack+             Type    -- return type of the command+             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]++type instance XCmdTop  GhcPs = NoExtField+type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]+type instance XCmdTop  GhcTc = CmdTopTc+++type instance XXCmdTop (GhcPass _) = DataConCantHappen++instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where+    ppr cmd = pprCmd cmd++-----------------------+-- pprCmd and pprLCmd call pprDeeper;+-- the underscore versions do not+pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+pprLCmd (L _ c) = pprCmd c++pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc+pprCmd c | isQuietHsCmd c =            ppr_cmd c+         | otherwise      = pprDeeper (ppr_cmd c)++isQuietHsCmd :: HsCmd id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsCmd (HsCmdPar {}) = True+-- applications don't display anything themselves+isQuietHsCmd (HsCmdApp {}) = True+isQuietHsCmd _ = False++-----------------------+ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+ppr_lcmd c = ppr_cmd (unLoc c)++ppr_cmd :: forall p. (OutputableBndrId p+                     ) => HsCmd (GhcPass p) -> SDoc+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)++ppr_cmd (HsCmdApp _ c e)+  = let (fun, args) = collect_args c [e] in+    hang (ppr_lcmd fun) 2 (sep (map ppr args))+  where+    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)+    collect_args fun args = (fun, args)++ppr_cmd (HsCmdLam _ LamSingle matches)+  = pprMatches matches+ppr_cmd (HsCmdLam _ lam_variant matches)+  = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdCase _ expr matches)+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],+          nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdIf _ _ e ct ce)+  = sep [hsep [text "if", nest 2 (ppr e), text "then"],+         nest 4 (ppr ct),+         text "else",+         nest 4 (ppr ce)]++-- special case: let ... in let ...+ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {})))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),+         ppr_lcmd cmd]++ppr_cmd (HsCmdLet _ binds cmd)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr cmd)]++ppr_cmd (HsCmdDo _ (L _ stmts))  = pprArrowExpr stmts++ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]++ppr_cmd (HsCmdArrForm rn_fix (L _ op) ps_fix args)+  | HsVar _ (L _ v) <- op+  = ppr_cmd_infix v+  | GhcTc <- ghcPass @p+  , XExpr (ConLikeTc c _ _) <- op+  = ppr_cmd_infix (conLikeName c)+  | otherwise+  = fall_through+  where+    fall_through = hang (text "(|" <+> ppr_expr op)+                      4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")++    ppr_cmd_infix :: OutputableBndr v => v -> SDoc+    ppr_cmd_infix v+      | [arg1, arg2] <- args+      , case ghcPass @p of+          GhcPs -> ps_fix == Infix+          GhcRn -> isJust rn_fix || ps_fix == Infix+          GhcTc -> isJust rn_fix || ps_fix == Infix+      = hang (pprCmdArg (unLoc arg1))+           4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])+      | otherwise+      = fall_through++ppr_cmd (XCmd x) = case ghcPass @p of+  GhcTc -> case x of+    HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))++pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc+pprCmdArg (HsCmdTop _ cmd)+  = ppr_lcmd cmd++instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where+    ppr = pprCmdArg++{-+************************************************************************+*                                                                      *+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}+*                                                                      *+************************************************************************+-}++type instance XMG         GhcPs b = Origin+type instance XMG         GhcRn b = Origin -- See Note [Generated code and pattern-match checking]+type instance XMG         GhcTc b = MatchGroupTc++data MatchGroupTc+  = MatchGroupTc+       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn+       , mg_res_ty  :: Type    -- Type of the result, tr+       , mg_origin  :: Origin  -- Origin (Generated vs FromSource)+       } deriving Data++type instance XXMatchGroup (GhcPass _) b = DataConCantHappen++type instance XCMatch (GhcPass _) b = NoExtField+type instance XXMatch (GhcPass _) b = DataConCantHappen++instance (OutputableBndrId pr, Outputable body)+            => Outputable (Match (GhcPass pr) body) where+  ppr = pprMatch++isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool+isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms++-- | Is there only one RHS in this list of matches?+isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool+isSingletonMatchGroup matches+  | [L _ match] <- matches+  , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match+  = True+  | otherwise+  = False++matchGroupArity :: MatchGroup (GhcPass id) body -> Arity+-- This is called before type checking, when mg_arg_tys is not set+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+-- item. So this can never be used in practice.+type instance XCGRHSs (GhcPass _) _ = EpAnnComments++type instance XXGRHSs (GhcPass _) _ = DataConCantHappen++data GrhsAnn+  = GrhsAnn {+      ga_vbar :: Maybe (EpToken "|"),+      ga_sep  :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->`+      } deriving (Data)++instance NoAnn GrhsAnn where+  noAnn = GrhsAnn Nothing noAnn++type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn+                                   -- Location of matchSeparator+                                   -- TODO:AZ does this belong on the GRHS, or GRHSs?++type instance XXGRHS (GhcPass _) b = DataConCantHappen++pprMatches :: (OutputableBndrId idR, Outputable body)+           => MatchGroup (GhcPass idR) body -> SDoc+pprMatches MG { mg_alts = matches }+    = vcat (map pprMatch (map unLoc (unLoc matches)))+      -- Don't print the type; it's only a place-holder before typechecking++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprFunBind :: (OutputableBndrId idR)+           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc+pprFunBind matches = pprMatches matches++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprPatBind :: forall bndr p . (OutputableBndrId bndr,+                               OutputableBndrId p)+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc+pprPatBind pat grhss+ = sep [ppr pat,+       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)]++pprMatch :: (OutputableBndrId idR, Outputable body)+         => Match (GhcPass idR) body -> SDoc+pprMatch (Match { m_pats = L _ pats, m_ctxt = ctxt, m_grhss = grhss })+  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)+        , nest 2 (pprGRHSs ctxt grhss) ]+  where+    -- lam_cases_result: we don't simply return (empty, pats) to avoid+    -- introducing an additional `nest 2` via the empty herald+    lam_cases_result = case pats of+                          []     -> (empty, [])+                          (p:ps) -> (pprParendLPat appPrec p, ps)++    (herald, other_pats)+        = case ctxt of+            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}+                | SrcStrict <- strictness+                -> assert (null pats)     -- A strict variable binding+                   (char '!'<>pprPrefixOcc fun, pats)++                | Prefix <- fixity+                -> (pprPrefixOcc fun, pats) -- f x y z = e+                                            -- Not pprBndr; the AbsBinds will+                                            -- have printed the signature+                | otherwise+                -> case pats of+                     (p1:p2:rest)+                        | null rest -> (pp_infix, [])           -- x &&& y = e+                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e+                        where+                          pp_infix = pprParendLPat opPrec p1+                                     <+> pprInfixOcc fun+                                     <+> pprParendLPat opPrec p2+                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++            LamAlt LamSingle                       -> (char '\\', pats)+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)+            LamAlt LamCases                        -> lam_cases_result+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> lam_cases_result++            ArrowMatchCtxt ProcExpr -> (text "proc", pats)++            _ -> case pats of+                   []    -> (empty, [])+                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case+                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++pprGRHSs :: (OutputableBndrId idR, Outputable body)+         => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc+pprGRHSs ctxt (GRHSs _ grhss binds)+  = 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)+      (text "where" $$ nest 4 (pprBinds binds))++pprGRHS :: (OutputableBndrId idR, Outputable body)+        => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc+pprGRHS ctxt (GRHS _ [] body)+ =  pp_rhs ctxt body++pprGRHS ctxt (GRHS _ guards body)+ = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]++pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)++matchSeparator :: HsMatchContext fn -> SDoc+matchSeparator FunRhs{}         = text "="+matchSeparator CaseAlt          = arrow+matchSeparator LamAlt{}         = arrow+matchSeparator IfAlt            = arrow+matchSeparator ArrowMatchCtxt{} = arrow+matchSeparator PatBindRhs       = text "="+matchSeparator PatBindGuards    = text "="+matchSeparator StmtCtxt{}       = text "<-"+matchSeparator RecUpd           = text "="  -- This can be printed by the pattern+matchSeparator PatSyn           = text "<-" -- match checker trace+matchSeparator LazyPatCtx       = panic "unused"+matchSeparator ThPatSplice      = panic "unused"+matchSeparator ThPatQuote       = panic "unused"++instance Outputable GrhsAnn where+  ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s++{-+************************************************************************+*                                                                      *+\subsection{Do stmts and list comprehensions}+*                                                                      *+************************************************************************+-}++-- Extra fields available post typechecking for RecStmt.+data RecStmtTc =+  RecStmtTc+     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T+     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)+     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1+                                  -- with recS_later_ids and recS_rec_ids,+                                  -- and are the expressions that should be+                                  -- returned by the recursion.+                                  -- They may not quite be the Ids themselves,+                                  -- because the Id may be *polymorphic*, but+                                  -- the returned thing has to be *monomorphic*,+                                  -- so they may be type applications++      , recS_ret_ty :: Type        -- The type of+                                   -- do { stmts; return (a,b,c) }+                                   -- With rebindable syntax the type might not+                                   -- be quite as simple as (m (tya, tyb, tyc)).+      }+++type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField++type instance XBindStmt        (GhcPass _) GhcPs b = EpUniToken "<-" "←"+type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn+type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc++data XBindStmtRn = XBindStmtRn+  { xbsrn_bindOp :: SyntaxExpr GhcRn+  , xbsrn_failOp :: FailOperator GhcRn+  }++data XBindStmtTc = XBindStmtTc+  { xbstc_bindOp :: SyntaxExpr GhcTc+  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_failOp :: FailOperator GhcTc+  }++type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcTc = Type++type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcTc b = Type++type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpToken "let"++type instance XParStmt         (GhcPass _) GhcPs b = NoExtField+type instance XParStmt         (GhcPass _) GhcRn b = NoExtField+type instance XParStmt         (GhcPass _) GhcTc b = Type++type instance XTransStmt       (GhcPass _) GhcPs b = AnnTransStmt+type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField+type instance XTransStmt       (GhcPass _) GhcTc b = Type++type instance XRecStmt         (GhcPass _) GhcPs b = AnnList (EpToken "rec")+type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField+type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc++type instance XXStmtLR         (GhcPass _) GhcPs b = DataConCantHappen+type instance XXStmtLR         (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn+type instance XXStmtLR         (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc++data AnnTransStmt+  = AnnTransStmt {+      ats_then  :: EpToken "then",+      ats_group :: Maybe (EpToken "group"),+      ats_by    :: Maybe (EpToken "by"),+      ats_using :: Maybe (EpToken "using")+      } deriving Data++instance NoAnn AnnTransStmt where+  noAnn = AnnTransStmt noAnn noAnn noAnn noAnn+++-- | 'ApplicativeStmt' represents an applicative expression built with+-- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the+-- appropriate applicative expression by the desugarer, but it is intended+-- to be invisible in error messages.+--+-- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"+--+data ApplicativeStmt idL idR+  = ApplicativeStmt+             (XApplicativeStmt idL idR) -- Post typecheck, Type of the body+             [ ( SyntaxExpr idR+               , ApplicativeArg idL) ]+                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]+             (Maybe (SyntaxExpr idR))  -- 'join', if necessary++-- | Applicative Argument+data ApplicativeArg idL+  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)+    { xarg_app_arg_one  :: XApplicativeArgOne idL+      -- ^ The fail operator, after renaming+      --+      -- The fail operator is needed if this is a BindStmt+      -- where the pattern can fail. E.g.:+      -- (Just a) <- stmt+      -- The fail operator will be invoked if the pattern+      -- match fails.+      -- It is also used for guards in MonadComprehensions.+      -- The fail operator is Nothing+      -- if the pattern match can't fail+    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)+    , arg_expr          :: LHsExpr idL+    , is_body_stmt      :: Bool+      -- ^ True <=> was a BodyStmt,+      -- False <=> was a BindStmt.+      -- See Note [Applicative BodyStmt]+    }+  | ApplicativeArgMany     -- do { stmts; return vars }+    { xarg_app_arg_many :: XApplicativeArgMany idL+    , app_stmts         :: [ExprLStmt idL] -- stmts+    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)+    , bv_pattern        :: LPat idL      -- (v1,...,vn)+    , stmt_context      :: HsDoFlavour+      -- ^ context of the do expression, used in pprArg+    }+  | XApplicativeArg !(XXApplicativeArg idL)++type family XApplicativeStmt x x'++-- ApplicativeArg type families+type family XApplicativeArgOne   x+type family XApplicativeArgMany  x+type family XXApplicativeArg     x++type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen++type instance XApplicativeArgOne GhcPs = NoExtField+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc++type instance XApplicativeArgMany (GhcPass _) = NoExtField+type instance XXApplicativeArg    (GhcPass _) = DataConCantHappen++instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),+          Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))+        => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts++instance (OutputableBndrId pl, OutputableBndrId pr,+                 Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,+          Outputable body)+         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where+    ppr stmt = pprStmt stmt++pprStmt :: forall idL idR body . (OutputableBndrId idL,+                                  OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                                  Outputable body)+        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc+pprStmt (LastStmt _ expr m_dollar_stripped _)+  = whenPprDebug (text "[last]") <+>+      (case m_dollar_stripped of+        Just True -> text "return $"+        Just False -> text "return"+        Nothing -> empty) <+>+      ppr expr+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 $ toList stmtss))++pprStmt (TransStmt { trS_stmts = stmts, trS_by = by+                   , trS_using = using, trS_form = form })+  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])++pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids+                 , recS_later_ids = later_ids })+  = text "rec" <+>+    vcat [ ppr_do_stmts (unLoc segment)+         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids+                            , text "later_ids=" <> ppr later_ids])]++pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of+    GhcRn -> pprApplicativeStmt x+    GhcTc -> pprApplicativeStmt x++  where+    pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc+    pprApplicativeStmt (ApplicativeStmt _ args mb_join) =+      getPprStyle $ \style ->+          if userStyle style+             then pp_for_user+             else pp_debug+      where+        -- make all the Applicative stuff invisible in error messages by+        -- flattening the whole ApplicativeStmt nest back to a sequence+        -- of statements.+        pp_for_user = vcat $ concatMap flattenArg args++        -- ppr directly rather than transforming here, because we need to+        -- inject a "return" which is hard when we're polymorphic in the id+        -- type.+        flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]+        flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of+            GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args+            GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args+        flattenStmt stmt = [ppr stmt]++        flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]+        flattenArg (_, ApplicativeArgOne _ pat expr isBody)+          | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]+          | otherwise = [pprBindStmt pat expr]+        flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =+          concatMap flattenStmt stmts++        pp_debug =+          let+              ap_expr = sep (punctuate (text " |") (map pp_arg args))+          in+            whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>+            (if lengthAtLeast args 2 then parens else id) ap_expr++        pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc+        pp_arg (_, applicativeArg) = ppr applicativeArg++pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc+pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]++instance (OutputableBndrId idL)+      => Outputable (ApplicativeArg (GhcPass idL)) where+  ppr = pprArg++pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc+pprArg (ApplicativeArgOne _ pat expr isBody)+  | isBody = ppr expr -- See Note [Applicative BodyStmt]+  | otherwise = pprBindStmt pat expr+pprArg (ApplicativeArgMany _ stmts return pat ctxt) =+     ppr pat <+>+     text "<-" <+>+     pprDo ctxt (stmts +++                   [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])++pprTransformStmt :: (OutputableBndrId p)+                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc+pprTransformStmt bndrs using by+  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))+        , nest 2 (ppr using)+        , nest 2 (pprBy by)]++pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc+pprTransStmt by using ThenForm+  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]+pprTransStmt by using GroupForm+  = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)]++pprBy :: Outputable body => Maybe body -> SDoc+pprBy Nothing  = empty+pprBy (Just e) = text "by" <+> ppr e++pprDo :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc+pprDo (DoExpr m)    stmts =+  ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts+pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts+pprDo (MDoExpr m)   stmts =+  ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts+pprDo ListComp      stmts = brackets    $ pprComp stmts+pprDo MonadComp     stmts = brackets    $ pprComp stmts++pprArrowExpr :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => [LStmt (GhcPass p) body] -> SDoc+pprArrowExpr stmts = text "do"  <+> ppr_do_stmts stmts++ppr_module_name_prefix :: Maybe ModuleName -> SDoc+ppr_module_name_prefix = \case+  Nothing -> empty+  Just module_name -> ppr module_name <> char '.'++ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                 Outputable body)+             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc+-- Print a bunch of do stmts+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)++pprComp :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+        => [LStmt (GhcPass p) body] -> SDoc+pprComp quals     -- Prints:  body | qual1, ..., qualn+  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals+  = if null initStmts+       -- If there are no statements in a list comprehension besides the last+       -- one, we simply treat it like a normal list. This does arise+       -- occasionally in code that GHC generates, e.g., in implementations of+       -- 'range' for derived 'Ix' instances for product datatypes with exactly+       -- one constructor (e.g., see #12583).+       then ppr body+       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)+  | otherwise+  = pprPanic "pprComp" (pprQuals quals)++pprQuals :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+         => [LStmt (GhcPass p) body] -> SDoc+-- Show list comprehension qualifiers separated by commas+pprQuals quals = interpp'SP quals++{-+************************************************************************+*                                                                      *+                Template Haskell quotation brackets+*                                                                      *+************************************************************************+-}++-- | Finalizers produced by a splice with+-- 'Language.Haskell.TH.Syntax.addModFinalizer'+--+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how+-- this is used.+--+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]++-- A Data instance which ignores the argument of 'ThModFinalizers'.+instance Data ThModFinalizers where+  gunfold _ z _ = z $ ThModFinalizers []+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]++-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.+-- This is the result of splicing a splice. It is produced by+-- the renamer and consumed by the typechecker. It lives only between the two.+data HsUntypedSpliceResult thing  -- 'thing' can be HsExpr or HsType+  = HsUntypedSpliceTop+      { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice.+      , utsplice_result            :: thing           -- ^ The result of splicing; See Note [Lifecycle of a splice]+      }+  | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point++-- 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+type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn)+type instance XUntypedSplice GhcTc = DataConCantHappen++-- HsUntypedSplice+type instance XUntypedSpliceExpr GhcPs = EpToken "$"+type instance XUntypedSpliceExpr GhcRn = HsUserSpliceExt+type instance XUntypedSpliceExpr GhcTc = DataConCantHappen++type instance XTypedSpliceExpr GhcPs = EpToken "$$"+type instance XTypedSpliceExpr GhcRn = NoExtField+type instance XTypedSpliceExpr GhcTc = NoExtField++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 =+  DelayedSplice+    TcLclEnv          -- The local environment to run the splice in+    (LHsExpr GhcRn)   -- The original renamed expression+    TcType            -- The result type of running the splice, unzonked+    (LHsExpr GhcTc)   -- The typechecked expression to run and splice in the result++-- A Data instance which ignores the argument of 'DelayedSplice'.+instance Data DelayedSplice where+  gunfold _ _ _ = panic "DelayedSplice"+  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]++-- See Note [Pending Splices]+type SplicePointName = Name++data UntypedSpliceFlavour+  = UntypedExpSplice+  | UntypedPatSplice+  | UntypedTypeSplice+  | UntypedDeclSplice+  deriving Data+++-- 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+          }++-- | 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+    }++-- | 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+                 -> HsUntypedSplice (GhcPass p)+                 -> 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 (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 <>+                           ppr quote <> text "|]"++ppr_splice :: (OutputableBndrId p)+           => SDoc+           -> Maybe SplicePointName+           -> LHsExpr (GhcPass p)+           -> SDoc+ppr_splice herald mn e+    = herald+    <> (case mn of+         Nothing -> empty+         Just splice_name -> whenPprDebug (brackets (ppr splice_name)))+    <> ppr e+++type instance XExpBr  GhcPs       = (BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|"), EpUniToken "|]" "⟧")+type instance XPatBr  GhcPs       = (EpToken "[p|", EpUniToken "|]" "⟧")+type instance XDecBrL GhcPs       = (EpToken "[d|", EpUniToken "|]" "⟧", (EpToken "{", EpToken "}"))+type instance XDecBrG GhcPs       = NoExtField+type instance XTypBr  GhcPs       = (EpToken "[t|", EpUniToken "|]" "⟧")+type instance XVarBr  GhcPs       = EpaLocation+type instance XXQuote GhcPs       = DataConCantHappen++type instance XExpBr  GhcRn       = NoExtField+type instance XPatBr  GhcRn       = NoExtField+type instance XDecBrL GhcRn       = NoExtField+type instance XDecBrG GhcRn       = NoExtField+type instance XTypBr  GhcRn       = NoExtField+type instance XVarBr  GhcRn       = NoExtField+type instance XXQuote GhcRn       = DataConCantHappen++-- See Note [The life cycle of a TH quotation]+type instance XExpBr  GhcTc       = DataConCantHappen+type instance XPatBr  GhcTc       = DataConCantHappen+type instance XDecBrL GhcTc       = DataConCantHappen+type instance XDecBrG GhcTc       = DataConCantHappen+type instance XTypBr  GhcTc       = DataConCantHappen+type instance XVarBr  GhcTc       = DataConCantHappen+type instance XXQuote GhcTc       = NoExtField++instance OutputableBndrId p+          => Outputable (HsQuote (GhcPass p)) where+  ppr = pprHsQuote+    where+      pprHsQuote :: forall p. (OutputableBndrId p)+                   => HsQuote (GhcPass p) -> SDoc+      pprHsQuote (ExpBr _ e)   = thBrackets empty (ppr e)+      pprHsQuote (PatBr _ p)   = thBrackets (char 'p') (ppr p)+      pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)+      pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))+      pprHsQuote (TypBr _ t)   = thBrackets (char 't') (ppr t)+      pprHsQuote (VarBr _ True n)+        = char '\'' <> pprPrefixOcc (unLoc n)+      pprHsQuote (VarBr _ False n)+        = text "''" <> pprPrefixOcc (unLoc n)+      pprHsQuote (XQuote b)  = case ghcPass @p of+          GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)+                   -- See Note [The life cycle of a TH quotation]++thBrackets :: SDoc -> SDoc -> SDoc+thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>+                             pp_body <+> text "|]"++thTyBrackets :: SDoc -> SDoc+thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"++instance Outputable PendingTcSplice where+  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 $$ whenPprDebug (text "pending(tc)" <+> ppr ps)++{-+************************************************************************+*                                                                      *+\subsection{Enumerations and list comprehensions}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p+         => Outputable (ArithSeqInfo (GhcPass p)) where+    ppr (From e1)             = hcat [ppr e1, pp_dotdot]+    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]+    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]+    ppr (FromThenTo e1 e2 e3)+      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]++pp_dotdot :: SDoc+pp_dotdot = text " .. "++{-+************************************************************************+*                                                                      *+\subsection{HsMatchCtxt}+*                                                                      *+************************************************************************+-}++type HsMatchContextPs = HsMatchContext (LIdP GhcPs)+type HsMatchContextRn = HsMatchContext (LIdP GhcRn)++type HsStmtContextRn = HsStmtContext (LIdP GhcRn)++instance Outputable fn => Outputable (HsMatchContext fn) where+  ppr m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)+  ppr CaseAlt                 = text "CaseAlt"+  ppr (LamAlt lam_variant)    = text "LamAlt" <+> ppr lam_variant+  ppr IfAlt                   = text "IfAlt"+  ppr (ArrowMatchCtxt c)      = text "ArrowMatchCtxt" <+> ppr c+  ppr PatBindRhs              = text "PatBindRhs"+  ppr PatBindGuards           = text "PatBindGuards"+  ppr RecUpd                  = text "RecUpd"+  ppr (StmtCtxt _)            = text "StmtCtxt _"+  ppr ThPatSplice             = text "ThPatSplice"+  ppr ThPatQuote              = text "ThPatQuote"+  ppr PatSyn                  = text "PatSyn"+  ppr LazyPatCtx              = text "LazyPatCtx"++instance Outputable HsLamVariant where+  ppr = text . \case+    LamSingle -> "LamSingle"+    LamCase   -> "LamCase"+    LamCases  -> "LamCases"++lamCaseKeyword :: HsLamVariant -> SDoc+lamCaseKeyword LamSingle = text "lambda"+lamCaseKeyword LamCase   = text "\\case"+lamCaseKeyword LamCases  = text "\\cases"++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc+pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))+  = ppr (src,(n1,n2),(n3,n4))++instance Outputable HsArrowMatchContext where+  ppr ProcExpr                  = text "ProcExpr"+  ppr ArrowCaseAlt              = text "ArrowCaseAlt"+  ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant++pprHsArrType :: HsArrAppType -> SDoc+pprHsArrType HsHigherOrderApp = text "higher order arrow application"+pprHsArrType HsFirstOrderApp  = text "first order arrow application"++-----------------++instance Outputable fn => Outputable (HsStmtContext fn) where+    ppr = pprStmtContext++-- Used to generate the string for a *runtime* error message+matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc+matchContextErrString (FunRhs{mc_fun=fun})          = text "function" <+> ppr fun+matchContextErrString CaseAlt                       = text "case"+matchContextErrString (LamAlt lam_variant)          = lamCaseKeyword lam_variant+matchContextErrString IfAlt                         = text "multi-way if"+matchContextErrString PatBindRhs                    = text "pattern binding"+matchContextErrString PatBindGuards                 = text "pattern binding guards"+matchContextErrString RecUpd                        = text "record update"+matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c+matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString PatSyn                        = text "pattern synonym"+matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"+matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block"+matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour+matchContextErrString LazyPatCtx                    = text "irrefutable pattern"++matchArrowContextErrString :: HsArrowMatchContext -> SDoc+matchArrowContextErrString ProcExpr                  = text "proc"+matchArrowContextErrString ArrowCaseAlt              = text "case"+matchArrowContextErrString (ArrowLamAlt LamSingle)   = text "kappa"+matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant++matchDoContextErrString :: HsDoFlavour -> SDoc+matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"+matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")+matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")+matchDoContextErrString ListComp     = text "list comprehension"+matchDoContextErrString MonadComp    = text "monad comprehension"++pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)+               => Match (GhcPass idR) body -> SDoc+pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)+                                        <> colon)+                             4 (pprMatch match)++pprStmtInCtxt :: (OutputableBndrId idL,+                  OutputableBndrId idR,+                  Outputable fn,+                  Outputable body,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)+              => HsStmtContext fn+              -> StmtLR (GhcPass idL) (GhcPass idR) body+              -> SDoc+pprStmtInCtxt ctxt (LastStmt _ e _ _)+  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"+  = hang (text "In the expression:") 2 (ppr e)++pprStmtInCtxt ctxt stmt+  = 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+++pprMatchContext :: Outputable p => HsMatchContext p -> SDoc+pprMatchContext ctxt+  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt+  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt+  where+    want_an (FunRhs {})                              = True  -- Use "an" in front+    want_an (ArrowMatchCtxt ProcExpr)                = True+    want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True+    want_an LazyPatCtx                               = True+    want_an _                                        = False++pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for" <+> quotes (ppr fun)+pprMatchContextNoun CaseAlt                 = text "case alternative"+pprMatchContextNoun (LamAlt LamSingle)      = text "lambda abstraction"+pprMatchContextNoun (LamAlt lam_variant)    = lamCaseKeyword lam_variant+                                              <+> text "alternative"+pprMatchContextNoun IfAlt                   = text "multi-way if alternative"+pprMatchContextNoun RecUpd                  = text "record update"+pprMatchContextNoun ThPatSplice             = text "Template Haskell pattern splice"+pprMatchContextNoun ThPatQuote              = text "Template Haskell pattern quotation"+pprMatchContextNoun PatBindRhs              = text "pattern binding"+pprMatchContextNoun PatBindGuards           = text "pattern binding guards"+pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c+pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"+                                              $$ pprAStmtContext ctxt+pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"+pprMatchContextNoun LazyPatCtx              = text "irrefutable pattern"++pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for" <+> quotes (ppr fun)+pprMatchContextNouns PatBindGuards           = text "pattern binding guards"+pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c+pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"+                                               $$ pprAStmtContext ctxt+pprMatchContextNouns ctxt                    = pprMatchContextNoun ctxt <> char 's'++pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNoun ProcExpr                     = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt                 = text "case alternative within arrow notation"+pprArrowMatchContextNoun (ArrowLamAlt LamSingle)   = text "arrow kappa abstraction"+pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                     <+> text "alternative within arrow notation"++pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNouns ArrowCaseAlt              = text "case alternatives within arrow notation"+pprArrowMatchContextNouns (ArrowLamAlt LamSingle)   = text "arrow kappa abstractions"+pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                      <+> text "alternatives within arrow notation"+pprArrowMatchContextNouns ctxt                      = pprArrowMatchContextNoun ctxt <> char 's'++-----------------+pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt++-----------------+pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt+pprStmtContext ArrowExpr       = text "'do' block in an arrow command"++-- Drop the inner contexts when reporting errors, else we get+--     Unexpected transform statement+--     in a transformed branch of+--          transformed branch of+--          transformed branch of monad comprehension+pprStmtContext (ParStmtCtxt c) =+  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])+             (pprStmtContext c)+pprStmtContext (TransStmtCtxt c) =+  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])+             (pprStmtContext c)++pprStmtCat :: forall p body . IsPass p => Stmt (GhcPass p) body -> SDoc+pprStmtCat (TransStmt {})       = text "transform"+pprStmtCat (LastStmt {})        = text "return expression"+pprStmtCat (BodyStmt {})        = text "body"+pprStmtCat (BindStmt {})        = text "binding"+pprStmtCat (LetStmt {})         = text "let"+pprStmtCat (RecStmt {})         = text "rec"+pprStmtCat (ParStmt {})         = text "parallel"+pprStmtCat (XStmtLR _)          = text "applicative"++pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc+pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour+  where+    pp_an = text "an"+    pp_a  = text "a"+    article = case flavour of+                  MDoExpr Nothing -> pp_an+                  GhciStmtCtxt  -> pp_an+                  _             -> pp_a+pprHsDoFlavour (DoExpr m)      = prependQualified m (text "'do' block")+pprHsDoFlavour (MDoExpr m)     = prependQualified m (text "'mdo' block")+pprHsDoFlavour ListComp        = text "list comprehension"+pprHsDoFlavour MonadComp       = text "monad comprehension"+pprHsDoFlavour GhciStmtCtxt    = text "interactive GHCi command"++prependQualified :: Maybe ModuleName -> SDoc -> SDoc+prependQualified Nothing  t = t+prependQualified (Just _) t = text "qualified" <+> t++{-+************************************************************************+*                                                                      *+FieldLabelStrings+*                                                                      *+************************************************************************+-}++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where+  ppr (FieldLabelStrings flds) =+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where+  pprInfixOcc = pprFieldLabelStrings+  pprPrefixOcc = pprFieldLabelStrings++instance (UnXRec p,  Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where+  pprInfixOcc = pprInfixOcc . unLoc+  pprPrefixOcc = pprInfixOcc . unLoc++pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc+pprFieldLabelStrings (FieldLabelStrings flds) =+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))++pprPrefixFastString :: FastString -> SDoc+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)++instance UnXRec p => Outputable (DotFieldOcc p) where+  ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s+  ppr XDotFieldOcc{} = text "XDotFieldOcc"++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA+type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnC+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW++type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA++type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnLW+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnLW+type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA+type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA+type instance Anno [LocatedA (Pat (GhcPass p))] = EpaLocation+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = EpAnnCO+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA++type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA++type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW++type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO+type instance Anno FieldLabelString                = SrcSpanAnnN++type instance Anno FastString                      = EpAnnCO+  -- Used in HsQuasiQuote and perhaps elsewhere++type instance Anno (DotFieldOcc (GhcPass p))       = EpAnnCO++instance (HasAnnotation (Anno a))    => WrapXRec (GhcPass p) a where   wrapXRec = noLocA
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
@@ -25,10 +25,7 @@  import GHC.Prelude -import GHC.TypeLits (KnownSymbol, symbolVal)- import Data.Data hiding ( Fixity )-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader@@ -101,13 +98,21 @@ -}  -- 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 IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),+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)  instance UnXRec (GhcPass p) where@@ -174,11 +179,15 @@  -- | Allows us to check what phase we're in at GHC's runtime. -- For example, this class allows us to write--- >  f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah--- >  f e = case ghcPass @p of--- >          GhcPs ->    ... in this RHS we have HsExpr GhcPs...--- >          GhcRn ->    ... in this RHS we have HsExpr GhcRn...--- >          GhcTc ->    ... in this RHS we have HsExpr GhcTc...+--+-- @+-- f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah+-- f e = case ghcPass @p of+--         GhcPs ->    ... in this RHS we have HsExpr GhcPs...+--         GhcRn ->    ... in this RHS we have HsExpr GhcRn...+--         GhcTc ->    ... in this RHS we have HsExpr GhcTc...+-- @+-- -- which is very useful, for example, when pretty-printing. -- See Note [IsPass]. class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p@@ -201,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.@@ -217,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   ) @@ -236,16 +259,6 @@ pprIfTc pp = case ghcPass @p of GhcTc -> pp                                 _     -> empty -type instance Anno (HsToken tok) = TokenLocation--noHsTok :: GenLocated TokenLocation (HsToken tok)-noHsTok = L NoTokenLoc HsTok--type instance Anno (HsUniToken tok utok) = TokenLocation--noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)-noHsUniTok = L NoTokenLoc HsNormalTok- --- Outputable  instance Outputable NoExtField where@@ -253,12 +266,3 @@  instance Outputable DataConCantHappen where   ppr = dataConCantHappen--instance KnownSymbol tok => Outputable (HsToken tok) where-   ppr _ = text (symbolVal (Proxy :: Proxy tok))--instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where-   ppr HsNormalTok  = text (symbolVal (Proxy :: Proxy tok))-   ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok))--deriving instance Typeable p => Data (LayoutInfo (GhcPass p))
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@@ -21,25 +23,29 @@     , module GHC.Hs.ImpExp     ) where +import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name+import Language.Haskell.Syntax.ImpExp+ import GHC.Prelude  import GHC.Types.SourceText   ( SourceText(..) )-import GHC.Types.FieldLabel   ( FieldLabel )--import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Types.SrcLoc-import GHC.Parser.Annotation-import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.PkgQual +import GHC.Parser.Annotation+import GHC.Hs.Extension++import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Unit.Module.Warnings+ import Data.Data import Data.Maybe+import GHC.Hs.Doc (LHsDoc) -import Language.Haskell.Syntax.Extension-import Language.Haskell.Syntax.Module.Name-import Language.Haskell.Syntax.ImpExp  {- ************************************************************************@@ -53,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 EpaLocation-                         -> Maybe EpaLocation-                         -> (Maybe EpaLocation, 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@@ -70,6 +68,7 @@ isImportDeclQualified _ = True  + type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual@@ -77,11 +76,10 @@ type instance XCImportDecl  GhcPs = XImportDeclPass type instance XCImportDecl  GhcRn = XImportDeclPass type instance XCImportDecl  GhcTc = DataConCantHappen-                                 -- Note [Pragma source text] in GHC.Types.SourceText  data XImportDeclPass = XImportDeclPass     { ideclAnn        :: EpAnn EpAnnImportDecl-    , ideclSourceText :: SourceText+    , ideclSourceText :: SourceText -- Note [Pragma source text] in "GHC.Types.SourceText"     , ideclImplicit   :: Bool         -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude`         -- that appears in any file that omits `import Prelude`, setting@@ -93,7 +91,7 @@ type instance XXImportDecl  (GhcPass _) = DataConCantHappen  type instance Anno ModuleName = SrcSpanAnnA-type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL+type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI  deriving instance Data (IEWrappedName GhcPs) deriving instance Data (IEWrappedName GhcRn)@@ -108,14 +106,27 @@ -- API Annotations types  data EpAnnImportDecl = EpAnnImportDecl-  { importDeclAnnImport    :: EpaLocation-  , importDeclAnnPragma    :: Maybe (EpaLocation, EpaLocation)-  , importDeclAnnSafe      :: Maybe EpaLocation-  , importDeclAnnQualified :: Maybe EpaLocation-  , importDeclAnnPackage   :: Maybe EpaLocation-  , importDeclAnnAs        :: Maybe EpaLocation+  { 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  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@@ -125,6 +136,7 @@       ideclPkgQual    = NoRawPkgQual,       ideclSource     = NotBoot,       ideclSafe       = False,+      ideclLevelSpec  = NotLevelled,       ideclQualified  = NotQualified,       ideclAs         = Nothing,       ideclImportList = Nothing@@ -170,7 +182,7 @@                                 GhcTc -> dataConCantHappen ext             in case mSrcText of                   NoSourceText   -> text "{-# SOURCE #-}"-                  SourceText src -> text src <+> text "#-}"+                  SourceText src -> ftext src <+> text "#-}"         ppr_imp _ NotBoot = empty          pp_spec Nothing             = empty@@ -189,28 +201,51 @@ -}  type instance XIEName    (GhcPass _) = NoExtField-type instance XIEPattern (GhcPass _) = EpaLocation-type instance XIEType    (GhcPass _) = EpaLocation+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  type instance Anno (IE (GhcPass p)) = SrcSpanAnnA -type instance XIEVar             GhcPs = NoExtField-type instance XIEVar             GhcRn = NoExtField-type instance XIEVar             GhcTc = NoExtField+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEVar       GhcPs = Maybe (LWarningTxt GhcPs)+type instance XIEVar       GhcRn = Maybe (LWarningTxt GhcRn)+type instance XIEVar       GhcTc = NoExtField -type instance XIEThingAbs        (GhcPass _) = EpAnn [AddEpAnn]-type instance XIEThingAll        (GhcPass _) = EpAnn [AddEpAnn]+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEThingAbs  GhcPs = Maybe (LWarningTxt GhcPs)+type instance XIEThingAbs  GhcRn = Maybe (LWarningTxt GhcRn)+type instance XIEThingAbs  GhcTc = () --- See Note [IEThingWith]-type instance XIEThingWith       (GhcPass 'Parsed)      = EpAnn [AddEpAnn]-type instance XIEThingWith       (GhcPass 'Renamed)     = [Located FieldLabel]-type instance XIEThingWith       (GhcPass 'Typechecked) = NoExtField+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEThingAll  GhcPs = (Maybe (LWarningTxt GhcPs), (EpToken "(", EpToken "..", EpToken ")"))+type instance XIEThingAll  GhcRn = (Maybe (LWarningTxt GhcRn), (EpToken "(", EpToken "..", EpToken ")"))+type instance XIEThingAll  GhcTc = (EpToken "(", EpToken "..", EpToken ")") -type instance XIEModuleContents  GhcPs = EpAnn [AddEpAnn]-type instance XIEModuleContents  GhcRn = NoExtField+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), IEThingWithAnns)+type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), IEThingWithAnns)+type instance XIEThingWith GhcTc = IEThingWithAnns++type IEThingWithAnns = (EpToken "(", EpToken "..", EpToken ",", EpToken ")")++-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEModuleContents  GhcPs = (Maybe (LWarningTxt GhcPs), EpToken "module")+type instance XIEModuleContents  GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEModuleContents  GhcTc = NoExtField  type instance XIEGroup           (GhcPass _) = NoExtField@@ -220,55 +255,48 @@  type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA -{--Note [IEThingWith]-~~~~~~~~~~~~~~~~~~-A definition like--    {-# LANGUAGE DuplicateRecordFields #-}-    module M ( T(MkT, x) ) where-      data T = MkT { x :: Int }--gives rise to this in the output of the parser:--    IEThingWith NoExtField T [MkT, x] NoIEWildcard--But in the renamer we need to attach the correct field label,-because the selector Name is mangled (see Note [FieldLabel] in-GHC.Types.FieldLabel).  Hence we change this to:--    IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard--using the TTG extension field to store the list of fields in renamed syntax-only.  (Record fields always appear in this list, regardless of whether-DuplicateRecordFields was in use at the definition site or not.)--See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details.--}+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]-ieNames (IEThingAbs  _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingAll  _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n-                                     : map (ieWrappedName . unLoc) ns--- NB the above case does not include names of field selectors+ieNames (IEVar       _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingAbs  _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingAll  _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = [] ieNames (IEDoc            {})     = [] ieNames (IEDocNamed       {})     = [] +ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p))+ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p)+  where+    ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p))+    ie_deprecation GhcPs (IEVar xie _ _) = xie+    ie_deprecation GhcPs (IEThingAbs xie _ _) = xie+    ie_deprecation GhcPs (IEThingAll (xie, _) _ _) = xie+    ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _ _) = xie+    ie_deprecation GhcPs (IEModuleContents (xie, _) _) = xie+    ie_deprecation GhcRn (IEVar xie _ _) = xie+    ie_deprecation GhcRn (IEThingAbs xie _ _) = xie+    ie_deprecation GhcRn (IEThingAll (xie, _) _ _) = xie+    ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _ _) = xie+    ie_deprecation GhcRn (IEModuleContents xie _) = xie+    ie_deprecation _ _ = Nothing+ ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p)+ieWrappedLName (IEDefault _ (L l n)) = L l n 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@@ -281,20 +309,40 @@ ieLWrappedName (L _ n) = ieWrappedLName n  replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn+replaceWrappedName (IEDefault r (L l _)) n = IEDefault r (L l n) 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') +exportDocstring :: LHsDoc pass -> SDoc+exportDocstring doc = braces (text "docstring: " <> ppr doc)+ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where-    ppr (IEVar       _     var) = ppr (unLoc var)-    ppr (IEThingAbs  _   thing) = ppr (unLoc thing)-    ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]-    ppr (IEThingWith flds thing wc withs)-        = ppr (unLoc thing) <> parens (fsep (punctuate comma-                                              (ppWiths ++ ppFields) ))+    ppr ie@(IEVar       _     var doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc var)+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingAbs  _   thing doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc thing)+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingAll  _   thing doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ hcat [ppr (unLoc thing)+                      , text "(..)"]+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingWith _ thing wc withs doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))+                      , exportDocstring <$> doc+                      ]       where         ppWiths =           case wc of@@ -303,12 +351,8 @@               IEWildcard pos ->                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)                 in bs ++ [text ".."] ++ as-        ppFields =-          case ghcPass @p of-            GhcRn -> map ppr flds-            _     -> []-    ppr (IEModuleContents _ mod')-        = text "module" <+> ppr mod'+    ppr ie@(IEModuleContents _ mod')+        = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ text "module" <+> ppr mod']     ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")     ppr (IEDoc _ doc)             = ppr doc     ppr (IEDocNamed _ string)     = text ("<IEDocNamed: " ++ string ++ ">")@@ -322,9 +366,11 @@   pprInfixOcc  w = pprInfixOcc  (ieWrappedName w)  instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where+  ppr (IEDefault _ (L _ n)) = text "default" <+> pprPrefixOcc n   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-----------------------------------------@@ -256,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)@@ -287,6 +297,14 @@ deriving instance Data (FieldLabelStrings GhcRn) deriving instance Data (FieldLabelStrings GhcTc) +deriving instance Data (HsRecUpdParent GhcPs)+deriving instance Data (HsRecUpdParent GhcRn)+deriving instance Data (HsRecUpdParent GhcTc)++deriving instance Data (LHsRecUpdFields GhcPs)+deriving instance Data (LHsRecUpdFields GhcRn)+deriving instance Data (LHsRecUpdFields GhcTc)+ deriving instance Data (DotFieldOcc GhcPs) deriving instance Data (DotFieldOcc GhcRn) deriving instance Data (DotFieldOcc GhcTc)@@ -366,29 +384,42 @@ deriving instance Data (ParStmtBlock GhcRn GhcRn) deriving instance Data (ParStmtBlock GhcTc GhcTc) +-- deriving instance (DataIdLR p p) => Data (ApplicativeStmt p p)+deriving instance Data (ApplicativeStmt GhcPs GhcPs)+deriving instance Data (ApplicativeStmt GhcPs GhcRn)+deriving instance Data (ApplicativeStmt GhcPs GhcTc)+deriving instance Data (ApplicativeStmt GhcRn GhcPs)+deriving instance Data (ApplicativeStmt GhcRn GhcRn)+deriving instance Data (ApplicativeStmt GhcRn GhcTc)+deriving instance Data (ApplicativeStmt GhcTc GhcPs)+deriving instance Data (ApplicativeStmt GhcTc GhcRn)+deriving instance Data (ApplicativeStmt GhcTc GhcTc)+ -- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) deriving instance Data (ApplicativeArg GhcPs) deriving instance Data (ApplicativeArg GhcRn) deriving instance Data (ApplicativeArg GhcTc) -deriving instance Data (HsStmtContext GhcPs)-deriving instance Data (HsStmtContext GhcRn)-deriving instance Data (HsStmtContext GhcTc)- deriving instance Data HsArrowMatchContext -deriving instance Data HsDoFlavour--deriving instance Data (HsMatchContext GhcPs)-deriving instance Data (HsMatchContext GhcRn)-deriving instance Data (HsMatchContext GhcTc)+deriving instance Data fn => Data (HsStmtContext fn)+deriving instance Data fn => Data (HsMatchContext fn)  -- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p) deriving instance Data (HsUntypedSplice GhcPs) 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)@@ -417,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)@@ -437,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)@@ -450,6 +479,11 @@ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Type ---------------------------------- +-- deriving instance Data (HsBndrVis p)+deriving instance Data (HsBndrVis GhcPs)+deriving instance Data (HsBndrVis GhcRn)+deriving instance Data (HsBndrVis GhcTc)+ -- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) deriving instance Data (LHsQTyVars GhcPs) deriving instance Data (LHsQTyVars GhcRn)@@ -475,6 +509,11 @@ deriving instance Data (HsPatSigType GhcRn) deriving instance Data (HsPatSigType GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsTyPat p)+deriving instance Data (HsTyPat GhcPs)+deriving instance Data (HsTyPat GhcRn)+deriving instance Data (HsTyPat GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p) deriving instance Data (HsForAllTelescope GhcPs) deriving instance Data (HsForAllTelescope GhcRn)@@ -485,52 +524,56 @@ deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcTc) +-- deriving instance Data (HsBndrVar p)+deriving instance Data (HsBndrVar GhcPs)+deriving instance Data (HsBndrVar GhcRn)+deriving instance Data (HsBndrVar GhcTc)++-- deriving instance (DataIdLR p p) => Data (HsBndrKind p)+deriving instance Data (HsBndrKind GhcPs)+deriving instance Data (HsBndrKind GhcRn)+deriving instance Data (HsBndrKind GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsType p) deriving instance Data (HsType GhcPs) 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 (HsLinearArrowTokens p)-deriving instance Data (HsLinearArrowTokens GhcPs)-deriving instance Data (HsLinearArrowTokens GhcRn)-deriving instance Data (HsLinearArrowTokens GhcTc)---- deriving instance (DataIdLR p p) => Data (HsArrow p)-deriving instance Data (HsArrow GhcPs)-deriving instance Data (HsArrow GhcRn)-deriving instance Data (HsArrow GhcTc)+-- 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 (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 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 (Data a, Data b) => Data (HsArg a b)--- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs)))--- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn)))--- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind 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) => Data (ConDeclField p)-deriving instance Data (ConDeclField GhcPs)-deriving instance Data (ConDeclField GhcRn)-deriving instance Data (ConDeclField 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) deriving instance Data (FieldOcc GhcTc) --- deriving instance DataId p       => Data (AmbiguousFieldOcc p)-deriving instance Data (AmbiguousFieldOcc GhcPs)-deriving instance Data (AmbiguousFieldOcc GhcRn)-deriving instance Data (AmbiguousFieldOcc GhcTc)-- -- deriving instance (DataId name) => Data (ImportDecl name) deriving instance Data (ImportDecl GhcPs) deriving instance Data (ImportDecl GhcRn)@@ -548,6 +591,12 @@  -- --------------------------------------------------------------------- +deriving instance Data HsThingRn+deriving instance Data XXExprGhcRn+deriving instance Data a => Data (WithUserRdr a)++-- ---------------------------------------------------------------------+ deriving instance Data XXExprGhcTc deriving instance Data XXPatGhcTc @@ -556,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
@@ -25,11 +25,14 @@  import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) +import GHC.Data.FastString (unpackFS) import GHC.Types.Basic (PprPrec(..), topPrec ) import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type+import GHC.Utils.Misc (split) import GHC.Utils.Outputable+import GHC.Utils.Panic (panic) import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension@@ -46,18 +49,40 @@ type instance XHsChar       (GhcPass _) = SourceText type instance XHsCharPrim   (GhcPass _) = SourceText type instance XHsString     (GhcPass _) = SourceText+type instance XHsMultilineString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText type instance XHsInt        (GhcPass _) = NoExtField type instance XHsIntPrim    (GhcPass _) = SourceText type instance XHsWordPrim   (GhcPass _) = SourceText+type instance XHsInt8Prim   (GhcPass _) = SourceText+type instance XHsInt16Prim  (GhcPass _) = SourceText+type instance XHsInt32Prim  (GhcPass _) = SourceText type instance XHsInt64Prim  (GhcPass _) = SourceText+type instance XHsWord8Prim  (GhcPass _) = SourceText+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]@@ -120,37 +145,55 @@ -- -- 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     go (HsCharPrim {})    = False     go (HsString {})      = False+    go (HsMultilineString {}) = False     go (HsStringPrim {})  = False     go (HsInt _ x)        = p > topPrec && il_neg x+    go (HsFloatPrim {})   = False+    go (HsDoublePrim {})  = False     go (HsIntPrim {})     = False-    go (HsWordPrim {})    = False+    go (HsInt8Prim {})    = False+    go (HsInt16Prim {})   = False+    go (HsInt32Prim {})   = False     go (HsInt64Prim {})   = False+    go (HsWordPrim {})    = False+    go (HsWord8Prim {})   = False+    go (HsWord16Prim {})  = False     go (HsWord64Prim {})  = False-    go (HsInteger _ x _)  = p > topPrec && x < 0-    go (HsRat _ x _)      = p > topPrec && fl_neg x-    go (HsFloatPrim {})   = False-    go (HsDoublePrim {})  = False-    go (XLit _)           = False+    go (HsWord32Prim {})  = 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+convertLit (HsMultilineString a x) = HsMultilineString a x convertLit (HsStringPrim a x) = HsStringPrim a x convertLit (HsInt a x)        = HsInt a x convertLit (HsIntPrim a x)    = HsIntPrim a x convertLit (HsWordPrim a x)   = HsWordPrim a x+convertLit (HsInt8Prim a x)   = HsInt8Prim a x+convertLit (HsInt16Prim a x)  = HsInt16Prim a x+convertLit (HsInt32Prim a x)  = HsInt32Prim a x convertLit (HsInt64Prim a x)  = HsInt64Prim a x+convertLit (HsWord8Prim a x)  = HsWord8Prim a x+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 @@ -170,21 +213,33 @@ -}  -- 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)+    ppr (HsMultilineString st s) =+      case st of+        NoSourceText -> pprHsString s+        SourceText src -> vcat $ map text $ split '\n' (unpackFS src)     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)-    ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)+    ppr (HsInt8Prim st i)   = pprWithSourceText st (pprPrimInt8 i)+    ppr (HsInt16Prim st i)  = pprWithSourceText st (pprPrimInt16 i)+    ppr (HsInt32Prim st i)  = pprWithSourceText st (pprPrimInt32 i)     ppr (HsInt64Prim st i)  = pprWithSourceText st (pprPrimInt64 i)+    ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)+    ppr (HsWord8Prim st w)  = pprWithSourceText st (pprPrimWord8 w)+    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@@ -203,18 +258,43 @@ -- 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)+pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i)        = integer (il_value i) pmPprHsLit (HsIntPrim _ i)    = integer i pmPprHsLit (HsWordPrim _ w)   = integer w+pmPprHsLit (HsInt8Prim _ i)   = integer i+pmPprHsLit (HsInt16Prim _ i)  = integer i+pmPprHsLit (HsInt32Prim _ i)  = integer i pmPprHsLit (HsInt64Prim _ i)  = integer i+pmPprHsLit (HsWord8Prim _ w)  = integer w+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)+negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)+negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"++instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where+  compare (OverLit _ val1)  (OverLit _ val2) = val1 `compare` val2+  compare (XOverLit  val1)  (XOverLit  val2) = val1 `compare` val2+  compare _ _ = panic "Ord HsOverLit"++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where+  (OverLit _ val1) == (OverLit _ val2) = val1 == val2+  (XOverLit  val1) == (XOverLit  val2) = val1 == val2+  _ == _ = panic "Eq HsOverLit"
compiler/GHC/Hs/Pat.hs view
@@ -4,10 +4,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension @@ -22,6 +24,8 @@  module GHC.Hs.Pat (         Pat(..), LPat,+        isInvisArgPat, isInvisArgLPat,+        isVisArgPat, isVisArgLPat,         EpAnnSumPat(..),         ConPatTc (..),         ConLikeP,@@ -29,22 +33,22 @@         XXPatGhcTc(..),          HsConPatDetails, hsConPatArgs,-        HsConPatTyArg(..),         HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,         RecFieldsDotDot(..),         hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,-        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,          mkPrefixConPat, mkCharLitPat, mkNilPat, -        isSimplePat,+        isSimplePat, isPatSyn,         looksLazyPatBind,         isBangedLPat,         gParPat, patNeedsParens, parenthesizePat,         isIrrefutableHsPat, +        isBoringHsPat,+         collectEvVarsPat, collectEvVarsPats,          pprParendLPat, pprConArgs,@@ -72,20 +76,19 @@ import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Builtin.Types import GHC.Types.Var-import GHC.Types.Name.Reader ( RdrName )+import GHC.Types.Name.Reader import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Core.Type import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats-import GHC.Data.Maybe-import GHC.Types.Name (Name, dataName)-import GHC.Driver.Session-import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.Name+ import Data.Data+import qualified Data.List( map ) +import qualified Data.List.NonEmpty as NE  type instance XWildPat GhcPs = NoExtField type instance XWildPat GhcRn = NoExtField@@ -93,21 +96,23 @@  type instance XVarPat  (GhcPass _) = NoExtField -type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~'+type instance XLazyPat GhcPs = EpToken "~" type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat   GhcPs = EpAnnCO+type instance XAsPat   GhcPs = EpToken "@" type instance XAsPat   GhcRn = NoExtField type instance XAsPat   GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnnCO+type instance XParPat  GhcPs = (EpToken "(", EpToken ")")+type instance XParPat  GhcRn = NoExtField+type instance XParPat  GhcTc = NoExtField -type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'+type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = EpAnn AnnList+type instance XListPat GhcPs = AnnList ()   -- After parsing, ListPat can refer to a built-in Haskell list pattern   -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField@@ -117,19 +122,23 @@ type instance XListPat GhcTc = Type   -- List element type, for use in hsPatType. -type instance XTuplePat GhcPs = EpAnn [AddEpAnn]+type instance XTuplePat GhcPs = (EpaLocation, EpaLocation) type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = EpAnn EpAnnSumPat+type instance XOrPat GhcPs = NoExtField+type instance XOrPat GhcRn = NoExtField+type instance XOrPat GhcTc = Type++type instance XSumPat GhcPs = EpAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XConPat GhcPs = EpAnn [AddEpAnn]+type instance XConPat GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) type instance XConPat GhcRn = NoExtField type instance XConPat GhcTc = ConPatTc -type instance XViewPat GhcPs = EpAnn [AddEpAnn]+type instance XViewPat GhcPs = TokRarrow type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)   -- The @HsExpr GhcRn@ gives an inverse to the view function.   -- This is used for overloaded lists in particular.@@ -145,43 +154,128 @@  type instance XLitPat    (GhcPass _) = NoExtField -type instance XNPat GhcPs = EpAnn [AddEpAnn]-type instance XNPat GhcRn = EpAnn [AddEpAnn]+type instance XNPat GhcPs = EpToken "-"+type instance XNPat GhcRn = EpToken "-" type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+"+type instance XNPlusKPat GhcPs = EpToken "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = EpAnn [AddEpAnn]+type instance XSigPat GhcPs = TokDcolon type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type +type instance XEmbTyPat GhcPs = EpToken "type"+type instance XEmbTyPat GhcRn = NoExtField+type instance XEmbTyPat GhcTc = Type+ type instance XXPat GhcPs = DataConCantHappen type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)   -- Original pattern and its desugaring/expansion.-  -- See Note [Rebindable syntax and HsExpansion].+  -- See Note [Rebindable syntax and XXExprGhcRn]. type instance XXPat GhcTc = XXPatGhcTc-  -- After typechecking, we add extra constructors: CoPat and HsExpansion.-  -- HsExpansion allows us to handle RebindableSyntax in pattern position:+  -- After typechecking, we add extra constructors: CoPat and XXExprGhcRn.+  -- 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 XHsFieldBind _ = EpAnn [AddEpAnn]+type instance XHsRecFields GhcPs = NoExtField+type instance XHsRecFields GhcRn = NoExtField+type instance XHsRecFields GhcTc = NoExtField +type instance XHsFieldBind _ = Maybe (EpToken "=")++-- The specificity of an invisible pattern from the parser is always+-- SpecifiedSpec. The specificity field supports code generated when deriving+-- newtype or via; see Note [Inferred invisible patterns].+type instance XInvisPat GhcPs = (EpToken "@", Specificity)+type instance XInvisPat GhcRn = Specificity+type instance XInvisPat GhcTc = Type+++{- Note [Invisible binders in functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC Proposal #448 (section 1.5 Type arguments in lambda patterns) introduces+binders for invisible type arguments (@a-binders) in function equations and+lambdas, e.g.++  1.  {-# LANGUAGE TypeAbstractions #-}+      id1 :: a -> a+      id1 @t x = x :: t     -- @t-binder on the LHS of a function equation++  2.  {-# LANGUAGE TypeAbstractions #-}+      ex :: (Int8, Int16)+      ex = higherRank (\ @a x -> maxBound @a - x )+                            -- @a-binder in a lambda pattern in an argument+                            -- to a higher-order function+      higherRank :: (forall a. (Num a, Bounded a) => a -> a) -> (Int8, Int16)+      higherRank f = (f 42, f 42)++In the AST, invisible patterns are represented as InvisPat constructor inside of Pat:+    data Pat p+      = ...+      | InvisPat (LHsType p)+      ...++Just like `BangPat`, the `Pat` data type allows `InvisPat` to appear in+nested positions. But this is often not allowed; e.g.++   f @a x = rhs    -- YES+   f (@a,x) = rhs  -- NO++   g = do { @a <- e1; e2 }         -- NO+   h x = case x of { @a -> rhs }   -- NO++Rather than excluding these things syntactically, we reject them in the renamer+(see `rn_pats_general`).  This actually gives a better error message than we+would get if they were rejected in the parser.++Each pattern is either visible (not prefixed with @) or invisible (prefixed with @):+    f :: forall a. forall b -> forall c. Int -> ...+    f @a b @c x  = ...++In this example, the arg-patterns are+    1. InvisPat @a     -- in the type sig: forall a.+    2. VarPat b        -- in the type sig: forall b ->+    3. InvisPat @c     -- in the type sig: forall c.+    4. VarPat x        -- in the type sig: Int ->++Invisible patterns are always type patterns, i.e. they are matched with+forall-bound type variables in the signature. Consequently, those variables (and+their binders) are erased during compilation, having no effect on program+execution at runtime.++Visible patterns, on the other hand, may be matched with ordinary function+arguments (Int ->) as well as required type arguments (forall b ->). This means+that a visible pattern may either be erased or retained, and we only find out in+the type checker, namely in tcMatchPats, where we match up all arg-patterns with+quantifiers from the type signature.++In other words, invisible patterns are always /erased/, while visible patterns+are sometimes /erased/ and sometimes /retained/.++The desugarer has no use for erased patterns, as the type checker generates+HsWrappers to bind the corresponding type variables. Erased patterns are simply+discarded inside tcMatchPats, where we know if visible pattern retained or erased.+-}+ -- ---------------------------------------------------------------------  -- API Annotations types  data EpAnnSumPat = EpAnnSumPat-      { sumPatParens      :: [AddEpAnn]-      , sumPatVbarsBefore :: [EpaLocation]-      , sumPatVbarsAfter  :: [EpaLocation]+      { sumPatParens      :: (EpaLocation, EpaLocation)+      , sumPatVbarsBefore :: [EpToken "|"]+      , sumPatVbarsAfter  :: [EpToken "|"]       } deriving Data +instance NoAnn EpAnnSumPat where+  noAnn = EpAnnSumPat (noAnn, noAnn) [] []+ -- ---------------------------------------------------------------------  -- | Extension constructor for Pat, added after typechecking.@@ -204,11 +298,11 @@       }   -- | Pattern expansion: original pattern, and desugared pattern,   -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.-  -- See Note [Rebindable syntax and HsExpansion].+  -- See Note [Rebindable syntax and XXExprGhcRn].   | ExpansionPat (Pat GhcRn) (Pat GhcTc)  --- See Note [Rebindable syntax and HsExpansion].+-- See Note [Rebindable syntax and XXExprGhcRn]. data HsPatExpansion a b   = HsPatExpanded a b   deriving Data@@ -241,18 +335,18 @@       cpt_wrap  :: HsWrapper     } -hsRecFieldId :: HsRecField GhcTc arg -> Id-hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS+hsRecFields :: HsRecFields (GhcPass p) arg -> [IdGhcP p]+hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds) -hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id-hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc+hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg]+hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds) -hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc-hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS+hsRecFieldSel :: HsRecField (GhcPass p) arg -> IdGhcP p+hsRecFieldSel = unLoc . foLabel . unLoc . hfbLHS +hsRecFieldId :: HsRecField GhcTc arg -> Id+hsRecFieldId = hsRecFieldSel  {- ************************************************************************@@ -262,10 +356,7 @@ ************************************************************************ -} -instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where-  ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty--instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)+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 })         = braces (fsep (punctuate comma (map ppr flds)))@@ -283,7 +374,7 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where     ppr = pprPat --- See Note [Rebindable syntax and HsExpansion].+-- See Note [Rebindable syntax and XXExprGhcRn]. instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where   ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a) @@ -328,10 +419,10 @@ pprPat (WildPat _)              = char '_' pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat-pprPat (AsPat _ name _ pat)     = hcat [pprPrefixOcc (unLoc name), char '@',+pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',                                         pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]-pprPat (ParPat _ _ pat _)      = parens (ppr pat)+pprPat (ParPat _ pat)           = parens (ppr pat) pprPat (LitPat _ s)             = ppr s pprPat (NPat _ l Nothing  _)    = ppr l pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l@@ -348,6 +439,7 @@       GhcTc -> dataConCantHappen ext pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats)         = brackets (interpp'SP pats)+pprPat (OrPat _ pats)           = pprWithSemis ppr (NE.toList pats) pprPat (TuplePat _ pats bx)     -- Special-case unary boxed tuples so that they are pretty-printed as     -- `MkSolo x`, not `(x)`@@ -378,11 +470,20 @@                        , cpt_dicts = dicts                        , cpt_binds = binds                        } = ext+pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp+pprPat (InvisPat x tp) = char '@' <> delimit (ppr tp)+  where+    delimit+      | inferred     = braces+      | needs_parens = parens+      | otherwise    = id+    inferred = case ghcPass @p of+      GhcPs -> snd x == InferredSpec+      GhcRn -> x == InferredSpec+      GhcTc -> False+    needs_parens = hsTypeNeedsParens appPrec $ unLoc $ hstp_body tp  pprPat (XPat ext) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> dataConCantHappen ext-#endif   GhcRn -> case ext of     HsPatExpanded orig _ -> pprPat orig   GhcTc -> case ext of@@ -402,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@@ -421,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 = []@@ -474,7 +574,7 @@ isBangedLPat = isBangedPat . unLoc  isBangedPat :: Pat (GhcPass p) -> Bool-isBangedPat (ParPat _ _ p _) = isBangedLPat p+isBangedPat (ParPat _ p) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _            = False @@ -487,7 +587,7 @@ looksLazyPatBind (PatBind { pat_lhs = p })   = looksLazyLPat p looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds }))-  = anyBag (looksLazyPatBind . unLoc) binds+  = any (looksLazyPatBind . unLoc) binds looksLazyPatBind _   = False @@ -495,30 +595,13 @@ looksLazyLPat = looksLazyPat . unLoc  looksLazyPat :: Pat (GhcPass p) -> Bool-looksLazyPat (ParPat _ _ p _)  = looksLazyLPat p-looksLazyPat (AsPat _ _ _ p)   = looksLazyLPat p+looksLazyPat (ParPat _ p)  = looksLazyLPat p+looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {})  = False looksLazyPat (VarPat {})   = False looksLazyPat (WildPat {})  = False looksLazyPat _             = True -isIrrefutableHsPat :: forall p. (OutputableBndrId p)-                   => DynFlags -> LPat (GhcPass p) -> Bool--- (isIrrefutableHsPat p) is true if matching against p cannot fail,--- in the sense of falling through to the next pattern.---      (NB: this is not quite the same as the (silly) defn---      in 3.17.2 of the Haskell 98 report.)------ WARNING: isIrrefutableHsPat returns False if it's in doubt.--- Specifically on a ConPatIn, which is what it sees for a--- (LPat Name) in the renamer, it doesn't know the size of the--- constructor family, so it returns False.  Result: only--- tuple patterns are considered irrefutable at the renamer stage.------ But if it returns True, the pattern is definitely irrefutable-isIrrefutableHsPat dflags =-    isIrrefutableHsPat' (xopt LangExt.Strict dflags)- {- Note [-XStrict and irrefutability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -545,43 +628,55 @@ See also Note [decideBangHood] in GHC.HsToCore.Utils. -} -isIrrefutableHsPat' :: forall p. (OutputableBndrId p)-                    => Bool -- ^ Are we in a @-XStrict@ context?-                            -- See Note [-XStrict and irrefutability]-                    -> LPat (GhcPass p) -> Bool-isIrrefutableHsPat' is_strict = goL+-- | @isIrrefutableHsPat p@ is true if matching against @p@ cannot fail+-- in the sense of falling through to the next pattern.+--      (NB: this is not quite the same as the (silly) defn+--      in 3.17.2 of the Haskell 98 report.)+--+-- If isIrrefutableHsPat returns 'True', the pattern is definitely irrefutable.+--+-- However, isIrrefutableHsPat returns 'False' if it's in doubt. It's a+-- best effort guess with the information we have available:+--+--  - we sometimes call 'isIrrefutableHsPat' from the renamer, in which case+--    we don't have type information to hand. This means we can't properly+--    handle GADTs, nor the result TyCon of COMPLETE pragmas.+--  - even when calling 'isIrrefutableHsPat' in the typechecker, we don't keep+--    track of any long distance information like the pattern-match checker does.+isIrrefutableHsPat+  :: forall p+  .  IsPass p+  => Bool                           -- ^ Are we in a @-XStrict@ context?+                                    -- See Note [-XStrict and irrefutability]+  -> (ConLikeP (GhcPass p) -> Bool) -- ^ How to check whether the 'ConLike' in a+                                    -- 'ConPat' pattern is irrefutable+  -> LPat (GhcPass p)               -- ^ The (located) pattern to check+  -> Bool                           -- Is it irrefutable?+isIrrefutableHsPat is_strict irref_conLike pat = go (unLoc pat)   where-    goL :: LPat (GhcPass p) -> Bool-    goL = go . unLoc+    goL (L _ p) = go p      go :: Pat (GhcPass p) -> Bool     go (WildPat {})        = True     go (VarPat {})         = True     go (LazyPat _ p')       | is_strict-      = isIrrefutableHsPat' False p'+      = isIrrefutableHsPat False irref_conLike p'       | otherwise          = True     go (BangPat _ pat)     = goL pat-    go (ParPat _ _ pat _)  = goL pat-    go (AsPat _ _ _ pat)   = goL pat+    go (ParPat _ pat)      = goL pat+    go (AsPat _ _ pat)     = goL pat     go (ViewPat _ _ pat)   = goL pat     go (SigPat _ pat _)    = goL pat     go (TuplePat _ pats _) = all goL pats-    go (SumPat {})         = False-                    -- See Note [Unboxed sum patterns aren't irrefutable]+    go (OrPat _ pats)      = any goL pats -- This is simplistic; see Note [Irrefutable or-patterns]+    go (SumPat {})         = False -- See Note [Unboxed sum patterns aren't irrefutable]     go (ListPat {})        = False -    go (ConPat-        { pat_con  = con-        , pat_args = details })-                           = case ghcPass @p of-       GhcPs -> False -- Conservative-       GhcRn -> False -- Conservative-       GhcTc -> case con of-         L _ (PatSynCon _pat)  -> False -- Conservative-         L _ (RealDataCon con) ->-           isJust (tyConSingleDataCon_maybe (dataConTyCon con))-           && all goL (hsConPatArgs details)+    -- See Note [Irrefutability of ConPat]+    go (ConPat { pat_con = L _ con, pat_args = details })+                           =  irref_conLike con+                           && all goL (hsConPatArgs details)     go (LitPat {})         = False     go (NPat {})           = False     go (NPlusKPat {})      = False@@ -590,10 +685,12 @@     -- since we cannot know until the splice is evaluated.     go (SplicePat {})      = False +    -- The behavior of this case is unimportant, as GHC will throw an error shortly+    -- after reaching this case for other reasons (see TcRnIllegalTypePattern).+    go (EmbTyPat {})       = True+    go (InvisPat {})       = True+     go (XPat ext)          = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-      GhcPs -> dataConCantHappen ext-#endif       GhcRn -> case ext of         HsPatExpanded _ pat -> go pat       GhcTc -> case ext of@@ -609,16 +706,157 @@ -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of-  ParPat _ _ x _ -> isSimplePat x+  ParPat _ x -> isSimplePat x   SigPat _ x _ -> isSimplePat x   LazyPat _ x -> isSimplePat x   BangPat _ x -> isSimplePat x   VarPat _ x -> Just (unLoc x)   _ -> Nothing +-- | Is this pattern boring from the perspective of pattern-match checking,+-- i.e. introduces no new pieces of long-distance information+-- which could influence pattern-match checking?+--+-- See Note [Boring patterns].+isBoringHsPat :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool+-- NB: it's always safe to return 'False' in this function; that just means+-- performing potentially-redundant pattern-match checking.+isBoringHsPat = goL+  where+    goL :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool+    goL = go . unLoc -{- Note [Unboxed sum patterns aren't irrefutable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    go :: forall p. OutputableBndrId p => Pat (GhcPass p) -> Bool+    go = \case+      WildPat {} -> True+      VarPat  {} -> True+      LazyPat {} -> True+      BangPat _ pat     -> goL pat+      ParPat _ pat      -> goL pat+      AsPat {} -> False -- the pattern x@y links x and y together,+                        -- which is a nontrivial piece of information+      ViewPat _ _ pat   -> goL pat+      SigPat _ pat _    -> goL pat+      TuplePat _ pats _ -> all goL pats+      SumPat  _ pat _ _ -> goL pat+      ListPat _ pats    -> all goL pats+      ConPat { pat_con = con, pat_args = details }+        -> case ghcPass @p of+            GhcPs -> False -- conservative+            GhcRn -> False -- conservative+            GhcTc+              | isVanillaConLike (unLoc con)+              -> all goL (hsConPatArgs details)+              | otherwise+              -- A pattern match on a GADT constructor can introduce+              -- type-level information (for example, T18572).+              -> False+      OrPat _ pats  -> all goL pats+      LitPat {}     -> True+      NPat {}       -> True+      NPlusKPat {}  -> True+      SplicePat {}  -> False+      EmbTyPat {}   -> True+      InvisPat {}   -> True+      XPat ext ->+        case ghcPass @p of+         GhcRn -> case ext of+           HsPatExpanded _ pat -> go pat+         GhcTc -> case ext of+           CoPat _ pat _      -> go pat+           ExpansionPat _ pat -> go pat++isPatSyn :: LPat GhcTc -> Bool+isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True+isPatSyn _ = False++{- Note [Irrefutability of ConPat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A constructor pattern `ConPat { pat_con, pat_args }` is irrefutable under two+conditions:++  Irref-ConLike: the constructor, pat_con, is itself irrefutable.+  Irref-args   : all of the argument patterns, pat_args, are irrefutable.++The (Irref-ConLike) condition can be stated as follows:++  Irref-DataCon: a DataCon is irrefutable iff it is the only constructor of its+                 parent type constructor.+  Irref-PatSyn:  a PatSyn is irrefutable iff there is a COMPLETE pragma+                 containing this PatSyn as its sole member.++To understand this, let's consider some simple examples:++  data A = MkA Int Bool+  data BC = B Int | C++  pattern P :: Maybe Int -> BC+  pattern P mb_i <- ( ( \ case { B i -> Just i; C -> Nothing } ) -> mb_i )+  {-# COMPLETE P #-}++In this case:++  - the pattern 'A p1 p2' (for patterns 'p1 :: Int', 'p2 :: Bool') is irrefutable+    precisely when both 'p1' and 'p2' are irrefutable (this is the same as+    irrefutability of tuple patterns);+  - neither of the patterns 'B p' (for any pattern 'p :: Int') or 'C' are irrefutable,+    because the parent type constructor 'BC' contains more than one data constructor,+  - the pattern 'P q', for a pattern 'q :: Maybe Int', is irrefutable precisely+    when 'q' is irrefutable, due to the COMPLETE pragma on 'P'.++Wrinkle [Irrefutability and COMPLETE pragma result TyCons]++  There is one subtlety in the Irref-PatSyn condition: COMPLETE pragmas may+  optionally specify a result TyCon, as explained in Note [Implementation of COMPLETE pragmas]+  in GHC.HsToCore.Pmc.Solver.++  So, for a COMPLETE pragma with a result TyCon, we would need to compute+  'completeMatchAppliesAtType' to ensure that the COMPLETE pragma is indeed+  applicable. Doing so is not so straightforward in 'isIrrefutableHsPat', for+  a couple of reasons:++    1. 'isIrrefutableHsPat' is called from within the renamer, which means+       we don't have the appropriate 'Type' to hand,+    2. Even when 'isIrrefutableHsPat' is called from within the typechecker,+       computing 'completeMatchAppliesAtType' for a 'ConPat' which might be+       nested deep inside the top-level call, such as++          ( ( _ , P (x :: Int) ) :: ( Int, Int )++        would require keeping track of types as we recur in 'isIrrefutableHsPat',+        which would be much more involved and require duplicating code from+        the pattern match checker (it performs this check using the notion+        of "match variables", which we don't have in the typechecker).++Note [Irrefutable or-patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When is an or-pattern ( p_1 ; ... ; p_n ) irrefutable? It certainly suffices+that individual pattern p_i is irrefutable, but it isn't necessary.++For example, with the datatype definition++  data ABC = A | B | C++the or-pattern ( B ; C ; A ) is irrefutable. Similarly, one can take into+account COMPLETE pragmas, e.g. (P ; R ; Q) is irrefutable in the presence of+{-# COMPLETE P, Q, R #-}. This would extend Note [Irrefutability of ConPat] to+the case of disjunctions of constructor patterns.++For now, the function 'isIrrefutableHsPat' does not take into account these+additional complications, and considers an or-pattern irrefutable precisely when+any of the summands are irrefutable. This pessimistic behaviour is OK: the contract+of 'isIrrefutableHsPat' is that it can only return 'True' for definitely irrefutable+patterns, but may conservatively return 'False' in other cases.++The justification for this design choice is as follows:++  1. Producing the correct answer in all cases would be rather difficult,+     for example for a complex pattern such as ( P ; !( R ; S ; ( Q :: Ty ) ) ).+  2. Irrefutable or-patterns aren't particularly common or useful, given that+     (currently) or-patterns aren't allowed to bind variables.++Note [Unboxed sum patterns aren't irrefutable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as patterns. A simple example that demonstrates this is from #14228: @@ -637,8 +875,182 @@ Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' case in foo to be unreachable, as GHC would mistakenly believe that Nothing' is the only thing that could possibly be matched!++Note [Boring patterns]+~~~~~~~~~~~~~~~~~~~~~~+A pattern is called boring when no new information is gained upon successfully+matching on the pattern.++Some examples of boring patterns:++  - x, for a variable x. We learn nothing about x upon matching this pattern.+  - Just y. This pattern can fail, but if it matches, we don't learn anything+    about y.++Some examples of non-boring patterns:++  - x@(Just y). A match on this pattern introduces the fact that x is headed+    by the constructor Just, which means that a subsequent pattern match such as++      case x of { Just z -> ... }++    should not be marked as incomplete.+  - a@b. Matching on this pattern introduces a relation between 'a' and 'b',+    which means that we shouldn't emit any warnings in code of the form++      case a of+        True -> case b of { True -> .. } -- no warning here!+        False -> ...+  - GADT patterns. For example, with the GADT++      data G i where { MkGInt :: G Int }++    a match on the pattern 'MkGInt' introduces type-level information:++      foo :: G i -> i+      foo MkGInt = 3++    Here we learn that i ~ Int after matching on 'MkGInt', so this pattern+    is not boring.++When a pattern is boring, and we are only interested in additional long-distance+information (not whether the pattern itself is fallible), we can skip pattern-match+checking entirely. Doing this saves about 10% allocations in test T11195.++This happens when we are checking pattern-matches in do-notation, for example:++  do { x@(Just y) <- z+     ; ...+     ; return $ case x of { Just w -> ... } }++Here we *do not* want to emit a pattern-match warning on the first line for the+incomplete pattern-match, as incompleteness inside do-notation is handled+using MonadFail. However, we still want to propagate the fact that x is headed+by the 'Just' constructor, to avoid a pattern-match warning on the last line.++Note [Implementation of OrPatterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes the implementation of the extension -XOrPatterns.++* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0522-or-patterns.rst+* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/522 and others++Parser+------+We parse an or-pattern `pat_1; ...; pat_k` into `OrPat [pat_1, ..., pat_k]`,+where `OrPat` is a constructor of `Pat` in Language.Haskell.Syntax.Pat.+We occasionally refer to any of the `pat_k` as "pattern alternatives" below.+The changes to the parser are as outlined in Section 8.1 of the proposal.+The main productions are++  orpats -> exp | exp ';' orpats+  aexp2 -> '(' orpats ')'+  pat -> orpats++Renamer and typechecker+-----------------------+The typing rule for or-patterns in terms of pattern types is++                   Γ0, Σ0 ⊢ pat_i : τ ⤳ Γ0,Σi,Ψi+            --------------------------------------------+            Γ0, Σ0 ⊢ ( pat_1; ...; pat_n ) : τ ⤳ Γ0,Σ0,∅++(See the proposal for what a pattern type `Γ, Σ ⊢ pat : τ ⤳ Γ,Σ,Ψ` is.)+The main points++  * None of the patterns may bind any variables, hence the same Γ0 in both input+    and output.+  * Any Given constraints bound by the pattern are discarded: the rule discards+    the Σi returned by each pattern.+  * Similarly any existentials Ψi bound by the pattern are discarded.++In GHC.Rename.Pat.rnPatAndThen, we reject visible term and type binders (i.e.+concerning Γ0).++Regarding the Givens Σi and existenials Ψi (i.e. invisible type binders)+introduced by the pattern alternatives `pat_i`, we discard them in+GHC.Tc.Gen.Pats.tc_pat in a manner similar to LazyPats;+see Note [Hopping the LIE in lazy patterns].++Why is it useful to allow Σi and Ψi only to discard them immediately after?+Consider++  data T a where MkT :: forall a x. Num a => x -> T a+  foo :: T a -> a+  foo (MkT{}; MkT{}) = 3++We do want to allow matching on MkT{} in or-patterns, despite them invisibly+binding an existential type variable `x` and a new Given constraint `Num a`.+Clearly, `x` must be dead in the RHS of foo, because there is no field binder+that brings it to life, so no harm done.+But we must be careful not to solve the `Num a` Wanted constraint in the RHS of+foo with the Given constraint from the pattern alternatives, hence we are+Hopping the LIE.++Desugarer+---------+The desugaring of or-patterns is complicated by the fact that we have to avoid+exponential code blowup. Consider+  f (LT; GT) (EQ; GT) = rhs1+  f _        _        = rhs2+The naïve desugaring of or-patterns would explode every or-pattern, thus+  f LT EQ = rhs1+  f LT GT = rhs1+  f GT EQ = rhs1+  f GT GT = rhs1+  f _  _  = rhs2+which leads to an exponential number of copies of `rhs1`.+Our current strategy, implemented in GHC.HsToCore.Match.tidy1, is to+desugar to LambdaCase and ViewPatterns,+  f ((\case LT -> True; GT -> True; _ -> False) -> True)+    ((\case EQ -> True; GT -> True; _ -> False) -> True)+    = rhs1+  f _ _ = rhs2+The existing code for ViewPatterns makes sure that we do not duplicate `rhs1`+and the Simplifier will take care to turn this into efficient code.++Pattern-match checker+---------------------+The changes to the pattern-match checker are described in detail in Section 4.9+of the 2024 revision of the "Lower Your Guards" paper.+What follows is a brief summary of that change.++The pattern-match checker desugars patterns as well, into syntactic variants of+*guard trees* such as `PmMatch`, describing a single Match `f ps | grhss`.+It used to be that each such guard trees nicely captured the effects of pattern+matching `ps` in a conjunctive list of `PmGrd`s, each of which refines+the set of Nablas that reach the RHS of the clause.+`PmGrd` is the heart of the Lower Your Guards approach: it is compositional,+simple, and *non-recursive*, unlike or-patterns!+Conjunction is implemented with the `...Pmc.Check.leftToRight` combinator.+But to desugar or-patterns, we need to compose with `Pmc.Check.topToBottom`+to model first match semantics!+This was previously impossible in the pattern fragment, and indeed is+incompatible with the simple "list of `PmGrd`s" desugaring of patterns.++So our solution is to generalise "sequence of `PmGrd`" into a series-parallel+graph `GrdDag`, a special kind of DAG, where "series" corresponds to+left-to-right sequence and "parallel" corresponds to top-to-bottom or-pattern+alternatives. Example++  f (LT; GT) True (EQ; GT) = rhs++desugars to++   /- LT <- x -\             /- EQ <- z -\+  .             . True <- y .             .-> rhs+   \- GT <- x ./             \- GT <- z -/++Branching is GdAlt and models first-match semantics of or-patterns, and+sequencing is GdSeq.++We must take care of exponential explosion of Covered sets for long matches like+  g (LT; GT) (LT; GT) ... True = 1+Fortunately, we can build on our existing throttling mechanism;+see Note [Countering exponential blowup] in GHC.HsToCore.Pmc.Check. -} + -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs -- parentheses under precedence @p@. patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool@@ -648,15 +1060,15 @@     -- at a different GhcPass (see the case for GhcTc XPat below).     go :: forall q. IsPass q => Pat (GhcPass q) -> Bool     go (NPlusKPat {})    = p > opPrec+    go (OrPat {})        = p > topPrec     go (SplicePat {})    = False     go (ConPat { pat_args = ds })                          = conPatNeedsParens p ds     go (SigPat {})       = p >= sigPrec     go (ViewPat {})      = True+    go (EmbTyPat {})     = True+    go (InvisPat{})      = False     go (XPat ext)        = case ghcPass @q of-#if __GLASGOW_HASKELL__ < 901-      GhcPs -> dataConCantHappen ext-#endif       GhcRn -> case ext of         HsPatExpanded orig _ -> go orig       GhcTc -> case ext of@@ -683,17 +1095,22 @@  -- | @'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-gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)-gParPat p = ParPat noAnn noHsTok p noHsTok+gParPat :: forall p. IsPass p => LPat (GhcPass p) -> Pat (GhcPass p)+gParPat pat = ParPat x pat+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField  -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.@@ -705,6 +1122,7 @@   | patNeedsParens p pat = L loc (gParPat lpat)   | otherwise            = lpat + {- % Collect all EvVars from all constructor patterns -}@@ -720,11 +1138,12 @@ collectEvVarsPat pat =   case pat of     LazyPat _ p      -> collectEvVarsLPat p-    AsPat _ _ _ p    -> collectEvVarsLPat p-    ParPat  _ _ p _  -> collectEvVarsLPat p+    AsPat _ _ p      -> collectEvVarsLPat p+    ParPat  _ p      -> collectEvVarsLPat p     BangPat _ p      -> collectEvVarsLPat p     ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps     TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps+    OrPat _ ps       -> unionManyBags $ map collectEvVarsLPat (NE.toList ps)     SumPat _ p _ _   -> collectEvVarsLPat p     ConPat       { pat_args  = args@@ -751,7 +1170,7 @@ -}  type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA-type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA-type instance Anno RecFieldsDotDot = SrcSpan+type instance Anno RecFieldsDotDot = EpaLocation
+ compiler/GHC/Hs/Specificity.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Hs.Specificity where++import Prelude+import Control.DeepSeq (NFData(..))++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Language.Haskell.Syntax.Specificity++{- *********************************************************************+*                                                                      *+*                   ForAllTyFlag+*                                                                      *+********************************************************************* -}++instance Outputable ForAllTyFlag where+  ppr Required  = text "[req]"+  ppr Specified = text "[spec]"+  ppr Inferred  = text "[infrd]"++instance Binary Specificity where+  put_ bh SpecifiedSpec = putByte bh 0+  put_ bh InferredSpec  = putByte bh 1++  get bh = do+    h <- getByte bh+    case h of+      0 -> return SpecifiedSpec+      _ -> return InferredSpec++instance Binary ForAllTyFlag where+  put_ bh Required  = putByte bh 0+  put_ bh Specified = putByte bh 1+  put_ bh Inferred  = putByte bh 2++  get bh = do+    h <- getByte bh+    case h of+      0 -> return Required+      1 -> return Specified+      _ -> return Inferred++instance NFData Specificity where+  rnf SpecifiedSpec = ()+  rnf InferredSpec = ()+instance NFData ForAllTyFlag where+  rnf (Invisible spec) = rnf spec+  rnf Required = ()+
compiler/GHC/Hs/Type.hs view
@@ -1,5 +1,6 @@  {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -22,19 +23,25 @@ -}  module GHC.Hs.Type (-        Mult, HsScaled(..),-        hsMult, hsScaledThing,-        HsArrow(..), arrowToHsType,-        HsLinearArrowTokens(..),-        hsLinear, hsUnrestricted, isUnrestricted,-        pprHsArrow,+        Mult,+        HsMultAnn, HsMultAnnOf(..),+        multAnnToHsType, expandHsMultAnnOf,+        EpLinear(..), EpArrowOrColon(..),+        pprHsArrow, pprHsMultAnn,          HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,-        HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,+        HsTypeGhcPsExt(..),+        HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis,+        HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..),+        HsBndrKind(..),+        HsBndrVar(..),+        HsBndrVis(..), isHsBndrInvisible,         LHsQTyVars(..),         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,         HsWildCardBndrs(..),         HsPatSigType(..), HsPSRn(..),+        HsTyPat(..), HsTyPatRn(..),+        HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn,         HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,         HsTupleSort(..),         HsContext, LHsContext, fromMaybeContext,@@ -44,33 +51,36 @@         LHsTypeArg, lhsTypeArgSrcSpan,         OutputableBndrFlag, -        LBangType, BangType,         HsSrcBang(..), HsImplBang(..),         SrcStrictness(..), SrcUnpackedness(..),-        getBangType, getBangStrictness, -        ConDeclField(..), LConDeclField, pprConDeclFields,--        HsConDetails(..), noTypeArgs,+        HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields, +        HsConDetails(..),+        HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult,+        hsPlainTypeField, mkConDeclField,         FieldOcc(..), LFieldOcc, mkFieldOcc,-        AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,-        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,-        unambiguousFieldOcc, ambiguousFieldOcc,+        fieldOccRdrName, fieldOccLRdrName, +        OpName(..),+         mkAnonWildCardTy, pprAnonWildCard,          hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,         mkHsOuterImplicit, mkHsOuterExplicit,         mkHsImplicitSigType, mkHsExplicitSigType,-        mkHsWildCardBndrs, mkHsPatSigType,+        mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat,         mkEmptyWildCardBndrs,         mkHsForAllVisTele, mkHsForAllInvisTele,         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,-        isHsKindedTyVar, hsTvbAllKinded,-        hsScopedTvs, hsWcScopedTvs, dropWildCards,-        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,+        isHsKindedTyVar, hsBndrVar, hsBndrKind, hsTvbAllKinded,+        hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,+        hsTyVarLName, hsTyVarName,+        hsAllLTyVarNames, hsLTyVarLocNames,+        hsLTyVarName, hsLTyVarNames,+        hsForAllTelescopeBndrs,+        hsForAllTelescopeNames,+        hsLTyVarLocName, hsExplicitLTyVarNames,         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,         splitLHsPatSynTy,         splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,@@ -79,10 +89,10 @@         mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,         ignoreParens, hsSigWcType, hsPatSigType,         hsTyKindSig,-        setHsTyVarBndrFlag, hsTyVarBndrFlag,+        setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag,          -- Printing-        pprHsType, pprHsForAll,+        pprHsType, pprHsForAll, pprHsForAllTelescope,         pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,         pprLHsContext,         hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext@@ -95,18 +105,20 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) )  import Language.Haskell.Syntax.Extension-import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) )+import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)+                        , HsSrcBang(..), HsImplBang(..)+                        ) import GHC.Hs.Extension import GHC.Parser.Annotation  import GHC.Types.Fixity ( LexicalFixity(..) )-import GHC.Types.Id ( Id ) import GHC.Types.SourceText-import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName )-import GHC.Types.Name.Reader ( RdrName )+import GHC.Types.Name+import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr ) import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) )-import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )+import GHC.Builtin.Names ( negateName )+import GHC.Builtin.Types( oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Core.Multiplicity( pprArrowWithMultiplicity )@@ -120,25 +132,7 @@ import Data.Data (Data)  import qualified Data.Semigroup as S--{--************************************************************************-*                                                                      *-\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 _))     = s-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s-getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)+import GHC.Data.Bag  {- ************************************************************************@@ -151,16 +145,15 @@ fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p) fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt -type instance XHsForAllVis   (GhcPass _) = EpAnnForallTy+type instance XHsForAllVis   (GhcPass _) = EpAnn (TokForall, TokRarrow)                                            -- Location of 'forall' and '->'-type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy+type instance XHsForAllInvis (GhcPass _) = EpAnn (TokForall, EpToken ".")                                            -- Location of 'forall' and '.'  type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen -type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn)-  -- ^ Location of 'forall' and '->' for HsForAllVis-  -- Location of 'forall' and '.' for HsForAllInvis+type EpAnnForallVis   = EpAnn (TokForall, TokRarrow)+type EpAnnForallInvis = EpAnn (TokForall, EpToken ".")  type HsQTvsRn = [Name]  -- Implicit variables   -- For example, in   data T (a :: k1 -> k2) = ...@@ -172,17 +165,17 @@  type instance XXLHsQTyVars  (GhcPass _) = DataConCantHappen -mkHsForAllVisTele ::EpAnnForallTy ->+mkHsForAllVisTele ::EpAnnForallVis ->   [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p) mkHsForAllVisTele an vis_bndrs =   HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs } -mkHsForAllInvisTele :: EpAnnForallTy+mkHsForAllInvisTele :: EpAnnForallInvis   -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p) mkHsForAllInvisTele an invis_bndrs =   HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs } -mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs+mkHsQTvs :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }  emptyLHsQTvs :: LHsQTyVars GhcRn@@ -195,7 +188,7 @@ type instance XHsOuterImplicit GhcRn = [Name] type instance XHsOuterImplicit GhcTc = [TyVar] -type instance XHsOuterExplicit GhcPs _    = EpAnnForallTy+type instance XHsOuterExplicit GhcPs _    = EpAnnForallInvis type instance XHsOuterExplicit GhcRn _    = NoExtField type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag] @@ -211,6 +204,10 @@ type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +type instance XHsTP GhcPs = NoExtField+type instance XHsTP GhcRn = HsTyPatRn+type instance XHsTP GhcTc = DataConCantHappen+ -- | The extension field for 'HsPatSigType', which is only used in the -- renamer onwards. See @Note [Pattern signature binders and scoping]@. data HsPSRn = HsPSRn@@ -219,15 +216,79 @@   }   deriving Data +-- HsTyPatRn is the extension field for `HsTyPat`, after renaming+-- E.g. pattern K @(Maybe (_x, a, b::Proxy k)+-- In the type pattern @(Maybe ...):+--    '_x' is a named wildcard+--    'a'  is explicitly bound+--    'k'  is implicitly bound+-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat+data HsTyPatRn = HsTPRn+  { hstp_nwcs    :: [Name] -- ^ Wildcard names+  , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names+  }+  deriving Data++-- | A variant of HsTyPatRn that uses Bags for efficient concatenation.+-- See Note [Implicit and explicit type variable binders]  in GHC.Rename.Pat+data HsTyPatRnBuilder =+  HsTPRnB {+    hstpb_nwcs :: Bag Name,+    hstpb_imp_tvs :: Bag Name,+    hstpb_exp_tvs :: Bag Name+  }++tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder+tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name}++tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder+tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} =+  mempty {+    hstpb_nwcs = listToBag hsps_nwcs,+    hstpb_imp_tvs = listToBag hsps_imp_tvs+  }++instance Semigroup HsTyPatRnBuilder where+  HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 =+    HsTPRnB+      (nwcs1    `unionBags` nwcs2)+      (imp_tvs1 `unionBags` imp_tvs2)+      (exptvs1  `unionBags` exptvs2)++instance Monoid HsTyPatRnBuilder where+  mempty = HsTPRnB emptyBag emptyBag emptyBag++buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn+buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} =+  HsTPRn {+    hstp_nwcs =    bagToList hstpb_nwcs,+    hstp_imp_tvs = bagToList hstpb_imp_tvs,+    hstp_exp_tvs = bagToList hstpb_exp_tvs+  }++builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder+builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} =+  HsTPRnB {+    hstpb_nwcs =    listToBag hstp_nwcs,+    hstpb_imp_tvs = listToBag hstp_imp_tvs,+    hstpb_exp_tvs = listToBag hstp_exp_tvs+  }+ type instance XXHsPatSigType (GhcPass _) = DataConCantHappen+type instance XXHsTyPat      (GhcPass _) = DataConCantHappen  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 @@ -243,7 +304,7 @@ mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField} -mkHsOuterExplicit :: EpAnnForallTy -> [LHsTyVarBndr flag GhcPs]+mkHsOuterExplicit :: EpAnnForallInvis -> [LHsTyVarBndr flag GhcPs]                   -> HsOuterTyVarBndrs flag GhcPs mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an                                              , hso_bndrs     = bndrs }@@ -253,7 +314,7 @@   HsSig { sig_ext   = noExtField         , sig_bndrs = mkHsOuterImplicit, sig_body = body } -mkHsExplicitSigType :: EpAnnForallTy+mkHsExplicitSigType :: EpAnnForallInvis                     -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs                     -> HsSigType GhcPs mkHsExplicitSigType an bndrs body =@@ -268,133 +329,272 @@ mkHsPatSigType ann x = HsPS { hsps_ext  = ann                             , hsps_body = x } +mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs+mkHsTyPat x = HsTP { hstp_ext  = noExtField+                   , hstp_body = x }+ mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x                               , hswc_ext  = [] }  -------------------------------------------------- -type instance XUserTyVar    (GhcPass _) = EpAnn [AddEpAnn]-type instance XKindedTyVar  (GhcPass _) = EpAnn [AddEpAnn]-+type instance XTyVarBndr    (GhcPass _) = AnnTyVarBndr type instance XXTyVarBndr   (GhcPass _) = DataConCantHappen +type instance XBndrKind   (GhcPass p) = NoExtField+type instance XBndrNoKind (GhcPass p) = NoExtField+type instance XXBndrKind  (GhcPass p) = DataConCantHappen++type instance XBndrVar (GhcPass p) = NoExtField++type instance XBndrWildCard GhcPs = EpToken "_"+type instance XBndrWildCard GhcRn = NoExtField+type instance XBndrWildCard GhcTc = NoExtField++type instance XXBndrVar (GhcPass p) = DataConCantHappen++data AnnTyVarBndr+  = AnnTyVarBndr {+    atv_opens  :: [EpaLocation], -- all "(" or all "{"+    atv_closes :: [EpaLocation], -- all ")" or all "}"+    atv_tv     :: EpToken "'",+    atv_dcolon :: TokDcolon+  } deriving Data++instance NoAnn AnnTyVarBndr where+  noAnn = AnnTyVarBndr noAnn noAnn noAnn noAnn+ -- | Return the attached flag hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag-hsTyVarBndrFlag (UserTyVar _ fl _)     = fl-hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl+hsTyVarBndrFlag = tvb_flag+-- By specialising to (GhcPass p) we know that XXTyVarBndr is DataConCantHappen+-- so the equation is exhaustive: extension construction can't happen  -- | Set the attached flag setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)   -> HsTyVarBndr flag (GhcPass pass)-setHsTyVarBndrFlag f (UserTyVar x _ l)     = UserTyVar x f l-setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k+setHsTyVarBndrFlag fl tvb = tvb { tvb_flag = fl } +-- | Update the attached flag+updateHsTyVarBndrFlag+  :: (flag -> flag')+  -> HsTyVarBndr flag  (GhcPass pass)+  -> HsTyVarBndr flag' (GhcPass pass)+updateHsTyVarBndrFlag f tvb = tvb { tvb_flag = f (tvb_flag tvb) }++-- | Get the variable of the type variable binder+hsBndrVar :: HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass)+hsBndrVar = tvb_var++-- | Get the kind of the type variable binder+hsBndrKind :: HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass)+hsBndrKind = tvb_kind+ -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -instance NamedThing (HsTyVarBndr flag GhcRn) where-  getName (UserTyVar _ _ v) = unLoc v-  getName (KindedTyVar _ _ v _) = unLoc v+type instance XBndrRequired (GhcPass _) = NoExtField +type instance XBndrInvisible GhcPs = EpToken "@"+type instance XBndrInvisible GhcRn = NoExtField+type instance XBndrInvisible GhcTc = NoExtField++type instance XXBndrVis (GhcPass _) = DataConCantHappen++{- Note [Wildcard binders in disallowed contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In contexts where a type variable binder is expected (HsTyVarBndr), we usually+allow both named binders and wildcards, e.g.++  type Const1 a b = a     -- ok+  type Const2 a _ = a     -- ok, too++This applies to LHSs of data, newtype, type, class, type family and data family+declarations. However, we choose to reject wildcards in forall telescopes and+type family result variables (the latter being part of TypeFamilyDependencies):++  type family Fd a = _    -- disallowed  (WildcardBndrInTyFamResultVar)+  fn :: forall _. Int     -- disallowed  (WildcardBndrInForallTelescope)++This restriction is placed solely because such binders have not been proposed+and there is no known use case for them. If we see user demand for wildcard+binders in these contexts, adding support for them would be as easy as dropping+the checks that reject them. The rest of the compiler can handle all wildcard+binders regardless of context by generating a fresh name (see `tcHsBndrVarName`+in GHC.Tc.Gen.HsType and `repHsBndrVar` in GHC.HsToCore.Quote).++That is, in type declarations we have:++  type F _  = ...  -- equivalent to ...+  type F _a = ...  -- where _a is fresh++and the same principle could be applied to foralls:++  fn :: forall _.  Int   -- equivalent to ...+  fn :: forall _a. Int   -- where _a is fresh++except the `forall _.` example is rejected by checkForAllTelescopeWildcardBndrs.+-}+ type instance XForAllTy        (GhcPass _) = NoExtField type instance XQualTy          (GhcPass _) = NoExtField-type instance XTyVar           (GhcPass _) = EpAnn [AddEpAnn]+type instance XTyVar           (GhcPass _) = EpToken "'" type instance XAppTy           (GhcPass _) = NoExtField-type instance XFunTy           (GhcPass _) = EpAnnCO-type instance XListTy          (GhcPass _) = EpAnn AnnParen-type instance XTupleTy         (GhcPass _) = EpAnn AnnParen-type instance XSumTy           (GhcPass _) = EpAnn AnnParen-type instance XOpTy            (GhcPass _) = EpAnn [AddEpAnn]-type instance XParTy           (GhcPass _) = EpAnn AnnParen-type instance XIParamTy        (GhcPass _) = EpAnn [AddEpAnn]+type instance XFunTy           (GhcPass _) = NoExtField+type instance XListTy          (GhcPass _) = AnnParen+type instance XTupleTy         (GhcPass _) = AnnParen+type instance XSumTy           (GhcPass _) = AnnParen+type instance XOpTy            (GhcPass _) = NoExtField+type instance XParTy           (GhcPass _) = (EpToken "(", EpToken ")")+type instance XIParamTy        (GhcPass _) = TokDcolon type instance XStarTy          (GhcPass _) = NoExtField-type instance XKindSig         (GhcPass _) = EpAnn [AddEpAnn]+type instance XKindSig         (GhcPass _) = TokDcolon -type instance XAppKindTy       (GhcPass _) = SrcSpan -- Where the `@` lives+type instance XAppKindTy       GhcPs = EpToken "@"+type instance XAppKindTy       GhcRn = NoExtField+type instance XAppKindTy       GhcTc = NoExtField  type instance XSpliceTy        GhcPs = NoExtField type instance XSpliceTy        GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy        GhcTc = Kind -type instance XDocTy           (GhcPass _) = EpAnn [AddEpAnn]-type instance XBangTy          (GhcPass _) = EpAnn [AddEpAnn]--type instance XRecTy           GhcPs = EpAnn AnnList-type instance XRecTy           GhcRn = NoExtField-type instance XRecTy           GhcTc = NoExtField+type instance XDocTy           (GhcPass _) = NoExtField+type instance XConDeclField    (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)+type instance XXConDeclRecField   (GhcPass _) = DataConCantHappen -type instance XExplicitListTy  GhcPs = EpAnn [AddEpAnn]+type instance XExplicitListTy  GhcPs = (EpToken "'", EpToken "[", EpToken "]") type instance XExplicitListTy  GhcRn = NoExtField type instance XExplicitListTy  GhcTc = Kind -type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn]+type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")") type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind]  type instance XTyLit           (GhcPass _) = NoExtField -type instance XWildCardTy      (GhcPass _) = NoExtField--type instance XXType         (GhcPass _) = HsCoreTy+type instance XWildCardTy      GhcPs = EpToken "_"+type instance XWildCardTy      GhcRn = NoExtField+type instance XWildCardTy      GhcTc = NoExtField --- 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 +type HsCoreTy = Type -oneDataConHsTy :: HsType GhcRn-oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)+-- 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" -manyDataConHsTy :: HsType GhcRn-manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName)+  | HsBangTy    (EpaLocation, EpToken "#-}", EpaLocation)+                HsSrcBang+                (LHsType GhcPs)+    -- See Note [Parsing data type declarations] -hsLinear :: a -> HsScaled (GhcPass p) a-hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok))+  | HsRecTy     (AnnList ())+                [LHsConDeclRecField GhcPs]+    -- See Note [Parsing data type declarations] -hsUnrestricted :: a -> HsScaled (GhcPass p) a-hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok)+{- 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.+-} -isUnrestricted :: HsArrow GhcRn -> Bool-isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName-isUnrestricted _ = False+data EpArrowOrColon+  = EpArrow !TokRarrow+  | EpColon !TokDcolon+  | EpPatBind+  deriving Data --- | Convert an arrow into its corresponding multiplicity. In essence this--- erases the information of whether the programmer wrote an explicit--- multiplicity or a shorthand.-arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn-arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy-arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy-arrowToHsType (HsExplicitMult _ p _) = p+data EpLinear+  = EpPct1 !(EpToken "%1") !EpArrowOrColon+  | EpLolly !(EpToken "⊸")+  deriving Data +instance NoAnn EpLinear where+  noAnn = EpPct1 noAnn (EpArrow noAnn)++type instance XUnannotated  _ GhcPs = EpArrowOrColon+type instance XUnannotated  _ GhcRn = NoExtField+type instance XUnannotated  _ GhcTc = Mult++type instance XLinearAnn    _ GhcPs = EpLinear+type instance XLinearAnn    _ GhcRn = NoExtField+type instance XLinearAnn    _ GhcTc = Mult++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-      (OutputableBndrId pass) =>-      Outputable (HsArrow (GhcPass pass)) where+      (Outputable mult, OutputableBndrId pass) =>+      Outputable (HsMultAnnOf mult (GhcPass pass)) where   ppr arr = parens (pprHsArrow arr)  -- See #18846-pprHsArrow :: (OutputableBndrId pass) => HsArrow (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 _) = EpAnn [AddEpAnn]-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:@@ -414,20 +614,40 @@   = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)     -- See Note [hsScopedTvs and visible foralls] +hsScopedKvs :: LHsKind GhcRn -> [Name]+-- Same as hsScopedTvs, but for a LHsKind+hsScopedKvs  (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }})+  = hsLTyVarNames bndrs+    -- See Note [hsScopedTvs and visible foralls]+hsScopedKvs _ = []+ ----------------------hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)-hsTyVarName (UserTyVar _ _ (L _ n))     = n-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p))+hsTyVarLName tvb =+  case hsBndrVar tvb of+    HsBndrVar      _ n -> Just n+    HsBndrWildCard _   -> Nothing -hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)+hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p))+hsTyVarName = fmap unLoc . hsTyVarLName++hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p)) hsLTyVarName = hsTyVarName . unLoc  hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]-hsLTyVarNames = map hsLTyVarName+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+ hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only-hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)+hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs)  hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] -- All variables@@ -435,11 +655,13 @@                          , hsq_explicit = tvs })   = kvs ++ hsLTyVarNames tvs -hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)+hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                => LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))+hsLTyVarLocName (L _ a) = hsTyVarLName a -hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]-hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)+hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN+                 => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]+hsLTyVarLocNames qtvs = mapMaybe hsLTyVarLocName (hsQTvExplicit qtvs)  -- | Get the kind signature of a type, ignoring parentheses: --@@ -472,27 +694,26 @@ ************************************************************************ -} -mkAnonWildCardTy :: HsType GhcPs-mkAnonWildCardTy = HsWildCardTy noExtField+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 noAnn prom ty1 op ty2+mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2  mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-mkHsAppTy t1 t2-  = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))+mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2)  mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]            -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy -mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+mkHsAppKindTy :: XAppKindTy (GhcPass p)+              -> LHsType (GhcPass p) -> LHsType (GhcPass p)               -> LHsType (GhcPass p)-mkHsAppKindTy ext ty k-  = addCLocAA ty k (HsAppKindTy ext ty k)+mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)  {- ************************************************************************@@ -508,60 +729,66 @@ --      splitHsFunType (a -> (b -> c)) = ([a,b], c) -- It returns API Annotations for any parens removed splitHsFunType ::-     LHsType (GhcPass p)-  -> ( [AddEpAnn], EpAnnComments -- The locations of any parens and+     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 an ty))+    go (L l (HsParTy (op,cp) ty))       = let-          (anns, cs, args, res) = splitHsFunType ty-          anns' = anns ++ annParen2AddEpAnn an-          cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an-        in (anns', cs', args, res)+          ((ops, cps), cs, args, res) = splitHsFunType ty+          cs' = cs S.<> epAnnComments l+        in ((ops++[op], cps ++ [cp]), cs', args, res) -    go (L ll (HsFunTy (EpAnn _ _ cs) mult x y))+    go (L ll (HsFunTy _ mult x y))       | (anns, csy, args, res) <- splitHsFunType y-      = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)-      where-        L l t = x-        x' = L (addCommentsToSrcAnn l cs) t+      = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res) -    go other = ([], emptyComments, [], other)+    go other = (noAnn, emptyComments, [], other)  -- | Retrieve the name of the \"head\" of a nested type application. -- 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  ------------------------------------------------------------ +type instance XValArg (GhcPass _) = NoExtField++type instance XTypeArg GhcPs = EpToken "@"+type instance XTypeArg GhcRn = NoExtField+type instance XTypeArg GhcTc = NoExtField++type instance XArgPar (GhcPass _) = SrcSpan++type instance XXArg (GhcPass _) = DataConCantHappen+ -- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.-lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan+lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan lhsTypeArgSrcSpan arg = case arg of-  HsValArg  tm    -> getLocA tm-  HsTypeArg at ty -> at `combineSrcSpans` getLocA ty+  HsValArg  _  tm -> getLocA tm+  HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty   HsArgPar  sp    -> sp  -------------------------------- -numVisibleArgs :: [HsArg tm ty] -> Arity+numVisibleArgs :: [HsArg p tm ty] -> Arity numVisibleArgs = count is_vis-  where is_vis (HsValArg _) = True-        is_vis _            = False+  where is_vis (HsValArg _ _) = True+        is_vis _              = False  -------------------------------- @@ -576,7 +803,7 @@ -- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering -- @ pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)-             => id -> LexicalFixity -> [HsArg tm ty] -> SDoc+             => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc pprHsArgsApp thing fixity (argl:argr:args)   | Infix <- fixity   = let pp_op_app = hsep [ ppr_single_hs_arg argl@@ -591,7 +818,7 @@  -- | Pretty-print a prefix identifier to a list of 'HsArg's. ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)-                        => SDoc -> [HsArg tm ty] -> SDoc+                        => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc ppr_hs_args_prefix_app acc []         = acc ppr_hs_args_prefix_app acc (arg:args) =   case arg of@@ -601,8 +828,8 @@  -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty)-                  => HsArg tm ty -> SDoc-ppr_single_hs_arg (HsValArg tm)    = ppr tm+                  => HsArg (GhcPass p) tm ty -> SDoc+ppr_single_hs_arg (HsValArg _ tm)  = ppr tm ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty -- GHC shouldn't be constructing ASTs such that this case is ever reached. -- Still, it's possible some wily user might construct their own AST that@@ -611,9 +838,9 @@  -- | This instance is meant for debug-printing purposes. If you wish to -- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.-instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where-  ppr (HsValArg tm)     = text "HsValArg"  <+> ppr tm-  ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty+instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where+  ppr (HsValArg _ tm)   = text "HsValArg"  <+> ppr tm+  ppr (HsTypeArg _ ty)  = text "HsTypeArg" <+> ppr ty   ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp  --------------------------------@@ -643,10 +870,10 @@         HsOuterImplicit{}                      -> ([], ignoreParens body)         HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body) -    (univs,       ty1) = split_sig_ty ty-    (reqs,        ty2) = splitLHsQualTy ty1-    ((_an, exis), ty3) = splitLHsForAllTyInvis ty2-    (provs,       ty4) = splitLHsQualTy ty3+    (univs, ty1) = split_sig_ty ty+    (reqs,  ty2) = splitLHsQualTy ty1+    (exis,  ty3) = splitLHsForAllTyInvis ty2+    (provs, ty4) = splitLHsQualTy ty3  -- | Decompose a sigma type (of the form @forall <tvs>. context => body@) -- into its constituent parts.@@ -666,8 +893,8 @@                      -> ([LHsTyVarBndr Specificity (GhcPass p)]                         , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p)) splitLHsSigmaTyInvis ty-  | ((_an,tvs), ty1) <- splitLHsForAllTyInvis ty-  , (ctxt,      ty2) <- splitLHsQualTy ty1+  | (tvs,  ty1) <- splitLHsForAllTyInvis ty+  , (ctxt, ty2) <- splitLHsQualTy ty1   = (tvs, ctxt, ty2)  -- | Decompose a GADT type into its constituent parts.@@ -686,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).@@ -712,11 +952,11 @@ -- Unlike 'splitLHsSigmaTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis ::-  LHsType (GhcPass pass) -> ( (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])+  LHsType (GhcPass pass) -> ( [LHsTyVarBndr Specificity (GhcPass pass)]                             , LHsType (GhcPass pass)) splitLHsForAllTyInvis ty   | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)-  = (fromMaybe (EpAnnNotUsed,[]) mb_tvbs, body)+  = (fromMaybe [] mb_tvbs, body)  -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that@@ -730,14 +970,13 @@ -- Unlike 'splitLHsForAllTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis_KP ::-  LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])+  LHsType (GhcPass pass) -> (Maybe ([LHsTyVarBndr Specificity (GhcPass pass)])                             , LHsType (GhcPass pass)) splitLHsForAllTyInvis_KP lty@(L _ ty) =   case ty of-    HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an-                                          , hsf_invis_bndrs = tvs }+    HsForAllTy { hst_tele = HsForAllInvis {hsf_invis_bndrs = tvs }                , hst_body = body }-      -> (Just (an, tvs), body)+      -> (Just tvs, body)     _ -> (Nothing, lty)  -- | Decompose a type of the form @context => body@ into its constituent parts.@@ -791,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@@ -890,57 +1129,85 @@                 FieldOcc *                                                                      * ************************************************************************--} -type instance XCFieldOcc GhcPs = NoExtField-type instance XCFieldOcc GhcRn = Name-type instance XCFieldOcc GhcTc = Id+Note [Ambiguous FieldOcc in record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a "record field update" (`some_record{ field = expr }`), the field+occurrence may be ambiguous if there are multiple record types with that same+field label in scope. Instead of failing, we may attempt to do type-directed+disambiguation: if we typecheck the record field update, we can disambiguate+the `field` based on the record and field type. -type instance XXFieldOcc (GhcPass _) = DataConCantHappen+In practice, this means an identifier of a field occurrence+(`FieldOcc`) may have to go straight from `RdrName` to `Id`, since field+ambiguity makes it impossible to construct a `Name` for the field. -mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs-mkFieldOcc rdr = FieldOcc noExtField rdr+Since type-directed disambiguation is a GHC property rather than a property of+the GHC-Haskell AST, we still parameterise a `FieldOcc` occurrence by `IdP p`,+but in the case of the ambiguity we do the unthinkable and insert a mkUnboundName+in the name. Very bad, yes, but since type-directed disambiguation is on the way+out (see proposal https://github.com/ghc-proposals/ghc-proposals/pull/366),+we consider this acceptable for now. +see also Wrinkle [Disambiguating fields] and note [Type-directed record disambiguation] -type instance XUnambiguous GhcPs = NoExtField-type instance XUnambiguous GhcRn = Name-type instance XUnambiguous GhcTc = Id+NB: FieldOcc preserves the RdrName throughout its lifecycle for+exact printing purposes.+-} -type instance XAmbiguous GhcPs = NoExtField-type instance XAmbiguous GhcRn = NoExtField-type instance XAmbiguous GhcTc = Id+type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field+type instance XCFieldOcc GhcRn = RdrName+type instance XCFieldOcc GhcTc = RdrName -type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen+type instance XXFieldOcc (GhcPass p) = DataConCantHappen -instance Outputable (AmbiguousFieldOcc (GhcPass p)) where-  ppr = ppr . rdrNameAmbiguousFieldOcc+-------------------------------------------------------------------------------- -instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where-  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc-  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc+mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs+mkFieldOcc rdr = FieldOcc noExtField rdr -instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where-  pprInfixOcc  = pprInfixOcc . unLoc-  pprPrefixOcc = pprPrefixOcc . unLoc+fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName+fieldOccRdrName fo = case ghcPass @p of+  GhcPs -> unLoc $ foLabel fo+  GhcRn -> foExt fo+  GhcTc -> foExt fo -mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs-mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr+-- ToDo SPJ: remove+--fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p)+--fieldOccExt (FieldOcc { foExt = ext }) = ext -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName-rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr-rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr+fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName+fieldOccLRdrName fo = case ghcPass @p of+  GhcPs -> foLabel fo+  GhcRn -> case fo of+    FieldOcc rdr sel ->+      let (L l _) = sel+       in L l rdr+  GhcTc ->+    let (L l _) = foLabel fo+     in L l (foExt fo) -selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id-selectorAmbiguousFieldOcc (Unambiguous sel _) = sel-selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel -unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc-unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel-unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel+{-+************************************************************************+*                                                                      *+                OpName+*                                                                      *+************************************************************************+-} -ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc-ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr+-- | Name of an operator in an operator application or section+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+  ppr NegateOp       = ppr negateName+  ppr (UnboundOp uv) = ppr uv+  ppr (RecFldOp fld) = ppr fld+ {- ************************************************************************ *                                                                      *@@ -949,19 +1216,49 @@ ************************************************************************ -} +instance OutputableBndrId p => Outputable (HsBndrVar (GhcPass p)) where+  ppr (HsBndrVar _ name) = ppr name+  ppr (HsBndrWildCard _) = char '_'+ class OutputableBndrFlag flag p where-    pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc+  pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc  instance OutputableBndrFlag () p where-    pprTyVarBndr (UserTyVar _ _ n)     = ppr n-    pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k]+  pprTyVarBndr (HsTvb _ _ bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = parens_if_kind bkind d  instance OutputableBndrFlag Specificity p where-    pprTyVarBndr (UserTyVar _ SpecifiedSpec n)     = ppr n-    pprTyVarBndr (UserTyVar _ InferredSpec n)      = braces $ ppr n-    pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]-    pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr n, dcolon, ppr k]+  pprTyVarBndr (HsTvb _ spec bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case spec of+            InferredSpec  -> braces d+            SpecifiedSpec -> parens_if_kind bkind d +instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where+  pprTyVarBndr (HsTvb _ bvis bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case bvis of+            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]++parens_if_kind :: HsBndrKind (GhcPass p) -> SDoc -> SDoc+parens_if_kind (HsBndrNoKind _) d = d+parens_if_kind (HsBndrKind _ _) d = parens d+ instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where     ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =       pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body@@ -1006,6 +1303,11 @@   instance (OutputableBndrId p)+       => Outputable (HsTyPat (GhcPass p)) where+    ppr (HsTP { hstp_body = ty }) = ppr ty+++instance (OutputableBndrId p)        => Outputable (HsTyLit (GhcPass p)) where     ppr = ppr_tylit @@ -1017,24 +1319,41 @@     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 RdrName) => 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 (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where-  pprInfixOcc  = pprInfixOcc . unXRec @pass . foLabel-  pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel+instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where+  pprInfixOcc  = pprInfixOcc . unXRec @(GhcPass pass) . foLabel+  pprPrefixOcc = pprPrefixOcc . unXRec @(GhcPass pass) . foLabel -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where+instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass pass))) where   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))@@ -1057,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.@@ -1065,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@@ -1095,30 +1417,9 @@       [L _ ty] -> ppr_mono_ty ty           <+> darrow       _        -> parens (interpp'SP ctxt) <+> darrow -pprConDeclFields :: 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 :: [LFieldOcc (GhcPass p)] -> SDoc-    ppr_names [n] = pprPrefixOcc n-    ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))--{--Note [Printing KindedTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#3830 reminded me that we should really only print the kind-signature on a KindedTyVar if the kind signature was put there by the-programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,-rather than converting to KindedTyVars as before.--(As it happens, the message in #3830 comes out a different way now,-and the problem doesn't show up; but having the flag on a KindedTyVar-seems like the Right Thing anyway.)--}+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 @@ -1136,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)@@ -1166,13 +1465,13 @@ ppr_mono_ty (HsExplicitListTy _ prom tys)   | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)   | otherwise       = brackets (interpp'SP tys)-ppr_mono_ty (HsExplicitTupleTy _ tys)+ppr_mono_ty (HsExplicitTupleTy _ prom tys)     -- Special-case unary boxed tuples so that they are pretty-printed as     -- `'MkSolo x`, not `'(x)`   | [ty] <- tys-  = quote $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]+  = quote_tuple prom $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]   | otherwise-  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)+  = quote_tuple prom $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t)       = ppr t ppr_mono_ty (HsWildCardTy {})   = char '_' @@ -1194,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@@ -1206,16 +1510,18 @@     in     sep [p1, arr <+> p2] +quote_tuple :: PromotionFlag -> SDoc -> SDoc+quote_tuple IsPromoted  doc = quote doc+quote_tuple NotPromoted doc = doc+ -------------------------- -- | @'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@@ -1235,7 +1541,7 @@     -- Special-case unary boxed tuple applications so that they are     -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612)     -- See Note [One-tuples] in GHC.Builtin.Types-    go_hs_ty (HsExplicitTupleTy _ [_])+    go_hs_ty (HsExplicitTupleTy _ _ [_])                                       = p >= appPrec     go_hs_ty (HsExplicitTupleTy{})    = False     go_hs_ty (HsTyLit{})              = False@@ -1246,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@@ -1278,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@@ -1303,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@@ -1312,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]@@ -1327,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@@ -1340,8 +1647,7 @@ type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA  type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA-type instance Anno HsIPName = SrcAnn NoEpAnns-type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA+type instance Anno HsIPName = EpAnnCO+type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA -type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
compiler/GHC/Hs/Utils.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections   #-}+ {-| Module      : GHC.Hs.Utils Description : Generic helpers for the HsSyn type.-Copyright   : (c) The University of Glasgow, 1992-2006+Copyright   : (c) The University of Glasgow, 1992-2023  Here we collect a variety of helper functions that construct or analyse HsSyn.  All these functions deal with generic HsSyn; functions@@ -12,7 +14,7 @@    ----------------          -------------    GhcPs/RdrName             GHC.Parser.PostProcess    GhcRn/Name                GHC.Rename.*-   GhcTc/Id                  GHC.Tc.Utils.Zonk+   GhcTc/Id                  GHC.Tc.Zonk.Type  The @mk*@ functions attempt to construct a not-completely-useless SrcSpan from their components, compared with the @nl*@ functions which@@ -33,28 +35,33 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE RecordWildCards #-}  module GHC.Hs.Utils(   -- * Terms-  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,+  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps,   mkHsAppType, mkHsAppTypes, mkHsCaseAlt,   mkSimpleMatch, unguardedGRHSs, unguardedRHS,   mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,   mkHsDictLet, mkHsLams,-  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,+  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns,+  mkHsWrapPat, mkLHsWrapPat, mkHsWrapPatCo,   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,+  mkLocatedList, nlAscribe, +  forgetUserRdr, noUserRdr,+   -- * Bindings   mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,   mkPatSynBind,@@ -86,7 +93,7 @@   mkLetStmt,    -- * Collecting binders-  isUnliftedHsBind, isBangedHsBind,+  isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind,    collectLocalBinders, collectHsValBinders, collectHsBindListBinders,   collectHsIdBinders,@@ -97,12 +104,15 @@   collectLStmtBinders, collectStmtBinders,   CollectPass(..), CollectFlag(..), +  TyDeclBinders(..), LConsWithFields(..),   hsLTyClDeclBinders, hsTyClForeignBinders,   hsPatSynSelectors, getPatSynBinds,   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,    -- * Collecting implicit binders-  lStmtsImplicits, hsValBindsImplicits, lPatImplicits+  ImplicitFieldBinders(..),+  lStmtsImplicits, hsValBindsImplicits, lPatImplicits,+  lHsRecFieldsImplicits   ) where  import GHC.Prelude hiding (head, init, last, tail)@@ -113,6 +123,7 @@ import GHC.Hs.Pat import GHC.Hs.Type import GHC.Hs.Lit+import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Parser.Annotation@@ -126,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@@ -140,19 +151,22 @@ import GHC.Types.SourceText  import GHC.Data.FastString-import GHC.Data.Bag  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.Either+import Control.Arrow ( first ) import Data.Foldable ( toList )-import Data.Function-import Data.List ( partition, deleteBy )-import Data.List.NonEmpty ( nonEmpty )+import Data.List ( partition )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE +import Data.IntMap ( IntMap )+import qualified Data.IntMap.Strict as IntMap+import Data.Map ( Map )+import qualified Data.Map.Strict as Map+ {- ************************************************************************ *                                                                      *@@ -166,19 +180,19 @@ -}  -- | @e => (e)@-mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsPar e = L (getLoc e) (gHsPar e)  mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))                         ~ SrcSpanAnnA,                   Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                        ~ SrcAnn NoEpAnns)-              => HsMatchContext (GhcPass p)-              -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))+                        ~ EpAnn NoEpAnns)+              => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))+              -> LocatedE [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))               -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))-mkSimpleMatch ctxt pats rhs+mkSimpleMatch ctxt (L l pats) rhs   = L loc $-    Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats+    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = L l pats           , m_grhss = unguardedGRHSs (locA loc) rhs noAnn }   where     loc = case pats of@@ -186,59 +200,59 @@                 (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)  unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns+                     ~ EpAnn NoEpAnns                => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn                -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) unguardedGRHSs loc rhs an   = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds  unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns+                     ~ 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-    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL+    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnLW     , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA     )  mkMatchGroup :: AnnoBody p body              => Origin-             -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+             -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]              -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = origin                                  , mg_alts = matches }  mkLamCaseMatchGroup :: AnnoBody p body                     => Origin-                    -> LamCaseVariant-                    -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+                    -> HsLamVariant+                    -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]                     -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))-mkLamCaseMatchGroup origin lc_variant (L l matches)+mkLamCaseMatchGroup origin lam_variant (L l matches)   = mkMatchGroup origin (L l $ map fixCtxt matches)-  where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant}+  where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant} -mkLocatedList :: Semigroup a-  => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]+mkLocatedList :: (Semigroup a, NoAnn an)+  => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2] mkLocatedList ms = case nonEmpty ms of     Nothing -> noLocA []     Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms  mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)+mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2)  mkHsAppWith   :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))   -> LHsExpr (GhcPass id)   -> LHsExpr (GhcPass id)   -> LHsExpr (GhcPass id)-mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2)+mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2)  mkHsApps   :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-mkHsApps = mkHsAppsWith addCLocAA+mkHsApps = mkHsAppsWith addCLocA  mkHsAppsWith  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))@@ -248,42 +262,52 @@ mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)  mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn-mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct)+mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct)   where     t_body    = hswc_body t-    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }+    paren_wct = t { hswc_body = t_body }  mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType  mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)-        => [LPat (GhcPass p)]+        => LocatedE [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)         -> LHsExpr (GhcPass p)-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))+mkHsLam (L l pats) body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))   where-    matches = mkMatchGroup Generated-                           (noLocA [mkSimpleMatch LambdaExpr pats' body])+    matches = mkMatchGroup (Generated OtherExpansion SkipPmc)+                           (noLocA [mkSimpleMatch (LamAlt LamSingle) (L l pats') body])     pats' = map (parenthesizePat appPrec) pats  mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars                                        <.> mkWpEvLams dicts) expr +mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc]+               -> LHsExpr GhcTc+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 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+ -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns,+                     ~ EpAnn NoEpAnns,                  Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))                         ~ SrcSpanAnnA)             => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))             -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))-mkHsCaseAlt pat expr-  = mkSimpleMatch CaseAlt [pat] expr+mkHsCaseAlt (L l pat) expr+  = mkSimpleMatch CaseAlt (L (l2l l) [L l pat]) expr  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@@ -297,7 +321,7 @@ mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat = parenthesizePat appPrec -nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)+nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) nlParPat p = noLocA (gParPat p)  -------------------------------@@ -307,17 +331,17 @@ mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs-mkHsDo         :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs-mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs+mkHsDo         :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs+mkHsDoAnns     :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                -> HsExpr GhcPs mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-               -> EpAnn AnnList+               -> AnnList EpaLocation                -> HsExpr GhcPs -mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]+mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-"             -> Pat GhcPs-mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation+mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpToken "+"             -> Pat GhcPs  -- NB: The following functions all use noSyntaxExpr: the generated expressions@@ -326,7 +350,7 @@            -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) mkBodyStmt :: LocatedA (bodyR GhcPs)            -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))-mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs)+mkPsBindStmt :: EpUniToken "<-" "←" -> LPat GhcPs -> LocatedA (bodyR GhcPs)              -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)              -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))@@ -336,12 +360,12 @@ emptyRecStmt     :: (Anno [GenLocated                              (Anno (StmtLR (GhcPass idL) GhcPs bodyR))                              (StmtLR (GhcPass idL) GhcPs bodyR)]-                        ~ SrcSpanAnnL)+                        ~ SrcSpanAnnLW)                  => StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: (Anno [GenLocated                              (Anno (StmtLR GhcRn GhcRn bodyR))                              (StmtLR GhcRn GhcRn bodyR)]-                        ~ SrcSpanAnnL)+                        ~ SrcSpanAnnLW)                  => StmtLR GhcRn GhcRn bodyR emptyRecStmtId   :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) @@ -349,9 +373,9 @@                     (Anno [GenLocated                              (Anno (StmtLR (GhcPass idL) GhcPs bodyR))                              (StmtLR (GhcPass idL) GhcPs bodyR)]-                        ~ SrcSpanAnnL)-                 => EpAnn AnnList-                 -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]+                        ~ SrcSpanAnnLW)+                 => AnnList (EpToken "rec")+                 -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]                  -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts  = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR)                              { recS_stmts = stmts }@@ -364,18 +388,21 @@ mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn-mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns+mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns   where-    -- Strip the annotations from the location, they are in the embedded expr-    last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr+    -- Move the annotations to the top of the last_stmt+    last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e)+    last_stmt = L l last+    -- last_stmt actually comes first in a list comprehension, consider all spans+    loc  = noAnnSrcSpan $ getHasLocList (last_stmt:stmts)  -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf        -> HsExpr GhcPs mkHsIf c a b anns = HsIf anns c a b  -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf        -> HsCmd GhcPs mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b @@ -383,17 +410,17 @@ mkNPlusKPat id lit anns   = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt    :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkTransformStmt    :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkTransformByStmt  :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkTransformByStmt  :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupUsingStmt   :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkGroupUsingStmt   :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkGroupByUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+emptyTransStmt :: AnnTransStmt -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt anns = TransStmt { trS_ext = anns                                 , trS_form = panic "emptyTransStmt: form"                                 , trS_stmts = [], trS_bndrs = []@@ -442,14 +469,14 @@ emptyRecStmtId   = emptyRecStmt' unitRecStmtTc                                         -- a panic might trigger during zonking -mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)+mkLetStmt :: EpToken "let" -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds  ------------------------------- -- | 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 noAnn 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)@@ -476,21 +503,17 @@  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 nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))  nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)-nlHsLit n = noLocA (HsLit noComments n)+nlHsLit n = noLocA (HsLit noExtField n)  nlHsIntLit :: Integer -> LHsExpr (GhcPass p)-nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n)))+nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))  nlVarPat :: IsSrcSpanAnn p a         => IdP (GhcPass p) -> LPat (GhcPass p)@@ -500,18 +523,11 @@ nlLitPat l = noLocA (LitPat noExtField l)  nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x))+nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x))  nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]                -> LHsExpr GhcTc-nlHsSyntaxApps (SyntaxExprTc { syn_expr      = fun-                             , syn_arg_wraps = arg_wraps-                             , syn_res_wrap  = res_wrap }) args-  = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"-                                                     mkLHsWrap arg_wraps args))-nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)-  -- this function should never be called in scenarios where there is no-  -- syntax expr+nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA  nlHsApps :: IsSrcSpanAnn p a          => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)@@ -519,10 +535,10 @@  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 noComments (noLocA f) (noLocA a)+                   mk f a = HsApp noExtField (noLocA f) (noLocA a)  nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars)@@ -542,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   }@@ -584,13 +600,14 @@ nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)  nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs-nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+nlHsPar  :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]          -> LHsExpr GhcPs nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs --- AZ:Is this used?-nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))+nlHsLam match = noLocA $ HsLam noAnn LamSingle+                  $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])+ nlHsPar e     = noLocA (gHsPar e)  -- nlHsIf should generate if-expressions which are NOT subject to@@ -599,42 +616,68 @@ nlHsIf cond true false = noLocA (HsIf noAnn cond true false)  nlHsCase expr matches-  = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))+  = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches))) 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 :: LHsType (GhcPass p) -> LHsType (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 (parenthesizeHsType appPrec t))-nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))-nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)+nlHsAppTy f t = noLocA (HsAppTy noExtField f t)+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 -> EpArrow noAnn+      GhcRn -> noExtField+      GhcTc -> manyDataConTy nlHsParTy t   = noLocA (HsParTy noAnn t) -nlHsTyConApp :: IsSrcSpanAnn p a+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 noAnn prom ty1 (noLocA tycon) ty2) rest+  , 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 (noLocA $ HsParTy noAnn fun) arg+    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg       -- parenthesize things like `(A + B) C`-    mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))-    mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))-    mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)+    mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty+    mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki+    mk_app fun (HsArgPar _) = nlHsParTy fun -nlHsAppKindTy ::+-- | 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 noSrcSpan f (parenthesizeHsType appPrec k))+nlHsAppKindTy f k = noLocA (HsAppKindTy x f k)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField  {- Tuples.  All these functions are *pre-typechecker* because they lack@@ -646,7 +689,7 @@ -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] _ = e mkLHsTupleExpr es ext-  = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed+  = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed  mkLHsVarTuple :: IsSrcSpanAnn p a                => [IdP (GhcPass p)]  -> XExplicitTuple (GhcPass p)@@ -656,7 +699,7 @@ nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLocA (TuplePat noAnn pats box) -missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs+missingTupArg :: EpAnn Bool -> HsTupArg GhcPs missingTupArg ann = Missing ann  mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn@@ -690,12 +733,12 @@  -- | Convert an 'LHsType' to an 'LHsSigType'. hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs-hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of+hsTypeToHsSigType lty@(L loc ty) = case ty of   HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an                                         , hsf_invis_bndrs = bndrs }              , hst_body = body }-    -> mkHsExplicitSigType an bndrs body-  _ -> mkHsImplicitSigType lty+    -> L loc $ mkHsExplicitSigType an bndrs body+  _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc  -- | Convert an 'LHsType' to an 'LHsSigWcType'. hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs@@ -738,6 +781,13 @@       = L loc (ClassOpSig anns False nms (dropWildCards ty))     fiddle sig = sig ++-- | Type ascription: (e :: ty)+nlAscribe :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs+nlAscribe ty e = noLocA $ ExprWithTySig noAnn e+                           $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType+                           $ nlHsTyVar NotPromoted ty+ {- ********************************************************************* *                                                                      *     --------- HsWrappers: type args, dict args, casts ---------@@ -749,7 +799,7 @@  mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrap co_fn e | isIdHsWrapper co_fn = e-mkHsWrap co_fn e                       = XExpr (WrapExpr $ HsWrap co_fn e)+mkHsWrap co_fn e                       = XExpr (WrapExpr co_fn e)  mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b            -> HsExpr GhcTc -> HsExpr GhcTc@@ -773,6 +823,9 @@ mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p                        | otherwise           = XPat $ CoPat co_fn p ty +mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc+mkLHsWrapPat co_fn (L loc p) ty = L loc (mkHsWrapPat co_fn p ty)+ mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPatCo co pat ty | isReflCo co = pat                         | otherwise     = XPat $ CoPat (mkWpCastN co) pat ty@@ -808,15 +861,15 @@                                     }  mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs-mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs+mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var (noLocA []) rhs -mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)+mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc mkVarBind var rhs = L (getLoc rhs) $                     VarBind { var_ext = noExtField,                               var_id = var, var_rhs = rhs }  mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs-             -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs+             -> LPat GhcPs -> HsPatSynDir GhcPs -> AnnPSB -> HsBind GhcPs mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb   where     psb = PSB{ psb_ext = anns@@ -827,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@@ -839,14 +892,14 @@   = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)   where     bsSpans :: [SrcSpan]-    bsSpans = map getLocA $ bagToList bs+    bsSpans = map getLocA bs     sigsSpans :: [SrcSpan]     sigsSpans = map getLocA sigs spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))   = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)   where     bsSpans :: [SrcSpan]-    bsSpans = map getLocA $ concatMap (bagToList . snd) bs+    bsSpans = map getLocA $ concatMap snd bs     sigsSpans :: [SrcSpan]     sigsSpans = map getLocA sigs spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))@@ -855,30 +908,33 @@ ------------ -- | Convenience function using 'mkFunBind'. -- This is for generated bindings only, do not use for user-written code.-mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]-                -> LHsExpr GhcPs -> LHsBind GhcPs+mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> LocatedE [LPat GhcPs]+                         -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr-  = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)-              [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr-                       emptyLocalBinds]+  = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)+                                     [mkMatch ctxt pats expr emptyLocalBinds]+  where+    ctxt :: HsMatchContextPs+    ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn  -- | Make a prefix, non-strict function 'HsMatchContext'-mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p-mkPrefixFunRhs n = FunRhs { mc_fun = n-                          , mc_fixity = Prefix-                          , mc_strictness = NoSrcStrict }+mkPrefixFunRhs :: fn -> AnnFunRhs -> HsMatchContext fn+mkPrefixFunRhs n an = FunRhs { mc_fun        = n+                          , mc_fixity     = Prefix+                          , mc_strictness = NoSrcStrict+                          , mc_an         = an }  ------------ mkMatch :: forall p. IsPass p-        => HsMatchContext (GhcPass p)-        -> [LPat (GhcPass p)]+        => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))+        -> LocatedE [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)         -> HsLocalBinds (GhcPass p)         -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr binds-  = noLocA (Match { m_ext   = noAnn+  = noLocA (Match { m_ext   = noExtField                   , m_ctxt  = ctxt-                  , m_pats  = map mkParPat pats+                  , m_pats  = pats                   , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })  {-@@ -905,60 +961,111 @@ and wild-card mechanism makes it hard to know what is bound. So these functions should not be applied to (HsSyn RdrName) -Note [Unlifted id check in isUnliftedHsBind]+Note [isUnliftedHsBind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function isUnliftedHsBind is used to complain if we make a top-level-binding for a variable of unlifted type.+The function isUnliftedHsBind tells if the binding binds a variable of+unlifted type.  e.g. -Such a binding is illegal if the top-level binding would be unlifted;-but also if the local letrec generated by desugaring AbsBinds would be.-E.g.-      f :: Num a => (# a, a #)-      g :: Num a => a -> a-      f = ...g...-      g = ...g...+  - I# x = blah+  - Just (I# x) = blah -The top-level bindings for f,g are not unlifted (because of the Num a =>),-but the local, recursive, monomorphic bindings are:+isUnliftedHsBind is used in two ways: +* To complain if we make a top-level binding for a variable of unlifted+  type. E.g. any of the above bindings are illegal at top level++* To generate a case expression for a non-recursive local let.  E.g.+     let Just (I# x) = blah in body+  ==>+     case blah of Just (I# x) -> body+  See GHC.HsToCore.Expr.dsUnliftedBind.++Wrinkles:++(W1) For AbsBinds we must check if the local letrec generated by desugaring+     AbsBinds would be unlifted; so we just recurse into the abs_binds. E.g.+       f :: Num a => (# a, a #)+       g :: Num a => a -> a+       f = ...g...+       g = ...g...++    The top-level bindings for f,g are not unlifted (because of the Num a =>),+    but the local, recursive, monomorphic bindings are:       t = /\a \(d:Num a).          letrec fm :: (# a, a #) = ...g...                 gm :: a -> a = ...f...          in (fm, gm) -Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.+   Here the binding for 'fm' is illegal.  So we recurse into the abs_binds -BUT we have a special case when abs_sig is true;-  see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds+(W2) BUT we have a special case when abs_sig is true;+     see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds++(W3) isUnliftedHsBind returns False even if the binding itself is+     unlifted, provided it binds only lifted variables. E.g.+      -  (# a,b #) = (# reverse xs, xs #)++      -  x = sqrt# y#  :: Float#++      -  type Unl :: UnliftedType+         data Unl = MkUnl Int+         MkUnl z = blah++     In each case the RHS of the "=" has unlifted type, but isUnliftedHsBind+     returns False.  Reason: see GHC Proposal #35+        https://github.com/ghc-proposals/ghc-proposals/blob/master/+        proposals/0035-unbanged-strict-patterns.rst++(W4) In particular, (W3) applies to a pattern that binds no variables at all.+     So   { _ = sqrt# y :: Float# } returns False from isUnliftedHsBind, but+          { x = sqrt# y :: Float# } returns True.+     This is arguably a bit confusing (see #22719) -}  ----------------- Bindings --------------------------  -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around--- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage+-- AbsBinds. See Note [isUnliftedHsBind]. For usage -- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds-isUnliftedHsBind bind-  | XHsBindsLR (AbsBinds { abs_exports = exports, abs_sig = has_sig }) <- bind-  = if has_sig-    then any (is_unlifted_id . abe_poly) exports-    else any (is_unlifted_id . abe_mono) exports+isUnliftedHsBind (XHsBindsLR (AbsBinds { abs_exports = exports+                                       , abs_sig     = has_sig+                                       , abs_binds   = binds }))+  | has_sig   = any (is_unlifted_id . abe_poly) exports+  | otherwise = isUnliftedHsBinds binds+    -- See wrinkle (W1) and (W2) in Note [isUnliftedHsBind]     -- If has_sig is True we will never generate a binding for abe_mono,     -- so we don't need to worry about it being unlifted. The abe_poly     -- binding might not be: e.g. forall a. Num a => (# a, a #)+    -- If has_sig is False, just recurse -  | otherwise-  = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind)-  where-    is_unlifted_id id = isUnliftedType (idType id)-      -- bindings always have a fixed RuntimeRep, so it's OK-      -- to call isUnliftedType here+isUnliftedHsBind (FunBind { fun_id = L _ fun })+  = is_unlifted_id fun +isUnliftedHsBind (VarBind { var_id = var })+  = is_unlifted_id var++isUnliftedHsBind (PatBind { pat_lhs = pat })+  = any is_unlifted_id (collectPatBinders CollNoDictBinders pat)+    -- If we changed our view on (W3) you could add+    --    || isUnliftedType pat_ty+    -- to this check++isUnliftedHsBind (PatSynBind {}) = panic "isUnliftedBind: PatSynBind"++isUnliftedHsBinds :: LHsBinds GhcTc -> Bool+isUnliftedHsBinds = any (isUnliftedHsBind . unLoc)++is_unlifted_id :: Id -> Bool+is_unlifted_id id = isUnliftedType (idType id)+   -- Bindings always have a fixed RuntimeRep, so it's OK+   -- to call isUnliftedType here+ -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? isBangedHsBind :: HsBind GhcTc -> Bool isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds }))-  = anyBag (isBangedHsBind . unLoc) binds+  = any (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches})   | [L _ match] <- unLoc $ mg_alts matches   , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match@@ -1064,28 +1171,28 @@ ----------------- Statements -------------------------- -- collectLStmtsBinders-  :: CollectPass (GhcPass idL)+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))   => CollectFlag (GhcPass idL)   -> [LStmtLR (GhcPass idL) (GhcPass idR) body]   -> [IdP (GhcPass idL)] collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)  collectStmtsBinders-  :: CollectPass (GhcPass idL)+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))   => CollectFlag (GhcPass idL)   -> [StmtLR (GhcPass idL) (GhcPass idR) body]   -> [IdP (GhcPass idL)] collectStmtsBinders flag = concatMap (collectStmtBinders flag)  collectLStmtBinders-  :: CollectPass (GhcPass idL)+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))   => CollectFlag (GhcPass idL)   -> LStmtLR (GhcPass idL) (GhcPass idR) body   -> [IdP (GhcPass idL)] collectLStmtBinders flag = collectStmtBinders flag . unLoc  collectStmtBinders-  :: CollectPass (GhcPass idL)+  :: forall idL idR body . (IsPass idL, IsPass idR, CollectPass (GhcPass idL))   => CollectFlag (GhcPass idL)   -> StmtLR (GhcPass idL) (GhcPass idR) body   -> [IdP (GhcPass idL)]@@ -1095,15 +1202,19 @@     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-    ApplicativeStmt _ args _        -> concatMap collectArgBinders args-        where-         collectArgBinders = \case-            (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat-            (_, ApplicativeArgMany { bv_pattern = pat })     -> collectPatBinders flag pat+    XStmtLR x -> case ghcPass :: GhcPass idR of+        GhcRn -> collectApplicativeStmtBndrs x+        GhcTc -> collectApplicativeStmtBndrs x+  where+    collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)]+    collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args +    collectArgBinders = \case+        ApplicativeArgOne { app_arg_pattern = pat } -> collectPatBinders flag pat+        ApplicativeArgMany { bv_pattern = pat }     -> collectPatBinders flag pat  ----------------- Patterns -------------------------- @@ -1121,14 +1232,18 @@     -> [IdP p] collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats - ------------- --- | Indicate if evidence binders have to be collected.+-- | Indicate if evidence binders and type variable binders have+--   to be collected. ----- This type is used as a boolean (should we collect evidence binders or not?)--- but also to pass an evidence that the AST has been typechecked when we do--- want to collect evidence binders, otherwise these binders are not available.+-- This type enumerates the modes of collecting bound variables+--                     | evidence |   type    |   term    |  ghc  |+--                     | binders  | variables | variables |  pass |+--                     --------------------------------------------+-- CollNoDictBinders   |  no      |    no     |    yes    |  any  |+-- CollWithDictBinders |  yes     |    no     |    yes    | GhcTc |+-- CollVarTyVarBinders |  no      |    yes    |    yes    | GhcRn | -- -- See Note [Dictionary binders in ConPatOut] data CollectFlag p where@@ -1136,7 +1251,10 @@     CollNoDictBinders   :: CollectFlag p     -- | Collect evidence binders     CollWithDictBinders :: CollectFlag GhcTc+    -- | Collect variable and type variable binders, but no evidence binders+    CollVarTyVarBinders :: CollectFlag GhcRn + collect_lpat :: forall p. CollectPass p              => CollectFlag p              -> LPat p@@ -1154,28 +1272,50 @@   WildPat _             -> bndrs   LazyPat _ pat         -> collect_lpat flag pat bndrs   BangPat _ pat         -> collect_lpat flag pat bndrs-  AsPat _ a _ pat       -> unXRec @p a : collect_lpat flag pat bndrs+  AsPat _ a pat         -> unXRec @p a : collect_lpat flag pat bndrs   ViewPat _ _ pat       -> collect_lpat flag pat bndrs-  ParPat _ _ pat _      -> collect_lpat flag pat bndrs+  ParPat _ pat          -> collect_lpat flag pat bndrs   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats+  OrPat _ _             -> []+      -- See Note [Implementation of OrPatterns], Renamer:+      -- evidence binders in an OrPat currently aren't visible outside their+      -- binding pattern, so we return [].   SumPat _ pat _ _      -> collect_lpat flag pat bndrs   LitPat _ _            -> bndrs   NPat {}               -> bndrs   NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs-  SigPat _ pat _        -> collect_lpat flag pat bndrs+  SigPat _ pat sig      -> case flag of+    CollNoDictBinders   -> collect_lpat flag pat bndrs+    CollWithDictBinders -> collect_lpat flag pat bndrs+    CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig   XPat ext              -> collectXXPat @p flag ext bndrs   SplicePat ext _       -> collectXSplicePat @p flag ext bndrs+  EmbTyPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs+  InvisPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs+   -- See Note [Dictionary binders in ConPatOut]   ConPat {pat_args=ps}  -> case flag of     CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)     CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)                            ++ collectEvBinders (cpt_binds (pat_con_ext pat))+    CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)  collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" +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+collect_ty_pat_bndrs CollVarTyVarBinders tp bndrs = collectTyPatBndrs tp ++ bndrs++collectTyPatBndrs :: HsTyPat GhcRn -> [Name]+collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs++collectPatSigBndrs :: HsPatSigType GhcRn -> [Name]+collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs+ add_ev_bndr :: EvBind -> [Id] -> [Id] add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs                                        | otherwise = bs@@ -1210,8 +1350,7 @@       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.Utils.Zonk+        -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type    collectXSplicePat flag ext =       case ghcPass @p of@@ -1305,17 +1444,31 @@ hsTyClForeignBinders tycl_decls foreign_decls   =    map unLoc (hsForeignDeclsBinders foreign_decls)     ++ getSelectorNames-         (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls+         (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls          `mappend`-         foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)+         (foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls))   where     getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]-    getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs+    getSelectorNames (ns, fs) = map unLoc ns ++ map (unLoc . foLabel . unLoc) fs  --------------------hsLTyClDeclBinders :: IsPass p++data TyDeclBinders p+  = TyDeclBinders+  { tyDeclMainBinder     :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ())+  , tyDeclATs            :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())]+  , tyDeclOpSigs         :: ![LocatedA (IdP (GhcPass p))]+  , tyDeclConsWithFields :: !(LConsWithFields p) }++tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+tyDeclBinders (TyDeclBinders main ats sigs consWithFields)+  = (fst main : (fmap fst ats ++ sigs ++ cons), flds)+  where+    (cons, flds) = lconsWithFieldsBinders consWithFields++hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p)                    => LocatedA (TyClDecl (GhcPass p))-                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                   -> TyDeclBinders p -- ^ Returns all the /binding/ names of the decl.  The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second@@ -1326,27 +1479,40 @@ -- See Note [SrcSpan for binders]  hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl-                                            { fdLName = (L _ name) } }))-  = ([L loc name], [])+                                            { fdLName = (L _ name)+                                            , fdInfo  = fd_info } }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info)+  , tyDeclATs = [], tyDeclOpSigs = []+  , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (SynDecl                                { tcdLName = (L _ name) }))-  = ([L loc name], [])+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, TypeSynonymFlavour)+  , tyDeclATs = [], tyDeclOpSigs = []+  , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (ClassDecl                                { tcdLName = (L _ cls_name)                                , tcdSigs  = sigs                                , tcdATs   = ats }))-  = (L loc cls_name :-     [ L fam_loc fam_name | (L fam_loc (FamilyDecl-                                        { fdLName = L _ fam_name })) <- ats ]-     ++-     [ L mem_loc mem_name-                          | (L mem_loc (ClassOpSig _ False ns _)) <- sigs-                          , (L _ mem_name) <- ns ]-    , [])+  = TyDeclBinders+  { tyDeclMainBinder = (L loc cls_name, ClassFlavour)+  , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info)+                | (L fam_loc (FamilyDecl { fdLName = L _ fam_name+                                         , fdInfo = fd_info })) <- ats ]+  , tyDeclOpSigs = [ L mem_loc mem_name+                   | (L mem_loc (ClassOpSig _ False ns _)) <- sigs+                   , (L _ mem_name) <- ns ]+  , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = (L _ name)                                        , tcdDataDefn = defn }))-  = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn-+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, flav )+  , tyDeclATs = []+  , tyDeclOpSigs = []+  , tyDeclConsWithFields = hsDataDefnBinders defn }+  where+    flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn  ------------------- hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)@@ -1364,7 +1530,7 @@ -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _))-  = foldr addPatSynSelector [] . unionManyBags $ map snd binds+  = foldr addPatSynSelector [] . concat $ map snd binds  addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels@@ -1376,97 +1542,173 @@                => [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds   = [ psb | (_, lbinds) <- binds-          , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ]+          , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ]  --------------------hsLInstDeclBinders :: IsPass p+hsLInstDeclBinders :: (IsPass p, OutputableBndrId p)                    => LInstDecl (GhcPass p)-                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                   -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD                              { cid_inst = ClsInstDecl                                           { cid_datafam_insts = dfis }}))-  = foldMap (hsDataFamInstBinders . unLoc) dfis+  = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))-  = hsDataFamInstBinders fi+  = lconsWithFieldsBinders $ hsDataFamInstBinders fi hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty  ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names-hsDataFamInstBinders :: IsPass p+hsDataFamInstBinders :: (IsPass p, OutputableBndrId p)                      => DataFamInstDecl (GhcPass p)-                     -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                     -> LConsWithFields p hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})   = hsDataDefnBinders defn   -- There can't be repeated symbols because only data instances have binders  ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names-hsDataDefnBinders :: IsPass p+hsDataDefnBinders :: (IsPass p, OutputableBndrId p)                   => HsDataDefn (GhcPass p)-                  -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                  -> LConsWithFields p hsDataDefnBinders (HsDataDefn { dd_cons = cons })   = hsConDeclsBinders (toList cons)   -- See Note [Binders in family instances]  --------------------type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]-                 -- Filters out ones that have already been seen -hsConDeclsBinders :: forall p. IsPass p+{- Note [Collecting record fields in data declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a data declaration that includes record constructors, we are, in+the end, going to to create a mapping from constructor to its field labels,+to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer,+which constructor has what fields.++In order to achieve this, we return the constructor and field information from+hsConDeclsBinders in the following format:++  - [(ConRdrName, [Located Int])], a list of the constructors, each associated+    with its record fields, in the form of a list of Int indices into...+  - IntMap FieldOcc, an IntMap of record fields.++(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating+that the constructor has unlabelled fields: see Note [Local constructor info in the renamer]+in GHC.Types.GREInfo.)++This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc):++  - create 'Name's for each of the record fields, to get IntMap FieldLabel,+  - create 'Name's for each of the constructors, to get [(ConName, [Int])],+  - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])].++NB: This can be a bit tricky to get right in the presence of data types with+duplicate constructors or fields. Storing locations allows us to report an error+for duplicate field declarations, see test cases T9156 T9156_DF.+Other relevant test cases: rnfail015.++-}++-- | A mapping from constructors to all of their fields.+--+-- See Note [Collecting record fields in data declarations].+data LConsWithFields p =+  LConsWithFields+    { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])]+    , consFields :: IntMap (LFieldOcc (GhcPass p))+    }++lconsWithFieldsBinders :: LConsWithFields p+                       -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])+lconsWithFieldsBinders (LConsWithFields cons fields)+  = (map fst cons, IntMap.elems fields)++emptyLConsWithFields :: LConsWithFields p+emptyLConsWithFields = LConsWithFields [] IntMap.empty++hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p)                   => [LConDecl (GhcPass p)]-                  -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-   -- See hsLTyClDeclBinders for what this does-   -- The function is boringly complicated because of the records-   -- And since we only have equality, we have to be a little careful-hsConDeclsBinders cons-  = go id cons+                  -> LConsWithFields p+  -- The function is boringly complicated because of the records+  -- And since we only have equality, we have to be a little careful+hsConDeclsBinders cons = go emptyFieldIndices cons   where-    go :: Seen p -> [LConDecl (GhcPass p)]-       -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-    go _ [] = ([], [])-    go remSeen (r:rs)+    go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p+    go seen [] = LConsWithFields [] (fields seen)+    go seen (r:rs)       -- Don't re-mangle the location of field names, because we don't       -- have a record of the full location of the field declaration anyway       = let loc = getLoc r         in case unLoc r of-           -- remove only the first occurrence of any seen field in order to-           -- avoid circumventing detection of duplicate fields (#9156)            ConDeclGADT { con_names = names, con_g_args = args }-             -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs)+             -> LConsWithFields (cons ++ ns) fs              where-                (remSeen', flds) = get_flds_gadt remSeen args-                (ns, fs) = go remSeen' rs+                cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names)+                (con_flds, seen') = get_flds_gadt seen args+                LConsWithFields ns fs = go seen' rs             ConDeclH98 { con_name = name, con_args = args }-             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)+             -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs              where-                (remSeen', flds) = get_flds_h98 remSeen args-                (ns, fs) = go remSeen' rs+                (con_flds, seen') = get_flds_h98 seen args+                LConsWithFields ns fs = go seen' rs -    get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)-                 -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds-    get_flds_h98 remSeen _ = (remSeen, [])+    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 _ = (Nothing, seen) -    get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)-                  -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds-    get_flds_gadt remSeen _ = (remSeen, [])+    get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p)+                  -> (Maybe [Located Int], FieldIndices p)+    get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds+    get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen)+    get_flds_gadt seen _ = (Nothing, seen) -    get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]-             -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds remSeen flds = (remSeen', fld_names)-       where-          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))-          remSeen' = foldr (.) remSeen-                               [deleteBy ((==) `on` unLoc . foLabel . unLoc) v-                               | v <- fld_names]+    get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)]+             -> ([Located Int], FieldIndices p)+    get_flds seen flds =+      foldr add_fld ([], seen) fld_names+      where+        add_fld fld (is, ixs) =+          let (i, ixs') = insertField fld ixs+          in  (i:is, ixs')+        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].+data FieldIndices p =+  FieldIndices+    { fields       :: IntMap (LFieldOcc (GhcPass p))+        -- ^ Look up a field from its index.+    , fieldIndices :: Map RdrName Int+        -- ^ Look up the index of a field label in the previous 'IntMap'.+    , newInt       :: !Int+        -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'.+    }++emptyFieldIndices :: FieldIndices p+emptyFieldIndices =+  FieldIndices { fields       = IntMap.empty+               , fieldIndices = Map.empty+               , newInt       = 0 }++insertField :: IsPass p => LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p)+insertField new_fld fi@(FieldIndices flds idxs new_idx)+  | Just i <- Map.lookup rdr idxs+  = (L loc i, fi)+  | otherwise+  = (L loc new_idx,+      FieldIndices (IntMap.insert new_idx new_fld flds)+                   (Map.insert rdr new_idx idxs)+                   (new_idx + 1))+  where+    loc = getLocA new_fld+    rdr = fieldOccRdrName . unLoc $ new_fld+ {-  Note [SrcSpan for binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~-When extracting the (Located RdrNme) for a binder, at least for the+When extracting the (Located RdrName) for a binder, at least for the main name (the TyCon of a type declaration etc), we want to give it the @SrcSpan@ of the whole /declaration/, not just the name itself (which is how it appears in the syntax tree).  This SrcSpan (for the@@ -1487,41 +1729,77 @@ *                                                                      * ************************************************************************ -The job of this family of functions is to run through binding sites and find the set of all Names-that were defined "implicitly", without being explicitly written by the user.+The job of the following family of functions is to run through binding sites and find+the set of all Names that were defined "implicitly", without being explicitly written+by the user. -The main purpose is to find names introduced by record wildcards so that we can avoid-warning the user when they don't use those names (#4404)+Note [Collecting implicit binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We collect all the RHS Names that are implicitly introduced by record wildcards,+so that we can: -Since the addition of -Wunused-record-wildcards, this function returns a pair-of [(SrcSpan, [Name])]. Each element of the list is one set of implicit-binders, the first component of the tuple is the document describes the possible-fix to the problem (by removing the ..).+  - avoid warning the user when they don't use those names (#4404),+  - report deprecation warnings for deprecated fields that are used (#23382). -This means there is some unfortunate coupling between this function and where it-is used but it's only used for one specific purpose in one place so it seemed-easier.+The functions that collect implicit binders return a collection of 'ImplicitFieldBinders',+which associates each implicitly-introduced record field with the bound variables in the+RHS of the record field pattern, e.g. in++  data R = MkR { fld :: Int }+  foo (MkR { .. }) = fld++the renamer will elaborate this to++  foo (MkR { fld = fld_var }) = fld_var++and the implicit binders function will return++  [ ImplicitFieldBinders { implFlBndr_field = fld+                         , implFlBndr_binders = [fld_var] } ]++This information is then used:++  - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit+    a warning when a record wildcard binds no new variables (redundant record wildcard)+    or none of the bound variables are used (unused record wildcard).+  - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning+    when the field is deprecated and any of the binders are used.++NOTE: the implFlBndr_binders field should always be a singleton+      (since the RHS of an implicit binding should always be a VarPat,+      created in rnHsRecPatsAndThen.mkVarPat)+ -} -lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]-                -> [(SrcSpan, [Name])]+-- | All binders corresponding to a single implicit record field pattern.+--+-- See Note [Collecting implicit binders].+data ImplicitFieldBinders+  = ImplicitFieldBinders { implFlBndr_field :: Name+                             -- ^ The 'Name' of the record field+                         , implFlBndr_binders :: [Name]+                             -- ^ The binders of the RHS of the record field pattern+                             -- (in practice, always a singleton: see Note [Collecting implicit binders])+                         }++lStmtsImplicits :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]+                -> [(SrcSpan, [ImplicitFieldBinders])] lStmtsImplicits = hs_lstmts   where-    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]-              -> [(SrcSpan, [Name])]+    hs_lstmts :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]+              -> [(SrcSpan, [ImplicitFieldBinders])]     hs_lstmts = concatMap (hs_stmt . unLoc) -    hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))-            -> [(SrcSpan, [Name])]+    hs_stmt :: forall idR body . IsPass idR => StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))+            -> [(SrcSpan, [ImplicitFieldBinders])]     hs_stmt (BindStmt _ pat _) = lPatImplicits pat-    hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args-      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat-            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts+    hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of+        GhcRn -> hs_applicative_stmt x+        GhcTc -> hs_applicative_stmt x     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 @@ -1529,19 +1807,30 @@     hs_local_binds (HsIPBinds {})           = []     hs_local_binds (EmptyLocalBinds _)      = [] -hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]+    hs_applicative_stmt (ApplicativeStmt _ args _) = concatMap do_arg args+      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat+            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts++hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)+                    -> [(SrcSpan, [ImplicitFieldBinders])] hsValBindsImplicits (XValBindsLR (NValBinds binds _))   = concatMap (lhsBindsImplicits . snd) binds hsValBindsImplicits (ValBinds _ binds _)   = lhsBindsImplicits binds -lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]-lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []+lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])]+lhsBindsImplicits = concatMap (lhs_bind . unLoc)   where     lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat     lhs_bind _ = [] -lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]+-- | Collect all record wild card binders in the given pattern.+--+-- These are all the variables bound in all (possibly nested) record wildcard patterns+-- appearing inside the pattern.+--+-- See Note [Collecting implicit binders].+lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])] lPatImplicits = hs_lpat   where     hs_lpat lpat = hs_pat (unLoc lpat)@@ -1550,33 +1839,44 @@      hs_pat (LazyPat _ pat)      = hs_lpat pat     hs_pat (BangPat _ pat)      = hs_lpat pat-    hs_pat (AsPat _ _ _ pat)    = hs_lpat pat+    hs_pat (AsPat _ _ pat)      = hs_lpat pat     hs_pat (ViewPat _ _ pat)    = hs_lpat pat-    hs_pat (ParPat _ _ pat _)   = hs_lpat pat+    hs_pat (ParPat _ pat)       = hs_lpat pat     hs_pat (ListPat _ pats)     = hs_lpats pats     hs_pat (TuplePat _ pats _)  = hs_lpats pats-     hs_pat (SigPat _ pat _)     = hs_lpat pat -    hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps+    hs_pat (ConPat {pat_args=ps}) = details ps      hs_pat _ = [] -    details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]-    details _ (PrefixCon _ ps) = hs_lpats ps-    details n (RecCon fs)      =-      [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]-        ++ hs_lpats explicit_pats+    details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]+    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 }))+          = [(l2l err_loc, implicit_field_binders)]+          ++ hs_lpats explicit_pats -      where implicit_pats = map (hfbRHS . unLoc) implicit-            explicit_pats = map (hfbRHS . unLoc) explicit+          where (explicit_pats, implicit_field_binders)+                  = rec_field_expl_impl rec_flds rec_dotdot +    details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 -            (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld-                                                    | (i, fld) <- [0..] `zip` rec_flds fs-                                                    ,  let  pat_explicit =-                                                              maybe True ((i<) . unRecFieldsDotDot . unLoc)-                                                                         (rec_dotdot fs)]-            err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)+lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)]+                      -> RecFieldsDotDot+                      -> [ImplicitFieldBinders]+lHsRecFieldsImplicits rec_flds rec_dotdot+  = snd $ rec_field_expl_impl rec_flds rec_dotdot -    details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2+rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)]+                    -> RecFieldsDotDot+                    -> ([LPat GhcRn], [ImplicitFieldBinders])+rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })+  = ( map (hfbRHS . unLoc) explicit_binds+    , map implicit_field_binders implicit_binds )+  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 :: 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@@ -15,7 +15,7 @@ import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc@@ -26,10 +26,9 @@  instance Diagnostic DsMessage where   type DiagnosticOpts DsMessage = NoDiagnosticOpts-  defaultDiagnosticOpts = NoDiagnosticOpts-  diagnosticMessage _ = \case-    DsUnknownMessage (UnknownDiagnostic @e m)-      -> diagnosticMessage (defaultDiagnosticOpts @e) m+  diagnosticMessage opts = \case+    DsUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m     DsEmptyEnumeration       -> mkSimpleDecorated $ text "Enumeration is empty"     DsIdentitiesFound conv_fn type_of_conv@@ -84,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@@ -112,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 $@@ -168,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 $@@ -208,6 +241,12 @@                           <+> text "for"<+> quotes (ppr lhs_id)                           <+> text "might fire first")                 ]+    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@@ -221,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@@ -238,6 +275,7 @@     DsRecBindsNotAllowedForUnliftedTys{}        -> ErrorWithoutFlag     DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing     DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing+    DsIncompleteRecordSelector{}                -> WarningWithFlag Opt_WarnIncompleteRecordSelectors    diagnosticHints = \case     DsUnknownMessage m          -> diagnosticHints m@@ -257,9 +295,7 @@     DsMaxPmCheckModelsReached{}                 -> [SuggestIncreaseMaxPmCheckModels]     DsNonExhaustivePatterns{}                   -> noHints     DsTopLevelBindsNotAllowed{}                 -> noHints-    DsUselessSpecialiseForClassMethodSelector{} -> noHints-    DsUselessSpecialiseForNoInlineFunction{}    -> noHints-    DsMultiplicityCoercionsNotSupported         -> noHints+    DsUselessSpecialisePragma{}                 -> noHints     DsOrphanRule{}                              -> noHints     DsRuleLhsTooComplicated{}                   -> noHints     DsRuleIgnoredDueToConstructor{}             -> noHints@@ -274,8 +310,9 @@     DsRecBindsNotAllowedForUnliftedTys{}        -> noHints     DsRuleMightInlineFirst _ lhs_id rule_act    -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]     DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]+    DsIncompleteRecordSelector{}                -> noHints -  diagnosticCode = constructorCode+  diagnosticCode = constructorCode @GHC  {- Note [Suggest NegativeLiterals]@@ -299,11 +336,11 @@        2 (quotes (ppr elt_ty))  -- Print a single clause (for redundant/with-inaccessible-rhs)-pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc+pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->   f (q <+> matchSeparator ctx <+> text "...") -pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pprContext singular kind msg rest_of_msg_fun   = vcat [text txt <+> msg,           sep [ text "In" <+> ppr_match <> char ':'
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@@ -8,8 +9,10 @@  import GHC.Core (CoreRule, CoreExpr, RuleName) import GHC.Core.DataCon+import GHC.Core.ConLike import GHC.Core.Type-import GHC.Driver.Session+import GHC.Driver.DynFlags (DynFlags, xopt)+import GHC.Driver.Flags (WarningFlag) import GHC.Hs import GHC.HsToCore.Pmc.Solver.Types import GHC.Types.Basic (Activation)@@ -29,7 +32,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage   -- | Simply wraps a generic 'Diagnostic' message.-  = DsUnknownMessage UnknownDiagnostic+  = DsUnknownMessage (UnknownDiagnosticFor DsMessage)      {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is         emitted if an enumeration is empty.@@ -84,18 +87,18 @@    -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately   -- 'SrcInfo' gives us an 'SDoc' to begin with.-  | DsRedundantBangPatterns !(HsMatchContext GhcRn) !SDoc+  | DsRedundantBangPatterns !HsMatchContextRn !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately   -- 'SrcInfo' gives us an 'SDoc' to begin with.-  | DsOverlappingPatterns !(HsMatchContext GhcRn) !SDoc+  | DsOverlappingPatterns !HsMatchContextRn !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc'-  | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc+  | DsInaccessibleRhs !HsMatchContextRn !SDoc    | DsMaxPmCheckModelsReached !MaxPmCheckModels -  | DsNonExhaustivePatterns !(HsMatchContext GhcRn)+  | DsNonExhaustivePatterns !HsMatchContextRn                             !ExhaustivityCheckType                             !MaxUncoveredPatterns                             [Id]@@ -103,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 @@ -146,6 +156,25 @@                                 !RuleName -- the \"bad\" rule                                 !Var +  {-| DsIncompleteRecordSelector is a warning triggered when we are not certain whether+      a record selector application will be successful. Currently, this means that+      the warning is triggered when there is a record selector of a data type that+      does not have that field in all its constructors.++      Example(s):+      data T = T1 | T2 {x :: Bool}+      f :: T -> Bool+      f a = x a++     Test cases:+       DsIncompleteRecSel1+       DsIncompleteRecSel2+       DsIncompleteRecSel3+  -}+  | DsIncompleteRecordSelector !Name       -- ^ The selector+                               ![ConLike]  -- ^ The partial constructors+                               !Int        -- ^ The max number of constructors reported+   deriving Generic  -- The positional number of the argument for an expression (first, second, third, etc)@@ -154,7 +183,7 @@ -- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH' -- constructor of a 'DsMessage'. data ThRejectionReason-  = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn)+  = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn GhcRn)   | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn)   | ThForeignLabel !CLabelString   | ThForeignExport !(LForeignDecl GhcRn)@@ -175,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/Ppr.hs view
@@ -20,7 +20,6 @@ import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import Control.Monad.Trans.RWS.CPS import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -63,9 +63,9 @@ 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.Types.CompleteMatch (CompleteMatch(..))+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                             , FractionalExponentBase(..))@@ -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@@ -258,19 +258,19 @@ -- See also Note [Implementation of COMPLETE pragmas] data ResidualCompleteMatches   = RCM-  { rcm_vanilla :: !(Maybe CompleteMatch)+  { rcm_vanilla :: !(Maybe DsCompleteMatch)   -- ^ The residual set for the vanilla COMPLETE set from the data defn.   -- Tracked separately from 'rcm_pragmas', because it might only be   -- known much later (when we have enough type information to see the 'TyCon'   -- of the match), or not at all even. Until that happens, it is 'Nothing'.-  , rcm_pragmas :: !(Maybe [CompleteMatch])+  , rcm_pragmas :: !(Maybe DsCompleteMatches)   -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are   -- visible when compiling this module. Querying that set with   -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing'   -- until first needed in a 'DsM' context.   } -getRcm :: ResidualCompleteMatches -> [CompleteMatch]+getRcm :: ResidualCompleteMatches -> DsCompleteMatches getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas  isRcmInitialised :: ResidualCompleteMatches -> Bool@@ -325,6 +325,11 @@     go _                = Nothing  trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)+{-# INLINE trvVarInfo #-}+-- This function is called a lot and we want to specilise it, not only+-- for the type class, but also for its 'f' function argument.+-- Before the INLINE pragma it sometimes inlined and sometimes didn't,+-- depending delicately on GHC's optimisations.  Better to use a pragma. trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x   = set_vi <$> f (lookupVarInfo ts x)   where
compiler/GHC/HsToCore/Pmc/Types.hs view
@@ -18,10 +18,13 @@         -- * LYG syntax          -- ** Guard language-        SrcInfo(..), PmGrd(..), GrdVec(..),+        SrcInfo(..), PmGrd(..), GrdDag(..),+        consGrdDag, gdSeq, sequencePmGrds, sequenceGrdDags,+        alternativesGrdDags,          -- ** Guard tree language-        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),+        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..),+        PmPatBind(..), PmEmptyCase(..), PmRecSel(..),          -- * Coverage Checking types         RedSets (..), Precision (..), CheckResult (..),@@ -43,6 +46,7 @@ import GHC.Types.Var (EvVar) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Core.ConLike import GHC.Core.Type import GHC.Core @@ -101,9 +105,52 @@ -- location. newtype SrcInfo = SrcInfo (Located SDoc) --- | A sequence of 'PmGrd's.-newtype GrdVec = GrdVec [PmGrd]+-- | A series-parallel graph of 'PmGrd's, so very nearly a guard tree, if+-- it weren't for or-patterns/'GdAlt'!+-- The implicit "source" corresponds to "before the match" and the implicit+-- "sink" corresponds to "after a successful match".+--+--   * 'GdEnd' is a 'GrdDag' that always matches.+--   * 'GdOne' is a 'GrdDag' that matches iff its 'PmGrd' matches.+--   * @'GdSeq' g1 g2@ corresponds to matching guards @g1@ and then @g2@+--     if matching @g1@ succeeded.+--     Example: The Haskell guard @| x > 1, x < 10 = ...@ will test @x > 1@+--     before @x < 10@, failing if either test fails.+--   * @'GdAlt' g1 g2@ is far less common than 'GdSeq' and corresponds to+--     matching an or-pattern @(LT; EQ)@, succeeding if the+--     match variable matches /either/ 'LT' or 'EQ'.+--     See Note [Implementation of OrPatterns] for a larger example.+--+data GrdDag+  = GdEnd+  | GdOne !PmGrd+  | GdSeq !GrdDag !GrdDag+  | GdAlt !GrdDag !GrdDag +-- | Sequentially compose a list of 'PmGrd's into a 'GrdDag'.+sequencePmGrds :: [PmGrd] -> GrdDag+sequencePmGrds = sequenceGrdDags . map GdOne++-- | Sequentially compose a list of 'GrdDag's.+sequenceGrdDags :: [GrdDag] -> GrdDag+sequenceGrdDags xs = foldr gdSeq GdEnd xs++-- | Sequentially compose a 'PmGrd' in front of a 'GrdDag'.+consGrdDag :: PmGrd -> GrdDag -> GrdDag+consGrdDag g d = gdSeq (GdOne g) d++-- | Sequentially compose two 'GrdDag's. A smart constructor for `GdSeq` that+-- eliminates `GdEnd`s.+gdSeq :: GrdDag -> GrdDag -> GrdDag+gdSeq g1    GdEnd = g1+gdSeq GdEnd g2    = g2+gdSeq g1    g2    = g1 `GdSeq` g2++-- | Parallel composition of a list of 'GrdDag's.+-- Needs a non-empty list as 'GdAlt' does not have a neutral element.+alternativesGrdDags :: NonEmpty GrdDag -> GrdDag+alternativesGrdDags xs = foldr1 GdAlt xs+ -- | A guard tree denoting 'MatchGroup'. newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p)) @@ -130,14 +177,22 @@   -- rather than on the pattern bindings.   PmPatBind (PmGRHS p) +-- A guard tree denoting a record selector application+data PmRecSel v = PmRecSel { pr_arg_var :: v, pr_arg :: CoreExpr, pr_cons :: [ConLike] } instance Outputable SrcInfo where   ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss)   ppr (SrcInfo (L s                   _)) = ppr s  -- | Format LYG guards as @| True <- x, let x = 42, !z@-instance Outputable GrdVec where-  ppr (GrdVec [])     = empty-  ppr (GrdVec (g:gs)) = fsep (char '|' <+> ppr g : map ((comma <+>) . ppr) gs)+instance Outputable GrdDag where+  ppr GdEnd = empty+  ppr (GdOne g) = ppr g+  ppr (GdSeq d1 d2) = ppr d1 <> comma <+> ppr d2+  ppr d0@GdAlt{} = parens $ fsep (ppr d : map ((semi <+>) . ppr) ds)+    where+      d NE.:| ds = collect d0+      collect (GdAlt d1 d2) = collect d1 Semi.<> collect d2+      collect d = NE.singleton d  -- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as -- @{ <first alt>; ...; <last alt> }@@@ -232,7 +287,7 @@ --  -- | Used as tree payload pre-checking. The LYG guards to check.-type Pre = GrdVec+type Pre = GrdDag  -- | Used as tree payload post-checking. The redundancy info we elaborated. type Post = RedSets
+ 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
@@ -0,0 +1,336 @@++{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE LambdaCase #-}++{-+(c) The University of Glasgow 2006-2008+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+-}++-- | Module for constructing interface declaration values+-- from the corresponding 'TyThing's.++module GHC.Iface.Decl+   ( coAxiomToIfaceDecl+   , tyThingToIfaceDecl -- Converting things to their Iface equivalents+   )+where++import GHC.Prelude++import GHC.Tc.Utils.TcType++import GHC.Iface.Syntax++import GHC.CoreToIface++import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike+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+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.TyThing++import GHC.Utils.Panic.Plain+import GHC.Utils.Misc++import GHC.Data.Maybe+import Data.List ( findIndex, mapAccumL )++{-+************************************************************************+*                                                                      *+                Converting things to their Iface equivalents+*                                                                      *+************************************************************************+-}++tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl+tyThingToIfaceDecl _ (AnId id)      = idToIfaceDecl id+tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)+tyThingToIfaceDecl _ (ACoAxiom ax)  = coAxiomToIfaceDecl ax+tyThingToIfaceDecl show_linear_types (AConLike cl)  = case cl of+    RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only+    PatSynCon ps   -> patSynToIfaceDecl ps++--------------------------+idToIfaceDecl :: Id -> IfaceDecl+-- The Id is already tidied, so that locally-bound names+-- (lambdas, for-alls) already have non-clashing OccNames+-- We can't tidy it here, locally, because it may have+-- free variables in its type or IdInfo+idToIfaceDecl id+  = IfaceId { ifName      = getName id,+              ifType      = toIfaceType (idType id),+              ifIdDetails = toIfaceIdDetails (idDetails id),+              ifIdInfo    = toIfaceIdInfo (idInfo id) }++--------------------------+dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl+dataConToIfaceDecl show_linear_types dataCon+  = IfaceId { ifName      = getName dataCon,+              ifType      = toIfaceType (dataConDisplayType show_linear_types dataCon),+              ifIdDetails = IfVanillaId,+              ifIdInfo    = [] }++--------------------------+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl+-- We *do* tidy Axioms, because they are not (and cannot+-- conveniently be) built in tidy form+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches+                               , co_ax_role = role })+ = IfaceAxiom { ifName       = getName ax+              , ifTyCon      = toIfaceTyCon tycon+              , ifRole       = role+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon+                                     (map coAxBranchLHS branch_list))+                                   branch_list }+ where+   branch_list = fromBranches branches++-- 2nd parameter is the list of branch LHSs, in case of a closed type family,+-- for conversion from incompatible branches to incompatible indices.+-- For an open type family the list should be empty.+-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch tc lhs_s+                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                    , cab_eta_tvs = eta_tvs+                                    , cab_lhs = lhs, cab_roles = roles+                                    , cab_rhs = rhs, cab_incomps = incomps })++  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs+                  , ifaxbCoVars  = map toIfaceIdBndr cvs+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs+                  , ifaxbLHS     = toIfaceTcArgs tc lhs+                  , ifaxbRoles   = roles+                  , ifaxbRHS     = toIfaceType rhs+                  , ifaxbIncomps = iface_incomps }+  where+    iface_incomps = map (expectJust+                        . flip findIndex lhs_s+                        . eqTypes+                        . coAxBranchLHS) incomps++-----------------+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)+-- We *do* tidy TyCons, because they are not (and cannot+-- conveniently be) built in tidy form+-- The returned TidyEnv is the one after tidying the tyConTyVars+tyConToIfaceDecl env tycon+  | Just clas <- tyConClass_maybe tycon+  = classToIfaceDecl env clas++  | Just syn_rhs <- synTyConRhs_maybe tycon+  = ( tc_env1+    , IfaceSynonym { ifName    = getName tycon,+                     ifRoles   = tyConRoles tycon,+                     ifSynRhs  = if_syn_type syn_rhs,+                     ifBinders = if_binders,+                     ifResKind = if_res_kind+                   })++  | Just fam_flav <- famTyConFlav_maybe tycon+  = ( tc_env1+    , IfaceFamily { ifName    = getName tycon,+                    ifResVar  = mkIfLclName <$> if_res_var,+                    ifFamFlav = to_if_fam_flav fam_flav,+                    ifBinders = if_binders,+                    ifResKind = if_res_kind,+                    ifFamInj  = tyConInjectivityInfo tycon+                  })++  | isAlgTyCon tycon+  = ( tc_env1+    , IfaceData { ifName    = getName tycon,+                  ifBinders = if_binders,+                  ifResKind = if_res_kind,+                  ifCType   = tyConCType_maybe tycon,+                  ifRoles   = tyConRoles tycon,+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),+                  ifCons    = ifaceConDecls (algTyConRhs tycon),+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,+                  ifParent  = parent })++  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon+  -- We only convert these TyCons to IfaceTyCons when we are+  -- just about to pretty-print them, not because we are going+  -- to put them into interface files+  = ( env+    , IfaceData { ifName       = getName tycon,+                  ifBinders    = if_binders,+                  ifResKind    = if_res_kind,+                  ifCType      = Nothing,+                  ifRoles      = tyConRoles tycon,+                  ifCtxt       = [],+                  ifCons       = IfDataTyCon False [],+                  ifGadtSyntax = False,+                  ifParent     = IfNoParent })+  where+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause+    -- an error.+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)+    tc_tyvars      = binderVars tc_binders+    if_binders     = toIfaceForAllBndrs tc_binders+                     -- No tidying of the binders; they are already tidy+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)+    if_syn_type ty = tidyToIfaceType tc_env1 ty+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon++    parent = case tyConFamInstSig_maybe tycon of+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)+                                                   (toIfaceTyCon tc)+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)+               Nothing           -> IfNoParent++    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))+      where defs = fromBranches $ coAxiomBranches ax+            lhss = map coAxBranchLHS defs+            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs+            axn  = coAxiomName ax++    ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data })+      = IfDataTyCon type_data (map ifaceConDecl cons)+    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,+                    ifConInfix   = dataConIsInfix data_con,+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),+                    ifConExTCvs  = map toIfaceBndr ex_tvs',+                    ifConUserTvBinders = toIfaceForAllBndrs user_bndrs',+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,+                    ifConArgTys  =+                      map (\(Scaled w t) -> (tidyToIfaceType con_env2 w+                                          , (tidyToIfaceType con_env2 t))) arg_tys,+                    ifConFields  = dataConFieldLabels data_con,+                    ifConStricts = map (toIfaceBang con_env2)+                                       (dataConImplBangs data_con),+                    ifConSrcStricts = map toIfaceSrcBang+                                          (dataConSrcBangs data_con)}+        where+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)+            = dataConFullSig data_con+          user_bndrs = dataConUserTyVarBinders data_con++          -- Tidy the univ_tvs of the data constructor to be identical+          -- to the tyConTyVars of the type constructor.  This means+          -- (a) we don't need to redundantly put them into the interface file+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,+          --     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 univ_tvs tc_tyvars))+                     -- A bit grimy, perhaps, but it's simple!++          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs+          user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)++          -- By this point, we have tidied every universal and existential+          -- tyvar. Because of the dcUserForAllTyBinders invariant+          -- (see Note [DataCon user type variable binders]), *every*+          -- user-written tyvar must be contained in the substitution that+          -- 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 -> TyVarBinder -> TyVarBinder+          tidyUserForAllTyBinder env (Bndr tv vis) =+            Bndr (tidyTyCoVarOcc env tv) vis++classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)+classToIfaceDecl env clas+  = ( env1+    , IfaceClass { ifName   = getName tycon,+                   ifRoles  = tyConRoles (classTyCon clas),+                   ifBinders = toIfaceForAllBndrs tc_binders,+                   ifBody   = body,+                   ifFDs    = map toIfaceFD clas_fds })+  where+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)+      = classExtraBigSig clas+    tycon = classTyCon clas++    body | isAbstractTyCon tycon = IfAbstractClass+         | otherwise+         = IfConcreteClass {+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,+                ifATs    = map toIfaceAT clas_ats,+                ifSigs   = map toIfaceClassOp op_stuff,+                ifMinDef = toIfaceBooleanFormula (classMinimalDef clas),+                ifUnary  = isUnaryClassTyCon tycon+            }++    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)++    toIfaceAT :: ClassATItem -> IfaceAT+    toIfaceAT (ATI tc def)+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)+      where+        (env2, if_decl) = tyConToIfaceDecl env1 tc++    toIfaceClassOp (sel_id, def_meth)+        = assert (sel_tyvars == binderVars tc_binders) $+          IfaceClassOp (getName sel_id)+                       (tidyToIfaceType env1 op_ty)+                       (fmap toDmSpec def_meth)+        where+                -- Be careful when splitting the type, because of things+                -- like         class Foo a where+                --                op :: (?x :: String) => a -> a+                -- and          class Baz a where+                --                op :: (Ord a) => a -> a+          (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id)+          op_ty                = funResultTy rho_ty++    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType+    toDmSpec (_, VanillaDM)       = VanillaDM+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)++    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1+                             ,map (tidyTyVar env1) tvs2)++--------------------------++tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)+-- If the type variable "binder" is in scope, don't re-bind it+-- In a class decl, for example, the ATD binders mention+-- (amd must mention) the class tyvars+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)+ = case lookupVarEnv subst tv of+     Just tv' -> (env,  Bndr tv' vis)+     Nothing  -> tidyForAllTyBinder env tvb++tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])+tidyTyConBinders = mapAccumL tidyTyConBinder++tidyTyVar :: TidyEnv -> TyVar -> IfLclName+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
+ compiler/GHC/Iface/Errors/Ppr.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage+{-# LANGUAGE InstanceSigs #-}++module GHC.Iface.Errors.Ppr+  ( IfaceMessageOpts(..)+  , interfaceErrorHints+  , interfaceErrorReason+  , interfaceErrorDiagnostic+  , missingInterfaceErrorHints+  , missingInterfaceErrorReason+  , missingInterfaceErrorDiagnostic+  , readInterfaceErrorDiagnostic++  , lookingForHerald+  , cantFindErrorX+  , mayShowLocations+  , pkgHiddenHint+  )+  where++import GHC.Prelude++import GHC.Types.Error+import GHC.Types.Hint.Ppr () -- Outputable GhcHint+import GHC.Types.Error.Codes+import GHC.Types.Name+import GHC.Types.TyThing++import GHC.Unit.State+import GHC.Unit.Module++import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Iface.Errors.Types++defaultIfaceMessageOpts :: IfaceMessageOpts+defaultIfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles = False+                                           , ifaceBuildingCabalPackage = NoBuildingCabalPackage }++instance HasDefaultDiagnosticOpts IfaceMessageOpts where+  defaultOpts = defaultIfaceMessageOpts++instance Diagnostic IfaceMessage where+  type DiagnosticOpts IfaceMessage = IfaceMessageOpts+  diagnosticMessage opts reason = mkSimpleDecorated $+         interfaceErrorDiagnostic opts reason++  diagnosticReason = interfaceErrorReason++  diagnosticHints = interfaceErrorHints++  diagnosticCode = constructorCode @GHC++interfaceErrorHints :: IfaceMessage -> [GhcHint]+interfaceErrorHints = \ case+  Can'tFindInterface err _looking_for ->+    missingInterfaceErrorHints err+  Can'tFindNameInInterface {} ->+    noHints+  CircularImport {} ->+    noHints++missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint]+missingInterfaceErrorHints = \case+  BadSourceImport {} ->+    noHints+  HomeModError {} ->+    noHints+  DynamicHashMismatchError {} ->+    noHints+  CantFindErr {} ->+    noHints+  BadIfaceFile {} ->+    noHints+  FailedToLoadDynamicInterface {} ->+    noHints++interfaceErrorReason :: IfaceMessage -> DiagnosticReason+interfaceErrorReason (Can'tFindInterface err _)+  = missingInterfaceErrorReason err+interfaceErrorReason (Can'tFindNameInInterface {})+  = ErrorWithoutFlag+interfaceErrorReason (CircularImport {})+  = ErrorWithoutFlag++missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason+missingInterfaceErrorReason = \ case+  BadSourceImport {} ->+    ErrorWithoutFlag+  HomeModError {} ->+    ErrorWithoutFlag+  DynamicHashMismatchError {} ->+    ErrorWithoutFlag+  CantFindErr {} ->+    ErrorWithoutFlag+  BadIfaceFile {} ->+    ErrorWithoutFlag+  FailedToLoadDynamicInterface {} ->+    ErrorWithoutFlag+++prettyCantFindWhat :: FindOrLoad -> FindingModuleOrInterface -> AmbiguousOrMissing -> SDoc+prettyCantFindWhat Find FindingModule AoM_Missing = text "Could not find module"+prettyCantFindWhat Load FindingModule AoM_Missing = text "Could not load module"+prettyCantFindWhat _ FindingInterface AoM_Missing = text "Failed to load interface for"+prettyCantFindWhat _ FindingModule AoM_Ambiguous = text "Ambiguous module name"+prettyCantFindWhat _ FindingInterface AoM_Ambiguous = text "Ambiguous interface for"++isAmbiguousInstalledReason :: CantFindInstalledReason -> AmbiguousOrMissing+isAmbiguousInstalledReason (MultiplePackages {}) = AoM_Ambiguous+isAmbiguousInstalledReason _ = AoM_Missing++isLoadOrFindReason :: CantFindInstalledReason -> FindOrLoad+isLoadOrFindReason NotAModule {} = Find+isLoadOrFindReason (GenericMissing a b c _) | null a && null b && null c = Find+isLoadOrFindReason (ModuleSuggestion {}) = Find+isLoadOrFindReason _ = Load++data FindOrLoad  = Find | Load++data AmbiguousOrMissing = AoM_Ambiguous | AoM_Missing++cantFindError :: IfaceMessageOpts+  -> FindingModuleOrInterface+  -> CantFindInstalled+  -> SDoc+cantFindError opts =+  cantFindErrorX+    (pkgHiddenHint (const empty) (ifaceBuildingCabalPackage opts))+    (mayShowLocations "-v" (ifaceShowTriedFiles opts))+++pkgHiddenHint :: (UnitInfo -> SDoc) -> BuildingCabalPackage+              -> UnitInfo -> SDoc+pkgHiddenHint _hint YesBuildingCabalPackage pkg+ = text "Perhaps you need to add" <+>+   quotes (ppr (unitPackageName pkg)) <+>+   text "to the build-depends in your .cabal file."+pkgHiddenHint hint _not_cabal pkg+ = hint pkg++mayShowLocations :: String -> Bool -> [FilePath] -> SDoc+mayShowLocations option verbose files+    | null files = empty+    | not verbose =+          text "Use" <+> text option <+>+              text "to see a list of the files searched for."+    | otherwise =+          hang (text "Locations searched:") 2 $ vcat (map text files)++-- | General version of cantFindError which has some holes which allow GHC/GHCi to display slightly different+-- error messages.+cantFindErrorX :: (UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc+cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInstalled mod_name cfir) =+  let ambig = isAmbiguousInstalledReason cfir+      find_or_load = isLoadOrFindReason cfir+      ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig+  in+  (ppr_what <+> quotes (ppr mod_name) <> dot) $$+  case cfir of+    NoUnitIdMatching pkg cands ->++      let looks_like_srcpkgid :: SDoc+          looks_like_srcpkgid =+     -- Unsafely coerce a unit id (i.e. an installed package component+     -- identifier) into a PackageId and see if it means anything.+           case cands of+             (pkg:pkgs) ->+              parens (text "This unit ID looks like the source package ID;" $$+                      text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+                     (if null pkgs then empty+                                  else text "and" <+> int (length pkgs) <+> text "other candidate" <> plural pkgs))+             -- Todo: also check if it looks like a package name!+             [] -> empty++      in hsep [ text "no unit id matching" <+> quotes (ppr pkg)+              , text "was found"] $$ looks_like_srcpkgid+    MissingPackageFiles pkg files ->+      text "There are files missing in the " <> quotes (ppr pkg) <+>+      text "package," $$+      text "try running 'ghc-pkg check'." $$+      may_show_locations files+    MissingPackageWayFiles build pkg files ->+      text "Perhaps you haven't installed the " <> text build <+>+      text "libraries for package " <> quotes (ppr pkg) <> char '?' $$+      may_show_locations files+    ModuleSuggestion ms fps ->++      let pp_suggestions :: [ModuleSuggestion] -> SDoc+          pp_suggestions sugs+            | null sugs = empty+            | otherwise = hang (text "Perhaps you meant")+                             2 (vcat (map pp_sugg sugs))++          -- NB: Prefer the *original* location, and then reexports, and then+          -- package flags when making suggestions.  ToDo: if the original package+          -- also has a reexport, prefer that one+          pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+            where provenance ModHidden = empty+                  provenance (ModUnusable _) = empty+                  provenance (ModOrigin{ fromOrigUnit = e,+                                         fromExposedReexport = res,+                                         fromPackageFlag = f })+                    | Just True <- e+                       = parens (text "from" <+> ppr (moduleUnit mod))+                    | f && moduleName mod == m+                       = parens (text "from" <+> ppr (moduleUnit mod))+                    | (pkg:_) <- res+                       = parens (text "from" <+> ppr (mkUnit pkg)+                          <> comma <+> text "reexporting" <+> ppr mod)+                    | f+                       = parens (text "defined via package flags to be"+                          <+> ppr mod)+                    | otherwise = empty+          pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+            where provenance ModHidden =  empty+                  provenance (ModUnusable _) = empty+                  provenance (ModOrigin{ fromOrigUnit = e,+                                         fromHiddenReexport = rhs })+                    | Just False <- e+                       = parens (text "needs flag -package-id"+                          <+> ppr (moduleUnit mod))+                    | (pkg:_) <- rhs+                       = parens (text "needs flag -package-id"+                          <+> ppr (mkUnit pkg))+                    | otherwise = empty++        in pp_suggestions ms $$ may_show_locations fps+    NotAModule -> text "It is not a module in the current program, or in any known package."+    CouldntFindInFiles fps -> vcat (map text fps)+    MultiplePackages mods+      | Just pkgs <- unambiguousPackages+      -> sep [text "it was found in multiple packages:",+            hsep (map ppr pkgs)]+      | otherwise+      -> vcat (map pprMod mods)+      where+        unambiguousPackages = foldl' unambiguousPackage (Just []) mods+        unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+            = Just (moduleUnit m : xs)+        unambiguousPackage _ _ = Nothing+    GenericMissing pkg_hiddens mod_hiddens unusables files ->+      vcat (map pkg_hidden pkg_hiddens) $$+      vcat (map mod_hidden mod_hiddens) $$+      vcat (map unusable unusables) $$+      may_show_locations files+  where+    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnit m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.mkUnit) res +++      if f then [text "a package flag"] else []+      )+    pkg_hidden :: (Unit, Maybe UnitInfo) -> SDoc+    pkg_hidden (uid, uif) =+        text "It is a member of the hidden package"+        <+> quotes (ppr uid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ maybe empty pkg_hidden_hint uif+++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    unusable (UnusableUnit unit reason reexport)+      = text "It is " <> (if reexport then text "reexported from the package"+                                      else text "a member of the package")+      <+> quotes (ppr unit)+      $$ pprReason (text "which is") reason+++interfaceErrorDiagnostic :: IfaceMessageOpts -> IfaceMessage -> SDoc+interfaceErrorDiagnostic opts = \ case+  Can'tFindNameInInterface name relevant_tyThings ->+    missingDeclInInterface name relevant_tyThings+  Can'tFindInterface err looking_for ->+    hangNotEmpty (lookingForHerald looking_for) 2 (missingInterfaceErrorDiagnostic opts err)+  CircularImport mod ->+    text "Circular imports: module" <+> quotes (ppr mod)+    <+> text "depends on itself"++lookingForHerald :: InterfaceLookingFor -> SDoc+lookingForHerald looking_for =+    case looking_for of+      LookingForName {} -> empty+      LookingForModule {} -> empty+      LookingForHiBoot mod ->+        text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon+      LookingForSig sig ->+        text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon++readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc+readInterfaceErrorDiagnostic = \ case+  ExceptionOccurred fp ex ->+    hang (text "Exception when reading interface file " <+> text fp)+      2 (text (showException ex))+  HiModuleNameMismatchWarn _ m1 m2 ->+    hiModuleNameMismatchWarn m1 m2++missingInterfaceErrorDiagnostic :: IfaceMessageOpts -> MissingInterfaceError -> SDoc+missingInterfaceErrorDiagnostic opts reason =+  case reason of+    BadSourceImport m -> badSourceImport m+    HomeModError im ml -> homeModError im ml+    DynamicHashMismatchError m ml -> dynamicHashMismatchError m ml+    CantFindErr us module_or_interface cfi -> pprWithUnitState us $ cantFindError opts module_or_interface cfi+    BadIfaceFile rie -> readInterfaceErrorDiagnostic rie+    FailedToLoadDynamicInterface wanted_mod err ->+      hang (text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon)+        2 (readInterfaceErrorDiagnostic err)++hiModuleNameMismatchWarn :: Module -> Module -> SDoc+hiModuleNameMismatchWarn requested_mod read_mod+ | moduleUnit requested_mod == moduleUnit read_mod =+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,+         text "but we were expecting module" <+> quotes (ppr requested_mod),+         sep [text "Probable cause: the source code which generated interface file",+             text "has an incompatible module name"+            ]+        ]+ | otherwise =+  -- 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.+    hsep [ text "Something is amiss; requested module "+         , ppr requested_mod+         , text "differs from name found in the interface file"+         , ppr read_mod+         ]++dynamicHashMismatchError :: Module -> ModLocation -> SDoc+dynamicHashMismatchError wanted_mod loc  =+  vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod)+       , text "Normal interface file from"  <+> text (ml_hi_file loc)+       , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc)+       , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+  = text "attempting to use module " <> quotes (ppr mod)+    <> (case ml_hs_file location of+           Just file -> space <> parens (text file)+           Nothing   -> empty)+    <+> text "which is not loaded"+++missingDeclInInterface :: Name -> [TyThing] -> SDoc+missingDeclInInterface name things =+  whenPprDebug (found_things $$ empty) $$+  hang (text "Can't find interface-file declaration for" <+>+         pprNameSpace (nameNameSpace name) <+> ppr name)+    2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",+             text "Use -ddump-if-trace to get an idea of which file caused the error"])+  where+    found_things =+      hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)+           2 (vcat (map ppr things))++badSourceImport :: Module -> SDoc+badSourceImport mod+  = hang (text "You cannot {-# SOURCE #-} import a module from another package")+       2 (text "but" <+> quotes (ppr mod) <+> text "is from package"+          <+> quotes (ppr (moduleUnit mod)))
+ compiler/GHC/Iface/Errors/Types.hs view
@@ -0,0 +1,98 @@++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module GHC.Iface.Errors.Types (++    MissingInterfaceError(..)+  , InterfaceLookingFor(..)+  , IfaceMessage(..)+  , ReadInterfaceError(..)+  , CantFindInstalled(..)+  , CantFindInstalledReason(..)+  , FindingModuleOrInterface(..)++  , BuildingCabalPackage(..)++  , IfaceMessageOpts(..)++  ) where++import GHC.Prelude++import GHC.Types.Name (Name)+import GHC.Types.TyThing (TyThing)+import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit)+import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnit, UnitInfo)+import GHC.Exception.Type (SomeException)+import GHC.Unit.Types ( IsBootInterface )+import Language.Haskell.Syntax.Module.Name ( ModuleName )++++import GHC.Generics ( Generic )+import GHC.Unit.Module.Location++data IfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles :: !Bool -- ^ Whether to show files we tried to look for or not when printing loader errors+                                         , ifaceBuildingCabalPackage :: !BuildingCabalPackage+                                         }++data InterfaceLookingFor+  = LookingForName   !Name+  | LookingForHiBoot !Module+  | LookingForModule !ModuleName !IsBootInterface+  | LookingForSig    !InstalledModule++data IfaceMessage+  = Can'tFindInterface+      MissingInterfaceError+      InterfaceLookingFor+  | Can'tFindNameInInterface+      Name+      [TyThing] -- possibly relevant TyThings+  | CircularImport !Module+  deriving Generic++data MissingInterfaceError+  = BadSourceImport !Module+  | HomeModError !InstalledModule !ModLocation+  | DynamicHashMismatchError !Module !ModLocation++  | CantFindErr !UnitState FindingModuleOrInterface CantFindInstalled++  | BadIfaceFile ReadInterfaceError+  | FailedToLoadDynamicInterface Module ReadInterfaceError+    deriving Generic++data ReadInterfaceError+  = ExceptionOccurred        FilePath SomeException+  | HiModuleNameMismatchWarn FilePath Module Module+  deriving Generic++data CantFindInstalledReason+  = NoUnitIdMatching UnitId [UnitInfo]+  | MissingPackageFiles UnitId [FilePath]+  | MissingPackageWayFiles String UnitId [FilePath]+  | ModuleSuggestion [ModuleSuggestion] [FilePath]+  | NotAModule+  | CouldntFindInFiles [FilePath]+  | GenericMissing+      [(Unit, Maybe UnitInfo)] [Unit]+      [UnusableUnit] [FilePath]+  | MultiplePackages [(Module, ModuleOrigin)]+  deriving Generic++data CantFindInstalled =+  CantFindInstalled ModuleName CantFindInstalledReason+  deriving Generic+data FindingModuleOrInterface = FindingModule+                              | FindingInterface++-- | Pass to a 'DriverMessage' the information whether or not the+-- '-fbuilding-cabal-package' flag is set.+data BuildingCabalPackage+  = YesBuildingCabalPackage+  | NoBuildingCabalPackage+  deriving Eq
compiler/GHC/Iface/Ext/Fields.hs view
@@ -33,16 +33,16 @@     -- for a payload pointer after each name:     header_entries <- forM (Map.toList fs) $ \(name, dat) -> do       put_ bh name-      field_p_p <- tellBin bh+      field_p_p <- tellBinWriter bh       put_ bh field_p_p       return (field_p_p, dat)      -- Now put the payloads and use the reserved space     -- to point to the start of each payload:     forM_ header_entries $ \(field_p_p, dat) -> do-      field_p <- tellBin bh-      putAt bh field_p_p field_p-      seekBin bh field_p+      field_p <- tellBinWriter bh+      putAtRel bh field_p_p field_p+      seekBinWriter bh field_p       put_ bh dat    get bh = do@@ -50,11 +50,11 @@      -- Get the names and field pointers:     header_entries <- replicateM n $-      (,) <$> get bh <*> get bh+      (,) <$> get bh <*> getRelBin bh      -- Seek to and get each field's payload:     fields <- forM header_entries $ \(name, field_p) -> do-      seekBin bh field_p+      seekBinReaderRel bh field_p       dat <- get bh       return (name, dat) @@ -72,7 +72,7 @@ readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a) readField name = readFieldWith name get -readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)+readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a) readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>   Map.lookup name (getExtensibleFields fields) @@ -82,7 +82,7 @@ writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields writeField name x = writeFieldWith name (`put_` x) -writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields+writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields writeFieldWith name write fields = do   bh <- openBinMem (1024 * 1024)   write bh
+ 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
@@ -14,8 +14,10 @@ import GHC.Utils.Binary import GHC.Types.Name import GHC.Utils.Panic.Plain+import GHC.Iface.Type (putIfaceType)+import System.IO.Unsafe (unsafePerformIO) -fingerprintBinMem :: BinHandle -> IO Fingerprint+fingerprintBinMem :: WriteBinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f   where     f bs =@@ -26,20 +28,24 @@         in fp `seq` return fp  computeFingerprint :: (Binary a)-                   => (BinHandle -> Name -> IO ())+                   => (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   where-    set_user_data bh =-      setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS+    set_user_data bh = setWriterUserData bh $ mkWriterUserData+      [ mkSomeBinaryWriter $ mkWriter putIfaceType+      , mkSomeBinaryWriter $ mkWriter put_nonbinding_name+      , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally+      , mkSomeBinaryWriter $ mkWriter putFS+      ]  -- | Used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to.-putNameLiterally :: BinHandle -> Name -> IO ()+putNameLiterally :: WriteBinHandle -> Name -> IO () putNameLiterally bh name = assert (isExternalName name) $ do     put_ bh $! nameModule name     put_ bh $! nameOccName name
+ 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
@@ -12,18 +12,22 @@          IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),         IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,-        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding,+        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,         IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),         IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,-        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),-        IfaceClassBody(..),+        IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..),+        IfaceDefault(..), IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),+        IfaceClassBody(..), IfaceBooleanFormula(..),         IfaceBang(..),         IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),         IfaceAxBranch(..),         IfaceTyConParent(..),         IfaceCompleteMatch(..),         IfaceLFInfo(..), IfaceTopBndrInfo(..),+        IfaceImport(..),+        ifImpModule,+        ImpIfaceList(..), IfaceExport,          -- * Binding names         IfaceTopBndr,@@ -32,9 +36,11 @@         -- Misc         ifaceDeclImplicitBndrs, visibleIfConDecls,         ifaceDeclFingerprints,-+        fromIfaceWarnings,+        fromIfaceWarningTxt,         -- Free Names         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,+        freeNamesIfConDecls,          -- Pretty printing         pprIfaceExpr,@@ -44,6 +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 )@@ -54,37 +64,45 @@ 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.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )+import GHC.Types.SourceText 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(..) )  import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint import GHC.Utils.Binary-import GHC.Utils.Binary.Typeable ()+import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload 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.Basic (FieldLabelString(..))+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 &&& @@ -96,6 +114,53 @@ ************************************************************************ -} +type IfaceExport = AvailInfo++data IfaceImport = IfaceImport ImpDeclSpec ImpIfaceList++data ImpIfaceList+  = ImpIfaceAll -- ^ no user import list+  | 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@@ -109,16 +174,15 @@   -- We don't serialise the namespace onto the disk though; rather we   -- drop it when serialising and add it back in when deserialising. -getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr+getIfaceTopBndr :: ReadBinHandle -> IO IfaceTopBndr getIfaceTopBndr bh = get bh -putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()+putIfaceTopBndr :: WriteBinHandle -> IfaceTopBndr -> IO () putIfaceTopBndr bh name =-    case getUserData bh of-      UserData{ ud_put_binding_name = put_binding_name } ->+    case findUserDataWriter (Proxy @BindingName) bh of+      tbl ->           --pprTrace "putIfaceTopBndr" (ppr name) $-          put_binding_name bh name-+          putEntry tbl bh (BindingName name)  data IfaceDecl   = IfaceId { ifName      :: IfaceTopBndr,@@ -191,9 +255,25 @@      ifClassCtxt :: IfaceContext,             -- Super classes      ifATs       :: [IfaceAT],                -- Associated type families      ifSigs      :: [IfaceClassOp],           -- Method signatures-     ifMinDef    :: BooleanFormula IfLclName  -- 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++ data IfaceTyConParent   = IfNoParent   | IfDataInstance@@ -261,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@@ -289,12 +369,23 @@ data IfaceSrcBang   = IfSrcBang SrcUnpackedness SrcStrictness +-- See Note [Named default declarations] in GHC.Tc.Gen.Default+-- | Exported named defaults+data IfaceDefault+  = IfaceDefault { ifDefaultCls  :: IfExtName,            -- Defaulted class+                   ifDefaultTys  :: [IfaceType],          -- List of defaults+                   ifDefaultWarn :: Maybe IfaceWarningTxt }+ data IfaceClsInst   = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst                    ifDFun     :: IfExtName,                -- The dfun                    ifOFlag    :: OverlapFlag,              -- Overlap flag-                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in GHC.Core.InstEnv+                   ifInstOrph :: IsOrphan,                 -- See Note [Orphans] in GHC.Core.InstEnv+                   ifInstWarn :: Maybe IfaceWarningTxt }+                     -- Warning emitted when the instance is used+                     -- See Note [Implementation of deprecated instances]+                     -- in GHC.Tc.Solver.Dict         -- There's always a separate IfaceDecl for the DFun, which gives         -- its IdInfo with its full type and version number.         -- The instance declarations taken together have a version number,@@ -323,6 +414,18 @@         ifRuleOrph   :: IsOrphan   -- Just like IfaceClsInst     } +data IfaceWarnings+  = IfWarnAll IfaceWarningTxt+  | IfWarnSome [(OccName, IfaceWarningTxt)]+               [(IfExtName, IfaceWarningTxt)]++data IfaceWarningTxt+  = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])]+  | IfDeprecatedTxt                      SourceText [(IfaceStringLiteral, [IfExtName])]++data IfaceStringLiteral+  = IfStringLiteral SourceText FastString+ data IfaceAnnotation   = IfaceAnnotation {         ifAnnotatedTarget :: IfaceAnnTarget,@@ -331,7 +434,7 @@  type IfaceAnnTarget = AnnTarget OccName -data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfaceTyCon)+data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfExtName)  instance Outputable IfaceCompleteMatch where   ppr (IfaceCompleteMatch cls mtc) = text "COMPLETE" <> colon <+> ppr cls <+> case mtc of@@ -385,7 +488,11 @@ data IfaceIdDetails   = IfVanillaId   | IfWorkerLikeId [CbvMark]-  | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool+  | IfRecSelId+    { ifRecSelIdParent     :: Either IfaceTyCon IfaceDecl+    , ifRecSelFirstCon     :: IfaceTopBndr+    , ifRecSelIdIsNaughty  :: Bool+    , ifRecSelIdFieldLabel :: FieldLabel }   | IfDFunId  -- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are@@ -443,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -494,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] ++@@ -509,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 _ = [] @@ -541,10 +650,26 @@     [ (occ, computeFingerprint' (hash,occ))     | occ <- ifaceDeclImplicitBndrs decl ]   where-     computeFingerprint' =-       unsafeDupablePerformIO-        . computeFingerprint (panic "ifaceDeclFingerprints")+    computeFingerprint' = computeFingerprint (panic "ifaceDeclFingerprints") +fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn+fromIfaceWarnings = \case+    IfWarnAll txt -> WarnAll (fromIfaceWarningTxt txt)+    IfWarnSome vs ds -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- vs]+                                 [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- ds]++fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn+fromIfaceWarningTxt = \case+    IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs)+    IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)++fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn+fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)++fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral+fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing++ {- ************************************************************************ *                                                                      *@@ -571,18 +696,19 @@   | IfaceFCall  ForeignCall IfaceType   | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E + data IfaceTickish-  = IfaceHpcTick Module Int                -- from HpcTick x-  | IfaceSCC     CostCentre Bool Bool      -- from ProfNote-  | IfaceSource  RealSrcSpan String        -- from SourceNote-  -- no breakpoints: we never export these into interface files+  = IfaceHpcTick    Module Int               -- from HpcTick x+  | IfaceSCC        CostCentre Bool Bool     -- from ProfNote+  | IfaceSource  RealSrcSpan FastString      -- from SourceNote+  | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint  data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr         -- Note: IfLclName, not IfaceBndr (and same with the case binder)         -- We reconstruct the kind/type of the thing from the context         -- thus saving bulk in interface files -data IfaceConAlt = IfaceDefault+data IfaceConAlt = IfaceDefaultAlt                  | IfaceDataAlt IfExtName                  | IfaceLitAlt Literal @@ -596,7 +722,7 @@ -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings]-data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood  data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails                       | IfGblTopBndr IfaceTopBndr@@ -604,9 +730,6 @@ -- See Note [Interface File with Core: Sharing RHSs] data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr -data IfaceJoinInfo = IfaceNotJoinPoint-                   | IfaceJoinPoint JoinArity- {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -696,6 +819,27 @@             text "--" <+> text "incompatible with:"             <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps +instance Outputable IfaceWarnings where+    ppr = \case+        IfWarnAll txt -> text "Warn all" <+> ppr txt+        IfWarnSome vs ds ->+          hang (text "Warnings:") 2 $+            text "Deprecated names:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- vs] $$+            text "Deprecated exports:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- ds]++instance Outputable IfaceWarningTxt where+    ppr = \case+        IfWarningTxt _ _ ws  -> pp_ws ws+        IfDeprecatedTxt _ ds -> pp_ws ds+      where+        pp_ws [msg] = pp_with_name msg+        pp_ws msgs = brackets $ vcat . punctuate comma . map pp_with_name $ msgs++        pp_with_name = ppr . fst++instance Outputable IfaceStringLiteral where+    ppr (IfStringLiteral st fs) = pprWithSourceText st (ftext fs)+ instance Outputable IfaceAnnotation where   ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value @@ -745,27 +889,6 @@ filtered and hide it in that case. -} -data ShowSub-  = ShowSub-      { ss_how_much :: ShowHowMuch-      , ss_forall :: ShowForAllFlag }---- See Note [Printing IfaceDecl binders]--- The alternative pretty printer referred to in the note.-newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))--data ShowHowMuch-  = ShowHeader AltPpr -- ^Header information only, not rhs-  | ShowSome [OccName] AltPpr-  -- ^ Show only some sub-components. Specifically,-  ---  -- [@\[\]@] Print all sub-components.-  -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;-  -- elide other sub-components to @...@-  -- May 14: the list is max 1 element long at the moment-  | ShowIface-  -- ^Everything including GHC-internal information (used in --show-iface)- {- Note [Printing IfaceDecl binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -779,15 +902,13 @@ everything unqualified, so we can just print the OccName directly. -} -instance Outputable ShowHowMuch where-  ppr (ShowHeader _)    = text "ShowHeader"-  ppr ShowIface         = text "ShowIface"-  ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs-+-- | Show a declaration but not its RHS. showToHeader :: ShowSub showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing                        , ss_forall = ShowForAllWhen } +-- | Show declaration and its RHS, including GHc-internal information (e.g.+-- for @--show-iface@). showToIface :: ShowSub showToIface = ShowSub { ss_how_much = ShowIface                       , ss_forall = ShowForAllWhen }@@ -798,18 +919,20 @@  -- show if all sub-components or the complete interface is shown ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition]-ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc-ppShowAllSubs (ShowSub { ss_how_much = ShowIface })     doc = doc-ppShowAllSubs _                                         _   = Outputable.empty+ppShowAllSubs (ShowSub { ss_how_much = ShowSome Nothing _ }) doc+                                                        = doc+ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc+ppShowAllSubs _                                     _   = Outputable.empty  ppShowRhs :: ShowSub -> SDoc -> SDoc ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _   = Outputable.empty ppShowRhs _                                        doc = doc  showSub :: HasOccName n => ShowSub -> n -> Bool-showSub (ShowSub { ss_how_much = ShowHeader _ })     _     = False-showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing-showSub (ShowSub { ss_how_much = _ })              _     = True+showSub (ShowSub { ss_how_much = ShowHeader _ }) _     = False+showSub (ShowSub { ss_how_much = ShowSome (Just f) _ }) thing+                                                       = f (occName thing)+showSub (ShowSub { ss_how_much = _ })            _     = True  ppr_trim :: [Maybe SDoc] -> [SDoc] -- Collapse a group of Nothings to a single "..."@@ -839,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@@ -870,16 +1204,13 @@     cons       = visibleIfConDecls condecls     pp_where   = ppWhen (gadt && not (null cons)) $ text "where"     pp_cons    = ppr_trim (map show_con cons) :: [SDoc]-    pp_kind    = ppUnless (if ki_sig_printable-                              then isIfaceRhoType kind-                                      -- Even in the presence of a standalone kind signature, a non-tau-                                      -- result kind annotation cannot be discarded as it determines the arity.-                                      -- See Note [Arity inference in kcCheckDeclHeader_sig] in GHC.Tc.Gen.HsType-                              else isIfaceLiftedTypeKind kind)+    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@@ -926,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 minDef)])]+                        , 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 @@ -969,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 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 ||@@ -1002,27 +1346,28 @@     -- 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+         , hang (text "type family" <+> decl_head <+> pp_inj res_var inj                    <+> ppShowRhs ss (pp_where rhs))-              2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))+              2 (ppShowRhs ss (pp_rhs rhs))            $$            nest 2 (ppShowRhs ss (pp_branches rhs))          ]   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 @@ -1034,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")@@ -1111,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@@ -1168,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@@ -1212,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@@ -1235,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@@ -1299,7 +1658,7 @@       | otherwise      = Nothing       where         sel = flSelector lbl-        occ = mkVarOccFS (field_label $ flLabel lbl)+        occ = nameOccName sel      mk_user_con_res_ty :: IfaceEqSpec -> SDoc     -- See Note [Result type of a data family GADT]@@ -1346,6 +1705,10 @@     where       pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot +instance Outputable IfaceDefault where+  ppr (IfaceDefault { ifDefaultCls = cls, ifDefaultTys = tcs })+    = text "default" <+> ppr cls <+> parens (pprWithCommas ppr tcs)+ instance Outputable IfaceClsInst where   ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag                     , ifInstCls = cls, ifInstTys = mb_tcs@@ -1487,6 +1850,8 @@   = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names)   = braces (pprUserRealSpan True src)+pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)+  = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs)  ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc@@ -1496,7 +1861,7 @@  ------------------ instance Outputable IfaceConAlt where-    ppr IfaceDefault      = text "DEFAULT"+    ppr IfaceDefaultAlt   = text "DEFAULT"     ppr (IfaceLitAlt l)   = ppr l     ppr (IfaceDataAlt d)  = ppr d @@ -1504,10 +1869,10 @@ instance Outputable IfaceIdDetails where   ppr IfVanillaId       = Outputable.empty   ppr (IfWorkerLikeId dmd) = text "StrWork" <> parens (ppr dmd)-  ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc-                          <+> if b-                                then text "<naughty>"-                                else Outputable.empty+  ppr (IfRecSelId tc _c b _fl) = text "RecSel" <+> ppr tc+                            <+> if b+                                  then text "<naughty>"+                                  else Outputable.empty   ppr IfDFunId          = text "DFunId"  instance Outputable IfaceInfoItem where@@ -1522,10 +1887,6 @@   ppr (HsLFInfo lf_info)    = text "LambdaFormInfo:" <+> ppr lf_info   ppr (HsTagSig tag_sig)    = text "TagSig:" <+> ppr tag_sig -instance Outputable IfaceJoinInfo where-  ppr IfaceNotJoinPoint   = empty-  ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)- instance Outputable IfaceUnfolding where   ppr (IfCoreUnfold src _ guide e)     = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]@@ -1623,9 +1984,13 @@     freeNamesIfType rhs  freeNamesIfIdDetails :: IfaceIdDetails -> NameSet-freeNamesIfIdDetails (IfRecSelId tc _) =-  either freeNamesIfTc freeNamesIfDecl tc-freeNamesIfIdDetails _                 = emptyNameSet+freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) =+  either freeNamesIfTc freeNamesIfDecl tc &&&+  unitFV first_con &&&+  unitFV (flSelector fl)+freeNamesIfIdDetails IfVanillaId         = emptyNameSet+freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet+freeNamesIfIdDetails IfDFunId            = emptyNameSet  -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet@@ -1657,7 +2022,7 @@ freeNamesIfConDecls :: IfaceConDecls -> NameSet freeNamesIfConDecls (IfDataTyCon _ cs) = fnList freeNamesIfConDecl cs freeNamesIfConDecls (IfNewTyCon    c)  = freeNamesIfConDecl c-freeNamesIfConDecls _                   = emptyNameSet+freeNamesIfConDecls _                  = emptyNameSet  freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl (IfCon { ifConExTCvs  = ex_tvs, ifConCtxt = ctxt@@ -1710,15 +2075,13 @@   = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceAppCo c1 c2)   = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2-freeNamesIfCoercion (IfaceForAllCo _ kind_co co)+freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co)   = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet freeNamesIfCoercion (IfaceCoVarCo _)   = emptyNameSet freeNamesIfCoercion (IfaceHoleCo _)    = emptyNameSet-freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)-  = unitNameSet ax &&& fnList freeNamesIfCoercion cos-freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)-  = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2+freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2 cos)+  = freeNamesIfType t1 &&& freeNamesIfType t2 &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceSymCo c)   = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2)@@ -1733,15 +2096,13 @@   = freeNamesIfCoercion c freeNamesIfCoercion (IfaceSubCo co)   = freeNamesIfCoercion co-freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)-  -- the axiom is just a string, so we don't count it as a name.-  = fnList freeNamesIfCoercion cos+freeNamesIfCoercion (IfaceAxiomCo ax cos)+  = fnAxRule ax &&& fnList freeNamesIfCoercion cos -freeNamesIfProv :: IfaceUnivCoProv -> NameSet-freeNamesIfProv (IfacePhantomProv co)    = freeNamesIfCoercion co-freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co-freeNamesIfProv (IfacePluginProv _)      = emptyNameSet-freeNamesIfProv (IfaceCorePrepProv _)    = emptyNameSet+fnAxRule :: IfaceAxiomRule -> NameSet+fnAxRule (IfaceAR_X _)   = emptyNameSet -- the axiom is just a string, so we don't count it as a name.+fnAxRule (IfaceAR_U n)   = unitNameSet n+fnAxRule (IfaceAR_B n _) = unitNameSet n  freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr@@ -1791,7 +2152,7 @@ freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a)        = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co)      = freeNamesIfExpr e &&& freeNamesIfCoercion co-freeNamesIfExpr (IfaceTick _ e)       = freeNamesIfExpr e+freeNamesIfExpr (IfaceTick t e)       = freeNamesIfTickish t &&& freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty)     = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts)   = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts@@ -1801,7 +2162,7 @@     -- Depend on the data constructors.  Just one will do!     -- Note [Tracking data constructors]     fn_cons []                                     = emptyNameSet-    fn_cons (IfaceAlt IfaceDefault _ _       : xs) = fn_cons xs+    fn_cons (IfaceAlt IfaceDefaultAlt    _ _ : xs) = fn_cons xs     fn_cons (IfaceAlt (IfaceDataAlt con) _ _ : _ ) = unitNameSet con     fn_cons (_                               : _ ) = emptyNameSet @@ -1838,6 +2199,11 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys)   = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys +freeNamesIfTickish :: IfaceTickish -> NameSet+freeNamesIfTickish (IfaceBreakpoint _ fvs) =+  fnList freeNamesIfExpr fvs+freeNamesIfTickish _ = emptyNameSet+ -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSet@@ -1860,7 +2226,7 @@      data DynFlags = DF ... PackageState ...     module Packages where-     import GHC.Driver.Session+     import GHC.Driver.DynFlags      data PackageState = PS ...      lookupModule (df :: DynFlags)         = case df of@@ -1930,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@@ -1943,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@@ -2016,6 +2384,7 @@                     a6 <- get bh                     a7 <- get bh                     a8 <- get bh+                    a9 <- get bh                     return (IfaceClass {                         ifName    = a2,                         ifRoles   = a3,@@ -2023,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@@ -2056,6 +2426,20 @@                         ifBody = IfAbstractClass })             _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) +instance Binary IfaceBooleanFormula where+    put_ bh = \case+        IfVar a1    -> putByte bh 0 >> put_ bh a1+        IfAnd a1    -> putByte bh 1 >> put_ bh a1+        IfOr a1     -> putByte bh 2 >> put_ bh a1+        IfParens a1 -> putByte bh 3 >> put_ bh a1++    get bh = do+        getByte bh >>= \case+            0 -> IfVar    <$> get bh+            1 -> IfAnd    <$> get bh+            2 -> IfOr     <$> get bh+            _ -> IfParens <$> get bh+ {- Note [Lazy deserialization of IfaceId] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The use of lazyPut and lazyGet in the IfaceId Binary instance is@@ -2205,20 +2589,33 @@          a2 <- get bh          return (IfSrcBang a1 a2) +instance Binary IfaceDefault where+    put_ bh (IfaceDefault cls tys warn) = do+        put_ bh cls+        put_ bh tys+        put_ bh warn+    get bh = do+        cls  <- get bh+        tys  <- get bh+        warn <- get bh+        return (IfaceDefault cls tys warn)+ instance Binary IfaceClsInst where-    put_ bh (IfaceClsInst cls tys dfun flag orph) = do+    put_ bh (IfaceClsInst cls tys dfun flag orph warn) = do         put_ bh cls         put_ bh tys         put_ bh dfun         put_ bh flag         put_ bh orph+        put_ bh warn     get bh = do         cls  <- get bh         tys  <- get bh         dfun <- get bh         flag <- get bh         orph <- get bh-        return (IfaceClsInst cls tys dfun flag orph)+        warn <- get bh+        return (IfaceClsInst cls tys dfun flag orph warn)  instance Binary IfaceFamInst where     put_ bh (IfaceFamInst fam tys name orph) = do@@ -2254,6 +2651,27 @@         a8 <- get bh         return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) +instance Binary IfaceWarnings where+    put_ bh = \case+        IfWarnAll txt  -> putByte bh 0 *> put_ bh txt+        IfWarnSome vs ds -> putByte bh 1 *> put_ bh vs *> put_ bh ds+    get bh = getByte bh >>= \case+        0 -> pure IfWarnAll    <*> get bh+        1 -> pure IfWarnSome   <*> get bh <*> get bh+        _ -> fail "invalid tag(IfaceWarnings)"++instance Binary IfaceWarningTxt where+    put_ bh = \case+        IfWarningTxt a1 a2 a3 -> putByte bh 0 *> put_ bh a1 *> put_ bh a2 *> put_ bh a3+        IfDeprecatedTxt a1 a2 -> putByte bh 1 *> put_ bh a1 *> put_ bh a2+    get bh = getByte bh >>= \case+        0 -> pure IfWarningTxt    <*> get bh <*> get bh <*> get bh+        _ -> pure IfDeprecatedTxt <*> get bh <*> get bh++instance Binary IfaceStringLiteral where+    put_ bh (IfStringLiteral a1 a2) = put_ bh a1 *> put_ bh a2+    get bh = IfStringLiteral <$> get bh <*> get bh+ instance Binary IfaceAnnotation where     put_ bh (IfaceAnnotation a1 a2) = do         put_ bh a1@@ -2264,16 +2682,25 @@         return (IfaceAnnotation a1 a2)  instance Binary IfaceIdDetails where-    put_ bh IfVanillaId      = putByte bh 0-    put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b+    put_ bh IfVanillaId           = putByte bh 0+    put_ bh (IfRecSelId a b c d)  = do { putByte bh 1+                                       ; put_ bh a+                                       ; put_ bh b+                                       ; put_ bh c+                                       ; put_ bh d }     put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds-    put_ bh IfDFunId         = putByte bh 3+    put_ bh IfDFunId              = putByte bh 3     get bh = do         h <- getByte bh         case h of             0 -> return IfVanillaId-            1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }-            2 -> do { dmds <- get bh; return (IfWorkerLikeId dmds) }+            1 -> do { a <- get bh+                    ; b <- get bh+                    ; c <- get bh+                    ; d <- get bh+                    ; return (IfRecSelId a b c d) }+            2 -> do { dmds <- get bh+                    ; return (IfWorkerLikeId dmds) }             _ -> return IfDFunId  instance Binary IfaceInfoItem where@@ -2339,13 +2766,13 @@                     c <- get bh                     return (IfWhen a b c) -putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()+putUnfoldingCache :: WriteBinHandle -> IfUnfoldingCache -> IO () putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike                                      , uf_is_work_free = wf, uf_expandable = exp }) = do     let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp     putByte bh b -getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache+getUnfoldingCache :: ReadBinHandle -> IO IfUnfoldingCache getUnfoldingCache bh = do     b <- getByte bh     let hnf     = testBit b 3@@ -2355,9 +2782,14 @@     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 .<<|.-(.<<|.) :: (Bits a) => a -> Bool -> a+(.<<|.) :: (Num a, Bits a) => a -> Bool -> a x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)+{-# INLINE (.<<|.) #-}  instance Binary IfaceAlt where     put_ bh (IfaceAlt a b c) = do@@ -2424,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@@ -2473,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@@ -2496,6 +2925,11 @@         put_ bh (srcSpanEndLine src)         put_ bh (srcSpanEndCol src)         put_ bh name+    put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do+        putByte bh 3+        put_ bh m+        put_ bh ix+        put_ bh fvs      get bh = do         h <- getByte bh@@ -2516,16 +2950,20 @@                         end = mkRealSrcLoc file el ec                     name <- get bh                     return (IfaceSource (mkRealSrcSpan start end) name)+            3 -> do m <- get bh+                    ix <- get bh+                    fvs <- get bh+                    return (IfaceBreakpoint (BreakpointId m ix) fvs)             _ -> panic ("get IfaceTickish " ++ show h)  instance Binary IfaceConAlt where-    put_ bh IfaceDefault      = putByte bh 0+    put_ bh IfaceDefaultAlt   = putByte bh 0     put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa     put_ bh (IfaceLitAlt ac)  = putByte bh 2 >> put_ bh ac     get bh = do         h <- getByte bh         case h of-            0 -> return IfaceDefault+            0 -> return IfaceDefaultAlt             1 -> liftM IfaceDataAlt $ get bh             _ -> liftM IfaceLitAlt  $ get bh @@ -2580,19 +3018,6 @@       1 -> IfRhs <$> get bh       _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) ---instance Binary IfaceJoinInfo where-    put_ bh IfaceNotJoinPoint = putByte bh 0-    put_ bh (IfaceJoinPoint ar) = do-        putByte bh 1-        put_ bh ar-    get bh = do-        h <- getByte bh-        case h of-            0 -> return IfaceNotJoinPoint-            _ -> liftM IfaceJoinPoint $ get bh- instance Binary IfaceTyConParent where     put_ bh IfNoParent = putByte bh 0     put_ bh (IfDataInstance ax pr ty) = do@@ -2624,48 +3049,63 @@ ************************************************************************ -} +instance NFData IfaceImport where+  rnf (IfaceImport a b) = rnf a `seq` rnf b++instance NFData ImpIfaceList where+  rnf ImpIfaceAll = ()+  rnf (ImpIfaceEverythingBut ns) = rnf ns+  rnf (ImpIfaceExplicit gre explicit) = rnf gre `seq` rnf explicit+ instance NFData IfaceDecl where   rnf = \case     IfaceId f1 f2 f3 f4 ->       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` 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+      IfVar f1    -> rnf f1+      IfAnd f1    -> rnf f1+      IfOr f1     -> rnf f1+      IfParens f1 -> rnf f1+ instance NFData IfaceAT where   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@@ -2680,44 +3120,46 @@  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` ()-    IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b-    IfRecSelId (Right decl) b -> rnf decl `seq` rnf b+    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 -> ()  instance NFData IfaceInfoItem where   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@@ -2725,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@@ -2746,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@@ -2765,35 +3207,50 @@     IfaceAbstractClosedSynFamilyTyCon -> ()     IfaceBuiltInSynFamTyCon -> () -instance NFData IfaceJoinInfo where-  rnf x = x `seq` ()- 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+    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-    IfaceDefault -> ()+    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) =+    rnf f1 `seq` rnf f2 `seq` rnf f3+ 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) =-    f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()+  rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) =+    rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 +instance NFData IfaceWarnings where+  rnf = \case+      IfWarnAll txt   -> rnf txt+      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++instance NFData IfaceStringLiteral where+  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
@@ -7,19 +7,14 @@ -}  -{-# LANGUAGE FlexibleInstances #-}-  -- FlexibleInstances for Binary (DefMethSpec IfaceType)-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}- module GHC.Iface.Type (-        IfExtName, IfLclName,+        IfExtName,+        IfLclName(..), mkIfLclName, ifLclNameFS,          IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),-        IfaceMCoercion(..),-        IfaceUnivCoProv(..),+        IfaceAxiomRule(..),IfaceMCoercion(..),         IfaceMult,         IfaceTyCon(..),         IfaceTyConInfo(..), mkIfaceTyConInfo,@@ -29,6 +24,7 @@         IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,         IfaceForAllSpecBndr,         IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..),+        ShowSub(..), ShowHowMuch(..), AltPpr(..),         mkIfaceForAllTvBndr,         mkIfaceTyConKind,         ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr,@@ -36,6 +32,8 @@         ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,         ifTyConBinderVar, ifTyConBinderName, +        -- Binary utilities+        putIfaceType, getIfaceType, ifaceTypeSharedByte,         -- Equality testing         isIfaceLiftedTypeKind, @@ -46,6 +44,7 @@         SuppressBndrSig(..),         UseBndrParens(..),         PrintExplicitKinds(..),+        PrintArityInvisibles(..),         pprIfaceType, pprParendIfaceType, pprPrecIfaceType,         pprIfaceContext, pprIfaceContextArr,         pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,@@ -58,6 +57,7 @@         isIfaceRhoType,          suppressIfaceInvisibles,+        visibleTypeVarOccurencies,         stripIfaceInvisVars,         stripInvisArgs, @@ -74,9 +74,10 @@                                  , tupleTyConName                                  , tupleDataConName                                  , manyDataConTyCon-                                 , liftedRepTyCon, liftedDataConTyCon )+                                 , liftedRepTyCon, liftedDataConTyCon+                                 , sumTyCon ) import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy, funTyFlagTyCon )-import GHC.Core.TyCo.Rep( CoSel )+import GHC.Core.TyCo.Rep( CoSel, UnivCoProvenance(..) ) import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom@@ -92,9 +93,16 @@ import GHC.Utils.Panic import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar ) -import Data.Maybe( isJust )+import Data.Maybe (isJust)+import Data.Proxy import qualified Data.Semigroup as Semi+import Data.Word (Word8)+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  {- ************************************************************************@@ -104,15 +112,26 @@ ************************************************************************ -} -type IfLclName = FastString     -- A local name in iface syntax+-- | A local name in iface syntax+newtype IfLclName = IfLclName+  { getIfLclName :: LexicalFastString+  } deriving (Eq, Ord, Show) +ifLclNameFS :: IfLclName -> FastString+ifLclNameFS = getLexicalFastString . getIfLclName++mkIfLclName :: FastString -> IfLclName+mkIfLclName = IfLclName . LexicalFastString+ type IfExtName = Name   -- An External or WiredIn Name can appear in Iface syntax                         -- (However Internal or System Names never should)  data IfaceBndr          -- Local (non-top-level) binders   = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr   | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr+  deriving (Eq, Ord) + type IfaceIdBndr  = (IfaceType, IfLclName, IfaceType) type IfaceTvBndr  = (IfLclName, IfaceKind) @@ -133,7 +152,7 @@ type IfaceLamBndr = (IfaceBndr, IfaceOneShot)  data IfaceOneShot    -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy"-  = IfaceNoOneShot   -- and Note [The oneShot function] in "GHC.Types.Id.Make"+  = IfaceNoOneShot   -- and Note [oneShot magic] in "GHC.Types.Id.Make"   | IfaceOneShot  instance Outputable IfaceOneShot where@@ -156,7 +175,7 @@ -- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' -- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" data IfaceType-  = IfaceFreeTyVar TyVar                -- See Note [Free tyvars in IfaceType]+  = IfaceFreeTyVar TyVar                -- See Note [Free TyVars and CoVars in IfaceType]   | IfaceTyVar     IfLclName            -- Type/coercion variable only, not tycon   | IfaceLitTy     IfaceTyLit   | IfaceAppTy     IfaceType IfaceAppArgs@@ -180,7 +199,36 @@           -- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression           -- in interface file size (in GHC's boot libraries).           -- See !3987.+  deriving (Eq, Ord)+  -- See Note [Ord instance of IfaceType] +{-+Note [Ord instance of IfaceType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need an 'Ord' instance to have a 'Map' keyed by 'IfaceType'. This 'Map' is+required for implementing the deduplication table during interface file+serialisation.+See Note [Deduplication during iface binary serialisation] for the implementation details.++We experimented with a 'TrieMap' based implementation, but it seems to be+slower than using a straight-forward 'Map IfaceType'.+The experiments loaded the full agda library into a ghci session with the+following scenarios:++* normal: a plain ghci session.+* cold: a ghci session that uses '-fwrite-if-simplified-core -fforce-recomp',+  forcing a cold-cache.+* warm: a subsequent ghci session that uses a warm cache for+  '-fwrite-if-simplified-core', e.g. nothing needs to be recompiled.++The implementation was up to 5% slower in some execution runs. However, on+'lib:Cabal', the performance difference between 'Map IfaceType' and+'TrieMap IfaceType' was negligible.++We share our implementation of the 'TrieMap' in the ticket #24816, so that+further performance analysis and improvements don't need to start from scratch.+-}+ type IfaceMult = IfaceType  type IfacePredType = IfaceType@@ -188,9 +236,9 @@  data IfaceTyLit   = IfaceNumTyLit Integer-  | IfaceStrTyLit FastString+  | IfaceStrTyLit LexicalFastString   | IfaceCharTyLit Char-  deriving (Eq)+  deriving (Eq, Ord)  type IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis type IfaceForAllBndr     = VarBndr IfaceBndr ForAllTyFlag@@ -206,7 +254,7 @@ mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs   where     mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind-    mk (Bndr tv (AnonTCB af))   k = IfaceFunTy af many_ty (ifaceBndrType tv) k+    mk (Bndr tv AnonTCB)        k = IfaceFunTy FTF_T_T many_ty (ifaceBndrType tv) k     mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k  ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr]@@ -232,6 +280,7 @@                         --    arguments in @{...}.             IfaceAppArgs -- The rest of the arguments+  deriving (Eq, Ord)  instance Semi.Semigroup IfaceAppArgs where   IA_Nil <> xs              = xs@@ -246,8 +295,19 @@ -- We have to tag them in order to pretty print them -- properly. data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName-                             , ifaceTyConInfo :: IfaceTyConInfo }-    deriving (Eq)+                             , ifaceTyConInfo :: !IfaceTyConInfo+                             -- ^ We add a bang to this field as heap analysis+                             -- showed that this constructor retains a thunk to+                             -- a value that is usually shared.+                             --+                             -- See !12200 for how this bang saved ~10% residency+                             -- when loading 'mi_extra_decls' on the agda+                             -- code base.+                             --+                             -- See Note [Sharing IfaceTyConInfo] for why+                             -- sharing is so important for 'IfaceTyConInfo'.+                             }+    deriving (Eq, Ord)  -- | The various types of TyCons which have special, built-in syntax. data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon@@ -267,7 +327,7 @@                       -- that is actually being applied to two types                       -- of the same kind.  This affects pretty-printing                       -- only: see Note [Equality predicates in IfaceType]-                    deriving (Eq)+                    deriving (Eq, Ord)  instance Outputable IfaceTyConSort where   ppr IfaceNormalTyCon         = text "normal"@@ -275,7 +335,7 @@   ppr (IfaceSumTyCon n)        = text "sum:" <> ppr n   ppr IfaceEqualityTyCon       = text "equality" -{- Note [Free tyvars in IfaceType]+{- Note [Free TyVars and CoVars in IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an IfaceType and pretty printing that.  This eliminates a lot of@@ -361,18 +421,57 @@                       -- should be printed as 'D to distinguish it from                       -- an existing type constructor D.                    , ifaceTyConSort       :: IfaceTyConSort }-    deriving (Eq)+    deriving (Eq, Ord) --- This smart constructor allows sharing of the two most common--- cases. See #19194+-- | This smart constructor allows sharing of the two most common+-- cases. See Note [Sharing IfaceTyConInfo] mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo-mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = IfaceTyConInfo IsPromoted  IfaceNormalTyCon-mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon-mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom        sort+mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = promotedNormalTyConInfo+mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo+mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom sort +{-# NOINLINE promotedNormalTyConInfo #-}+-- | See Note [Sharing IfaceTyConInfo]+promotedNormalTyConInfo :: IfaceTyConInfo+promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon++{-# NOINLINE notPromotedNormalTyConInfo #-}+-- | See Note [Sharing IfaceTyConInfo]+notPromotedNormalTyConInfo :: IfaceTyConInfo+notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon++{-+Note [Sharing IfaceTyConInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example.+But almost all of them are++   IfaceTyConInfo IsPromoted IfaceNormalTyCon+   IfaceTyConInfo NotPromoted IfaceNormalTyCon.++The smart constructor `mkIfaceTyConInfo` arranges to share these instances,+thus:++  promotedNormalTyConInfo    = IfaceTyConInfo IsPromoted  IfaceNormalTyCon+  notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon++  mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = promotedNormalTyConInfo+  mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo+  mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom sort++But ALAS, the (nested) CPR transform can lose this sharing, completely+negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326.++Sticking-plaster solution: add a NOINLINE pragma to those top-level constants.+When we fix the CPR bug we can remove the NOINLINE pragmas.++This one change leads to an 15% reduction in residency for GHC when embedding+'mi_extra_decls': see !12222.+-}+ data IfaceMCoercion   = IfaceMRefl-  | IfaceMCo IfaceCoercion+  | IfaceMCo IfaceCoercion deriving (Eq, Ord)  data IfaceCoercion   = IfaceReflCo       IfaceType@@ -380,14 +479,13 @@   | IfaceFunCo        Role IfaceCoercion IfaceCoercion IfaceCoercion   | IfaceTyConAppCo   Role IfaceTyCon [IfaceCoercion]   | IfaceAppCo        IfaceCoercion IfaceCoercion-  | IfaceForAllCo     IfaceBndr IfaceCoercion IfaceCoercion+  | IfaceForAllCo     IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceCoercion IfaceCoercion   | IfaceCoVarCo      IfLclName-  | IfaceAxiomInstCo  IfExtName BranchIndex [IfaceCoercion]-  | IfaceAxiomRuleCo  IfLclName [IfaceCoercion]-       -- There are only a fixed number of CoAxiomRules, so it suffices+  | IfaceAxiomCo      IfaceAxiomRule [IfaceCoercion]+       -- ^ There are only a fixed number of CoAxiomRules, so it suffices        -- to use an IfaceLclName to distinguish them.        -- See Note [Adding built-in type families] in GHC.Builtin.Types.Literals-  | IfaceUnivCo       IfaceUnivCoProv Role IfaceType IfaceType+  | IfaceUnivCo       UnivCoProvenance Role IfaceType IfaceType [IfaceCoercion]   | IfaceSymCo        IfaceCoercion   | IfaceTransCo      IfaceCoercion IfaceCoercion   | IfaceSelCo        CoSel IfaceCoercion@@ -395,14 +493,16 @@   | IfaceInstCo       IfaceCoercion IfaceCoercion   | IfaceKindCo       IfaceCoercion   | IfaceSubCo        IfaceCoercion-  | IfaceFreeCoVar    CoVar    -- See Note [Free tyvars in IfaceType]+  | IfaceFreeCoVar    CoVar    -- ^ See Note [Free TyVars and CoVars in IfaceType]   | IfaceHoleCo       CoVar    -- ^ See Note [Holes in IfaceCoercion]+  deriving (Eq, Ord)+  -- Why Ord?  See Note [Ord instance of IfaceType] -data IfaceUnivCoProv-  = IfacePhantomProv IfaceCoercion-  | IfaceProofIrrelProv IfaceCoercion-  | IfacePluginProv String-  | IfaceCorePrepProv Bool  -- See defn of CorePrepProv+data IfaceAxiomRule+  = IfaceAR_X IfLclName               -- Built-in+  | IfaceAR_B IfExtName BranchIndex   -- Branched+  | IfaceAR_U IfExtName               -- Unbranched+  deriving (Eq, Ord)  {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -514,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@@ -524,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@@ -564,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@@ -574,11 +747,11 @@  mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst -- See Note [Substitution on IfaceType]-mkIfaceTySubst eq_spec = mkFsEnv eq_spec+mkIfaceTySubst eq_spec = mkFsEnv (map (first ifLclNameFS) eq_spec)  inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool -- See Note [Substitution on IfaceType]-inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)+inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (ifLclNameFS fs))  substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType -- See Note [Substitution on IfaceType]@@ -608,8 +781,7 @@     go_co (IfaceFreeCoVar cv)        = IfaceFreeCoVar cv     go_co (IfaceCoVarCo cv)          = IfaceCoVarCo cv     go_co (IfaceHoleCo cv)           = IfaceHoleCo cv-    go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)-    go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)+    go_co (IfaceUnivCo p r t1 t2 ds) = IfaceUnivCo p r (go t1) (go t2) (go_cos ds)     go_co (IfaceSymCo co)            = IfaceSymCo (go_co co)     go_co (IfaceTransCo co1 co2)     = IfaceTransCo (go_co co1) (go_co co2)     go_co (IfaceSelCo n co)          = IfaceSelCo n (go_co co)@@ -617,15 +789,10 @@     go_co (IfaceInstCo c1 c2)        = IfaceInstCo (go_co c1) (go_co c2)     go_co (IfaceKindCo co)           = IfaceKindCo (go_co co)     go_co (IfaceSubCo co)            = IfaceSubCo (go_co co)-    go_co (IfaceAxiomRuleCo n cos)   = IfaceAxiomRuleCo n (go_cos cos)+    go_co (IfaceAxiomCo n cos)       = IfaceAxiomCo n (go_cos cos)      go_cos = map go_co -    go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)-    go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)-    go_prov co@(IfacePluginProv _)   = co-    go_prov co@(IfaceCorePrepProv _) = co- substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args   = go args@@ -635,7 +802,7 @@  substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType substIfaceTyVar env tv-  | Just ty <- lookupFsEnv env tv = ty+  | Just ty <- lookupFsEnv env (ifLclNameFS tv) = ty   | otherwise                     = IfaceTyVar tv  @@ -681,6 +848,12 @@       | isVisibleForAllTyFlag argf = go (n+1) rest       | otherwise             = go n rest +ifaceAppArgsLength :: IfaceAppArgs -> Int+ifaceAppArgsLength = go 0+  where+    go !n IA_Nil = n+    go !n (IA_Arg _ _ ts) = go (n + 1) ts+ {- Note [Suppressing invisible arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -820,7 +993,7 @@ pprIfaceLamBndr (b, IfaceOneShot)   = ppr b <> text "[OneShot]"  pprIfaceIdBndr :: IfaceIdBndr -> SDoc-pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr w) <+> dcolon <+> ppr ty)+pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr_ty_nested w) <+> dcolon <+> ppr_ty_nested ty)  {- Note [Suppressing binder signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -848,7 +1021,7 @@ Normally, we pretty-print    `TYPE       'LiftedRep` as `Type` (or `*`)    `CONSTRAINT 'LiftedRep` as `Constraint`-   `FUN 'Many`             as `(->)`.+   `FUN 'Many`             as `(->)` This way, error messages don't refer to representation polymorphism or linearity if it is not necessary.  Normally we'd would represent these types using their synonyms (see GHC.Core.Type@@ -880,7 +1053,7 @@ pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens)   | suppress_sig             = ppr tv   | isIfaceLiftedTypeKind ki = ppr tv-  | otherwise                = maybe_parens (ppr tv <+> dcolon <+> ppr ki)+  | otherwise                = maybe_parens (ppr tv <+> dcolon <+> ppr_ty_nested ki)   where     maybe_parens | use_parens = parens                  | otherwise  = id@@ -893,12 +1066,7 @@     go (Bndr (IfaceTvBndr bndr) vis) =       -- See Note [Pretty-printing invisible arguments]       case vis of-        AnonTCB  af-          | isVisibleFunArg af -> ppr_bndr (UseBndrParens True)-          | otherwise          -> char '@' <> braces (ppr_bndr (UseBndrParens False))-          -- The above case is rare. (See Note [AnonTCB with constraint arg]-          --   in GHC.Core.TyCon.)-          -- Should we print these differently?+        AnonTCB            -> ppr_bndr (UseBndrParens True)         NamedTCB Required  -> ppr_bndr (UseBndrParens True)         NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True)         NamedTCB Inferred  -> char '@' <> braces (ppr_bndr (UseBndrParens False))@@ -937,9 +1105,13 @@ instance Outputable IfaceType where   ppr ty = pprIfaceType ty -pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc+-- The purpose of 'ppr_ty_nested' is to distinguish calls that should not+-- trigger 'hideNonStandardTypes', see Note [Defaulting RuntimeRep variables]+-- wrinkle (W2).+pprIfaceType, pprParendIfaceType, ppr_ty_nested :: IfaceType -> SDoc pprIfaceType       = pprPrecIfaceType topPrec pprParendIfaceType = pprPrecIfaceType appPrec+ppr_ty_nested = ppr_ty topPrec  pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc -- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be@@ -972,9 +1144,9 @@   | not (isIfaceRhoType ty)             = ppr_sigma ShowForAllMust ctxt_prec ty ppr_ty _         (IfaceForAllTy {})     = panic "ppr_ty"  -- Covered by not.isIfaceRhoType ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reason for IfaceFreeTyVar!-ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [Free tyvars in IfaceType]+ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [Free TyVars and CoVars in IfaceType] ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys-ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated+ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n          -- Function types@@ -991,7 +1163,7 @@       | isVisibleFunArg af       = (pprTypeArrow af wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2     ppr_fun_tail wthis other_ty-      = [pprTypeArrow af wthis <+> pprIfaceType other_ty]+      = [pprTypeArrow af wthis <+> ppr_ty_nested other_ty]  ppr_ty ctxt_prec (IfaceAppTy t ts)   = if_print_coercions@@ -1048,9 +1220,11 @@ syntactic overhead.  For this reason it was decided that we would hide RuntimeRep variables-for now (see #11549). We do this by defaulting all type variables of-kind RuntimeRep to LiftedRep.-Likewise, we default all Multiplicity variables to Many.+for now (see #11549). We do this right in the pretty-printer, by pre-processing+the type we are about to print, to default any type variables of kind RuntimeRep+that are bound by toplevel invisible quantification to LiftedRep.+Likewise, we default Multiplicity variables to Many and Levity variables to+Lifted.  This is done in a pass right before pretty-printing (defaultIfaceTyVarsOfKind, controlled by@@ -1077,6 +1251,32 @@ There's one exception though: TyVarTv metavariables should not be defaulted, as they appear during kind-checking of "newtype T :: TYPE r where..." (test T18357a). Therefore, we additionally test for isTyConableTyVar.++Wrinkles:++(W1) The loop 'go' in 'defaultIfaceTyVarsOfKind' passes a Bool flag, 'rank1',+     around that indicates whether we haven't yet descended into the arguments+     of a function type.+     This is used to decide whether newly bound variables are eligible for+     defaulting – we do not want contravariant foralls to be defaulted because+     that would result in an incorrect, rather than specialized, type.+     For example:+       ∀ p (r1 :: RuntimeRep) . (∀ (r2 :: RuntimeRep) . p r2) -> p r1+     We want to default 'r1', but not 'r2'.+     When examining the first forall, 'rank1' is True.+     The toplevel function type is matched as IfaceFunTy, where we recurse into+     'go' by passing False for 'rank1'.+     The forall in the first argument then skips adding a substitution for 'r2'.++(W2) 'defaultIfaceTyVarsOfKind' ought to be called only once when printing a+     type.+     A few components of the printing machinery used to invoke 'ppr' on types+     nested in secondary structures like IfaceBndr, which would repeat the+     defaulting process, but treating the type as if it were top-level, causing+     unwanted defaulting.+     In order to prevent future developers from using 'ppr' again or being+     confused that @ppr_ty topPrec@ is used, we introduced a marker function,+     'ppr_ty_nested'. -}  -- | Default 'RuntimeRep' variables to 'LiftedRep',@@ -1101,28 +1301,29 @@ defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables?                          -> Bool -- ^ default 'Multiplicity' variables?                          -> IfaceType -> IfaceType-defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty+defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty   where     go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables+       -> Bool -- Are we in a toplevel forall, where defaulting is allowed?        -> IfaceType        -> IfaceType-    go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)+    go subs True (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)      | isInvisibleForAllTyFlag argf  -- Don't default *visible* quantification-                                -- or we get the mess in #13963+                                     -- or we get the mess in #13963      , Just substituted_ty <- check_substitution var_kind-      = let subs' = extendFsEnv subs var substituted_ty+      = let subs' = extendFsEnv subs (ifLclNameFS var) substituted_ty             -- Record that we should replace it with LiftedRep/Lifted/Many,             -- and recurse, discarding the forall-        in go subs' ty+        in go subs' True ty -    go subs (IfaceForAllTy bndr ty)-      = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty)+    go subs rank1 (IfaceForAllTy bndr ty)+      = IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty) -    go subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of+    go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of       Just s -> s       Nothing -> ty -    go _ ty@(IfaceFreeTyVar tv)+    go _ _ ty@(IfaceFreeTyVar tv)       -- See Note [Defaulting RuntimeRep variables], about free vars       | def_rep       , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)@@ -1142,34 +1343,34 @@       | otherwise       = ty -    go subs (IfaceTyConApp tc tc_args)+    go subs _ (IfaceTyConApp tc tc_args)       = IfaceTyConApp tc (go_args subs tc_args) -    go subs (IfaceTupleTy sort is_prom tc_args)+    go subs _ (IfaceTupleTy sort is_prom tc_args)       = IfaceTupleTy sort is_prom (go_args subs tc_args) -    go subs (IfaceFunTy af w arg res)-      = IfaceFunTy af (go subs w) (go subs arg) (go subs res)+    go subs rank1 (IfaceFunTy af w arg res)+      = IfaceFunTy af (go subs False w) (go subs False arg) (go subs rank1 res) -    go subs (IfaceAppTy t ts)-      = IfaceAppTy (go subs t) (go_args subs ts)+    go subs _ (IfaceAppTy t ts)+      = IfaceAppTy (go subs False t) (go_args subs ts) -    go subs (IfaceCastTy x co)-      = IfaceCastTy (go subs x) co+    go subs rank1 (IfaceCastTy x co)+      = IfaceCastTy (go subs rank1 x) co -    go _ ty@(IfaceLitTy {}) = ty-    go _ ty@(IfaceCoercionTy {}) = ty+    go _ _ ty@(IfaceLitTy {}) = ty+    go _ _ ty@(IfaceCoercionTy {}) = ty      go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr     go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf)-      = Bndr (IfaceIdBndr (w, n, go subs t)) argf+      = Bndr (IfaceIdBndr (w, n, go subs False t)) argf     go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)-      = Bndr (IfaceTvBndr (n, go subs t)) argf+      = Bndr (IfaceTvBndr (n, go subs False t)) argf      go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs     go_args _ IA_Nil = IA_Nil     go_args subs (IA_Arg ty argf args)-      = IA_Arg (go subs ty) argf (go_args subs args)+      = IA_Arg (go subs False ty) argf (go_args subs args)      check_substitution :: IfaceType -> Maybe IfaceType     check_substitution (IfaceTyConApp tc _)@@ -1240,7 +1441,7 @@        Specified |  print_kinds                  -> char '@' <> ppr_ty appPrec t        Inferred  |  print_kinds-                 -> char '@' <> braces (ppr_ty topPrec t)+                 -> char '@' <> braces (ppr_ty_nested t)        _         -> empty  -------------------@@ -1253,7 +1454,8 @@ pprIfaceForAllPartMust tvs ctxt sdoc   = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc+pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)]+                     -> SDoc -> SDoc pprIfaceForAllCoPart tvs sdoc   = sep [ pprIfaceForAllCo tvs, sdoc ] @@ -1292,11 +1494,11 @@   | otherwise              = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc+pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCo []  = empty pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc+pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs  pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc@@ -1311,9 +1513,15 @@     -- See Note [Suppressing binder signatures]     suppress_sig = SuppressBndrSig False -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc-pprIfaceForAllCoBndr (tv, kind_co)-  = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)+pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc+pprIfaceForAllCoBndr (tv, kind_co, visL, visR)+  = parens (ppr tv <> pp_vis <+> dcolon <+> pprIfaceCoercion kind_co)+  where+    pp_vis | visL == coreTyLamForAllTyFlag+           , visR == coreTyLamForAllTyFlag+           = empty+           | otherwise+           = ppr visL <> char '~' <> ppr visR    -- "[spec]~[reqd]"  -- | Show forall flag --@@ -1322,6 +1530,29 @@ -- or when compiling with -fprint-explicit-foralls. data ShowForAllFlag = ShowForAllMust | ShowForAllWhen +data ShowSub+  = ShowSub+      { ss_how_much :: ShowHowMuch+      , ss_forall :: ShowForAllFlag }++-- See Note [Printing IfaceDecl binders]+-- The alternative pretty printer referred to in the note.+newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))++data ShowHowMuch+  = ShowHeader AltPpr -- ^ Header information only, not rhs+  | ShowSome (Maybe (OccName -> Bool)) AltPpr+  -- ^ Show the declaration and its RHS. The @Maybe@ predicate+  -- allows filtering of the sub-components which should be printing;+  -- any sub-components filtered out will be elided with @...@.+  | ShowIface+  -- ^ Everything including GHC-internal information (used in --show-iface)++instance Outputable ShowHowMuch where+  ppr (ShowHeader _) = text "ShowHeader"+  ppr ShowIface      = text "ShowIface"+  ppr (ShowSome _ _) = text "ShowSome"+ pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty   = hideNonStandardTypes (ppr_sigma show_forall topPrec) ty@@ -1345,7 +1576,7 @@           -- Then it could handle both invisible and required binders, and           -- splitIfaceReqForallTy wouldn't be necessary here.     in ppr_iface_forall_part show_forall invis_tvs theta $-       sep [pprIfaceForAll req_tvs, ppr tau']+       sep [pprIfaceForAll req_tvs, ppr_ty_nested tau']  pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs@@ -1516,19 +1747,19 @@        , IA_Arg (IfaceLitTy (IfaceStrTyLit n))                 Required (IA_Arg ty Required IA_Nil) <- tys        -> maybeParen ctxt_prec funPrec-         $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty+         $ char '?' <> ftext (getLexicalFastString n) <> dcolon <> ppr_ty topPrec ty         | IfaceTupleTyCon arity sort <- ifaceTyConSort info        , not debug        , arity == ifaceVisAppArgsLength tys-       -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys-           -- NB: pprTuple requires a saturated tuple.+       -> ppr_tuple ctxt_prec sort (ifaceTyConIsPromoted info) tys+           -- NB: ppr_tuple requires a saturated tuple.         | IfaceSumTyCon arity <- ifaceTyConSort info        , not debug        , arity == ifaceVisAppArgsLength tys-       -> pprSum (ifaceTyConIsPromoted info) tys-           -- NB: pprSum requires a saturated unboxed sum.+       -> ppr_sum ctxt_prec (ifaceTyConIsPromoted info) tys+           -- NB: ppr_sum requires a saturated unboxed sum.         | tc `ifaceTyConHasKey` consDataConKey        , False <- print_kinds@@ -1685,81 +1916,116 @@      | tc `ifaceTyConHasKey` liftedTypeKindTyConKey      -> ppr_kind_type ctxt_prec -     | not (isSymOcc (nameOccName (ifaceTyConName tc)))-     -> pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)+     | isSymOcc (nameOccName (ifaceTyConName tc)) -     | [ ty1@(_, Required), ty2@(_, Required) ] <- tys+     , [ ty1@(_, Required), ty2@(_, Required) ] <- tys          -- Infix, two visible arguments (we know nothing of precedence though).          -- Don't apply this special case if one of the arguments is invisible,          -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941).-     -> pprIfaceInfixApp ctxt_prec (ppr tc) (pp opPrec ty1) (pp opPrec ty2)+     -> pprIfaceInfixApp ctxt_prec (pprIfaceTyCon tc) (pp opPrec ty1) (pp opPrec ty2)       | otherwise-     -> pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)+     -> pprIfacePrefixApp ctxt_prec (pprParendIfaceTyCon tc) (map (pp appPrec) tys) --- | Pretty-print an unboxed sum type. The sum should be saturated:--- as many visible arguments as the arity of the sum.------ NB: this always strips off the invisible 'RuntimeRep' arguments,--- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.-pprSum :: PromotionFlag -> IfaceAppArgs -> SDoc-pprSum is_promoted args-  =   -- drop the RuntimeRep vars.-      -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-    let tys   = appArgsIfaceTypes args-        args' = drop (length tys `div` 2) tys-    in pprPromotionQuoteI is_promoted-       <> sumParens (pprWithBars (ppr_ty topPrec) args')+data TupleOrSum = IsSum | IsTuple TupleSort+  deriving (Eq) --- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple).--- The tuple should be saturated: as many visible arguments as the arity of--- the tuple.+-- | Pretty-print a boxed tuple datacon in regular tuple syntax.+-- Used when -XListTuplePuns is disabled.+ppr_tuple_no_pun :: PprPrec -> [IfaceType] -> SDoc+ppr_tuple_no_pun ctxt_prec = \case+  [t] -> maybeParen ctxt_prec appPrec (text "MkSolo" <+> pprPrecIfaceType appPrec t)+  tys -> tupleParens BoxedTuple (pprWithCommas pprIfaceType tys)++-- | Pretty-print an unboxed tuple or sum type in its parenthesized, punned, form.+-- Used when -XListTuplePuns is enabled. --+-- The tycon should be saturated:+-- as many visible arguments as the arity of the sum or tuple.+-- -- NB: this always strips off the invisible 'RuntimeRep' arguments, -- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.-pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc-pprTuple ctxt_prec sort promoted args =-  case promoted of-    IsPromoted-      -> let tys = appArgsIfaceTypes args-             args' = drop (length tys `div` 2) tys-         in ppr_tuple_app args' $-            pprPromotionQuoteI IsPromoted <>-            tupleParens sort (spaceIfSingleQuote (pprWithCommas pprIfaceType args'))+ppr_tuple_sum_pun :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceType -> Arity -> [IfaceType] -> SDoc+ppr_tuple_sum_pun ctxt_prec sort promoted tc arity tys+  | IsSum <- sort+  = sumParens (pprWithBars (ppr_ty topPrec) tys) -    NotPromoted-      |  ConstraintTuple <- sort-      ,  IA_Nil <- args-      -> maybeParen ctxt_prec sigPrec $-         text "() :: Constraint"+  |  IsTuple ConstraintTuple <- sort+  ,  NotPromoted <- promoted+  ,  arity == 0+  = maybeParen ctxt_prec sigPrec $+    text "() :: Constraint" -      | otherwise-      ->   -- drop the RuntimeRep vars.-           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-         let tys   = appArgsIfaceTypes args-             args' = case sort of-                       UnboxedTuple -> drop (length tys `div` 2) tys-                       _            -> tys-         in-         ppr_tuple_app args' $-         pprPromotionQuoteI promoted <>-         tupleParens sort (pprWithCommas pprIfaceType args')+  -- Special-case unary boxed tuples so that they are pretty-printed as+  -- `Solo x`, not `(x)`+  | IsTuple BoxedTuple <- sort+  , arity == 1+  = pprPrecIfaceType ctxt_prec tc++  | IsTuple tupleSort <- sort+  = pprPromotionQuoteI promoted <>+    tupleParens tupleSort (quote_space (pprWithCommas pprIfaceType tys))   where-    ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc-    ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens-        -- Special-case unary boxed tuples so that they are pretty-printed as-        -- `Solo x`, not `(x)`-      | [_] <- args_wo_runtime_reps-      , BoxedTuple <- sort-      = let solo_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon-            tupleName = case promoted of-              IsPromoted -> tupleDataConName (tupleSortBoxity sort)-              NotPromoted -> tupleTyConName sort-            solo_tc = IfaceTyCon (tupleName 1) solo_tc_info in-        pprPrecIfaceType ctxt_prec $ IfaceTyConApp solo_tc args+    quote_space = case promoted of+      IsPromoted -> spaceIfSingleQuote+      NotPromoted -> id++-- | Pretty-print an unboxed tuple or sum type either in the punned or unpunned form,+-- depending on whether -XListTuplePuns is enabled.+ppr_tuple_sum :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceAppArgs -> SDoc+ppr_tuple_sum ctxt_prec sort is_promoted args =+  sdocOption sdocListTuplePuns $ \case+    True -> ppr_tuple_sum_pun ctxt_prec sort is_promoted prefix_tc arity non_rep_tys+    False+      | IsPromoted <- is_promoted+      , IsTuple BoxedTuple <- sort+      -> ppr_tuple_no_pun ctxt_prec non_rep_tys       | otherwise-      = ppr_args_w_parens+      -> pprPrecIfaceType ctxt_prec prefix_tc+  where+    -- This tycon is used to print in prefix notation for the punned Solo+    -- case and the unabbreviated case.+    prefix_tc = IfaceTyConApp (IfaceTyCon (mk_name arity) info) args +    info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon++    mk_name = case (sort, is_promoted) of+      (IsTuple BoxedTuple, IsPromoted) -> tupleDataConName Boxed+      (IsTuple s, _) -> tupleTyConName s+      (IsSum, _) -> tyConName . sumTyCon++    -- drop the RuntimeRep vars.+    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+    non_rep_tys = if strip_reps then drop arity all_tys else all_tys++    arity = if strip_reps then count `div` 2 else count++    count = length all_tys++    all_tys = appArgsIfaceTypes args++    strip_reps = case is_promoted of+      IsPromoted -> True+      NotPromoted -> strip_reps_sort++    strip_reps_sort = case sort of+      IsTuple BoxedTuple -> False+      IsTuple UnboxedTuple -> True+      IsTuple ConstraintTuple -> False+      IsSum -> True++-- | Pretty-print an unboxed sum type.+-- The sum should be saturated: as many visible arguments as the arity of+-- the sum.+ppr_sum :: PprPrec -> PromotionFlag -> IfaceAppArgs -> SDoc+ppr_sum ctxt_prec = ppr_tuple_sum ctxt_prec IsSum++-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple).+-- The tuple should be saturated: as many visible arguments as the arity of+-- the tuple.+ppr_tuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc+ppr_tuple ctxt_prec sort = ppr_tuple_sum ctxt_prec (IsTuple sort)+ pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n)@@ -1798,36 +2064,35 @@     ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo {})   = maybeParen ctxt_prec funPrec $+    -- FIXME: collect and pretty-print visibility info?     pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)   where     (tvs, inner_co) = split_co co -    split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co')-      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')-    split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co')-      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')+    split_co (IfaceForAllCo (IfaceTvBndr (name, _)) visL visR kind_co co')+      = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')+    split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) visL visR kind_co co')+      = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')     split_co co' = ([], co') --- Why these three? See Note [Free tyvars in IfaceType]+-- Why these three? See Note [Free TyVars and CoVars in IfaceType] ppr_co _ (IfaceFreeCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar)   = ppr covar ppr_co _ (IfaceHoleCo covar)    = braces (ppr covar) -ppr_co _ (IfaceUnivCo prov role ty1 ty2)+ppr_co _ (IfaceUnivCo prov role ty1 ty2 ds)   = text "Univ" <> (parens $-      sep [ ppr role <+> pprIfaceUnivCoProv prov+      sep [ ppr role <+> ppr prov <> ppr ds           , dcolon <+>  ppr ty1 <> comma <+> ppr ty2 ])  ppr_co ctxt_prec (IfaceInstCo co ty)   = maybeParen ctxt_prec appPrec $-    text "Inst" <+> pprParendIfaceCoercion co-                        <+> pprParendIfaceCoercion ty--ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)-  = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)+    text "Inst" <+> sep [ pprParendIfaceCoercion co+                        , pprParendIfaceCoercion ty ] -ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)-  = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos+ppr_co ctxt_prec (IfaceAxiomCo ax cos)+  | null cos  = pprIfAxRule ax  -- Don't add parens+  | otherwise = ppr_special_co ctxt_prec (pprIfAxRule ax) cos ppr_co ctxt_prec (IfaceSymCo co)   = ppr_special_co ctxt_prec (text "Sym") [co] ppr_co ctxt_prec (IfaceTransCo co1 co2)@@ -1850,6 +2115,11 @@   = maybeParen ctxt_prec appPrec                (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) +pprIfAxRule :: IfaceAxiomRule -> SDoc+pprIfAxRule (IfaceAR_X n)   = ppr n+pprIfAxRule (IfaceAR_U n)   = ppr n+pprIfAxRule (IfaceAR_B n i) = ppr n <> brackets (int i)+ ppr_role :: Role -> SDoc ppr_role r = underscore <> pp_role   where pp_role = case r of@@ -1857,21 +2127,24 @@                     Representational -> char 'R'                     Phantom          -> char 'P' --------------------pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc-pprIfaceUnivCoProv (IfacePhantomProv co)-  = text "phantom" <+> pprParendIfaceCoercion co-pprIfaceUnivCoProv (IfaceProofIrrelProv co)-  = text "irrel" <+> pprParendIfaceCoercion co-pprIfaceUnivCoProv (IfacePluginProv s)-  = text "plugin" <+> doubleQuotes (text s)-pprIfaceUnivCoProv (IfaceCorePrepProv _)-  = text "CorePrep"- -------------------+instance Outputable IfLclName where+  ppr = ppr . ifLclNameFS+ instance Outputable IfaceTyCon where-  ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)+  ppr = pprIfaceTyCon +-- | Print an `IfaceTyCon` with a promotion tick if needed, without parens,+-- suitable for use in infix contexts+pprIfaceTyCon :: IfaceTyCon -> SDoc+pprIfaceTyCon tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)++-- | Print an `IfaceTyCon` with a promotion tick if needed, possibly with parens,+-- suitable for use in prefix contexts+pprParendIfaceTyCon :: IfaceTyCon -> SDoc+pprParendIfaceTyCon tc = pprPromotionQuote tc <> pprPrefixVar (isSymOcc (nameOccName tc_name)) (ppr tc_name)+  where tc_name = ifaceTyConName tc+ instance Outputable IfaceTyConInfo where   ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom                       , ifaceTyConSort       = sort })@@ -1899,11 +2172,12 @@   ppr = pprIfaceCoercion  instance Binary IfaceTyCon where-   put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i+  put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i -   get bh = do n <- get bh-               i <- get bh-               return (IfaceTyCon n i)+  get bh = do+    n <- get bh+    i <- get bh+    return (IfaceTyCon n i)  instance Binary IfaceTyConSort where    put_ bh IfaceNormalTyCon             = putByte bh 0@@ -1922,7 +2196,13 @@ instance Binary IfaceTyConInfo where    put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s -   get bh = mkIfaceTyConInfo <$> get bh <*> get bh+   get bh = mkIfaceTyConInfo <$!> get bh <*> get bh+    -- We want to make sure, when reading from disk, as the most common case+    -- is supposed to be shared. Any thunk adds an additional indirection+    -- making sharing less useful.+    --+    -- See !12200 for how this bang and the one in 'IfaceTyCon' reduces the+    -- residency by ~10% when loading 'mi_extra_decls' from disk.  instance Outputable IfaceTyLit where   ppr = pprIfaceTyLit@@ -1944,21 +2224,27 @@          _ -> panic ("get IfaceTyLit " ++ show tag)  instance Binary IfaceAppArgs where-  put_ bh tk =-    case tk of-      IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts-      IA_Nil        -> putByte bh 1+  put_ bh tk = do+    -- Int is variable length encoded so only+    -- one byte for small lists.+    put_ bh (ifaceAppArgsLength tk)+    go tk+    where+      go IA_Nil = pure ()+      go (IA_Arg a b t) = do+        put_ bh a+        put_ bh b+        go t -  get bh =-    do c <- getByte bh-       case c of-         0 -> do-           t  <- get bh-           a  <- get bh-           ts <- get bh-           return $! IA_Arg t a ts-         1 -> return IA_Nil-         _ -> panic ("get IfaceAppArgs " ++ show c)+  get bh = do+    n <- get bh :: IO Int+    go n+    where+      go 0 = return IA_Nil+      go c = do+        a <- get bh+        b <- get bh+        IA_Arg a b <$> go (c - 1)  ------------------- @@ -2013,38 +2299,80 @@ ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))  instance Binary IfaceType where-    put_ _ (IfaceFreeTyVar tv)-       = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)+   put_ bh ty =+    case findUserDataWriter Proxy bh of+      tbl -> putEntry tbl bh ty -    put_ bh (IfaceForAllTy aa ab) = do-            putByte bh 0-            put_ bh aa-            put_ bh ab-    put_ bh (IfaceTyVar ad) = do-            putByte bh 1-            put_ bh ad-    put_ bh (IfaceAppTy ae af) = do-            putByte bh 2-            put_ bh ae-            put_ bh af-    put_ bh (IfaceFunTy af aw ag ah) = do-            putByte bh 3-            put_ bh af-            put_ bh aw-            put_ bh ag-            put_ bh ah-    put_ bh (IfaceTyConApp tc tys)-      = do { putByte bh 5; put_ bh tc; put_ bh tys }-    put_ bh (IfaceCastTy a b)-      = do { putByte bh 6; put_ bh a; put_ bh b }-    put_ bh (IfaceCoercionTy a)-      = do { putByte bh 7; put_ bh a }-    put_ bh (IfaceTupleTy s i tys)-      = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }-    put_ bh (IfaceLitTy n)-      = do { putByte bh 9; put_ bh n }+   get bh = getIfaceTypeShared bh -    get bh = do+-- | This is the byte tag we expect to read when the next+-- value is not an 'IfaceType' value, but an offset into a+-- lookup table.+-- See Note [Deduplication during iface binary serialisation].+--+-- Must not overlap with any byte tag in 'getIfaceType'.+ifaceTypeSharedByte :: Word8+ifaceTypeSharedByte = 99++-- | Like 'getIfaceType' but checks for a specific byte tag+-- that indicates that we won't be able to read a 'IfaceType' value+-- but rather an offset into a lookup table. Consequentially,+-- we look up the value for the 'IfaceType' in the look up table.+--+-- See Note [Deduplication during iface binary serialisation]+-- for details.+getIfaceTypeShared :: ReadBinHandle -> IO IfaceType+getIfaceTypeShared bh = do+  start <- tellBinReader bh+  tag <- getByte bh+  if ifaceTypeSharedByte == tag+    then case findUserDataReader Proxy bh of+            tbl -> getEntry tbl bh+    else seekBinReader bh start >> getIfaceType bh++-- | Serialises an 'IfaceType' to the given 'WriteBinHandle'.+--+-- Serialising inner 'IfaceType''s uses the 'Binary.put' of 'IfaceType' which may be using+-- a deduplication table. See Note [Deduplication during iface binary serialisation].+putIfaceType :: WriteBinHandle -> IfaceType -> IO ()+putIfaceType _ (IfaceFreeTyVar tv)+  = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)+  -- See Note [Free TyVars and CoVars in IfaceType]++putIfaceType bh (IfaceForAllTy aa ab) = do+        putByte bh 0+        put_ bh aa+        put_ bh ab+putIfaceType bh (IfaceTyVar ad) = do+        putByte bh 1+        put_ bh ad+putIfaceType bh (IfaceAppTy ae af) = do+        putByte bh 2+        put_ bh ae+        put_ bh af+putIfaceType bh (IfaceFunTy af aw ag ah) = do+        putByte bh 3+        put_ bh af+        put_ bh aw+        put_ bh ag+        put_ bh ah+putIfaceType bh (IfaceTyConApp tc tys)+  = do { putByte bh 5; put_ bh tc; put_ bh tys }+putIfaceType bh (IfaceCastTy a b)+  = do { putByte bh 6; put_ bh a; put_ bh b }+putIfaceType bh (IfaceCoercionTy a)+  = do { putByte bh 7; put_ bh a }+putIfaceType bh (IfaceTupleTy s i tys)+  = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }+putIfaceType bh (IfaceLitTy n)+  = do { putByte bh 9; put_ bh n }++-- | Deserialises an 'IfaceType' from the given 'ReadBinHandle'.+--+-- Reading inner 'IfaceType''s uses the 'Binary.get' of 'IfaceType' which may be using+-- a deduplication table. See Note [Deduplication during iface binary serialisation].+getIfaceType :: HasCallStack => ReadBinHandle -> IO IfaceType+getIfaceType bh = do             h <- getByte bh             case h of               0 -> do aa <- get bh@@ -2072,6 +2400,13 @@               _  -> do n <- get bh                        return (IfaceLitTy n) +instance Binary IfLclName where+  put_ bh = put_ bh . ifLclNameFS++  get bh = do+    fs <- get bh+    pure $ IfLclName $ LexicalFastString fs+ instance Binary IfaceMCoercion where   put_ bh IfaceMRefl =           putByte bh 1@@ -2111,25 +2446,23 @@           putByte bh 5           put_ bh a           put_ bh b-  put_ bh (IfaceForAllCo a b c) = do+  put_ bh (IfaceForAllCo a visL visR b c) = do           putByte bh 6           put_ bh a+          put_ bh visL+          put_ bh visR           put_ bh b           put_ bh c   put_ bh (IfaceCoVarCo a) = do           putByte bh 7           put_ bh a-  put_ bh (IfaceAxiomInstCo a b c) = do-          putByte bh 8-          put_ bh a-          put_ bh b-          put_ bh c-  put_ bh (IfaceUnivCo a b c d) = do+  put_ bh (IfaceUnivCo a b c d deps) = do           putByte bh 9           put_ bh a           put_ bh b           put_ bh c           put_ bh d+          put_ bh deps   put_ bh (IfaceSymCo a) = do           putByte bh 10           put_ bh a@@ -2155,15 +2488,16 @@   put_ bh (IfaceSubCo a) = do           putByte bh 16           put_ bh a-  put_ bh (IfaceAxiomRuleCo a b) = do+  put_ bh (IfaceAxiomCo a b) = do           putByte bh 17           put_ bh a           put_ bh b   put_ _ (IfaceFreeCoVar cv)        = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)+           -- See Note [Free TyVars and CoVars in IfaceType]   put_ _  (IfaceHoleCo cv)        = pprPanic "Can't serialise IfaceHoleCo" (ppr cv)-          -- See Note [Holes in IfaceCoercion]+           -- See Note [Holes in IfaceCoercion]    get bh = do       tag <- getByte bh@@ -2187,20 +2521,19 @@                    b <- get bh                    return $ IfaceAppCo a b            6 -> do a <- get bh+                   visL <- get bh+                   visR <- get bh                    b <- get bh                    c <- get bh-                   return $ IfaceForAllCo a b c+                   return $ IfaceForAllCo a visL visR b c            7 -> do a <- get bh                    return $ IfaceCoVarCo a-           8 -> do a <- get bh-                   b <- get bh-                   c <- get bh-                   return $ IfaceAxiomInstCo a b c            9 -> do a <- get bh                    b <- get bh                    c <- get bh                    d <- get bh-                   return $ IfaceUnivCo a b c d+                   deps <- get bh+                   return $ IfaceUnivCo a b c d deps            10-> do a <- get bh                    return $ IfaceSymCo a            11-> do a <- get bh@@ -2221,36 +2554,19 @@                    return $ IfaceSubCo a            17-> do a <- get bh                    b <- get bh-                   return $ IfaceAxiomRuleCo a b+                   return $ IfaceAxiomCo a b            _ -> panic ("get IfaceCoercion " ++ show tag) -instance Binary IfaceUnivCoProv where-  put_ bh (IfacePhantomProv a) = do-          putByte bh 1-          put_ bh a-  put_ bh (IfaceProofIrrelProv a) = do-          putByte bh 2-          put_ bh a-  put_ bh (IfacePluginProv a) = do-          putByte bh 3-          put_ bh a-  put_ bh (IfaceCorePrepProv a) = do-          putByte bh 4-          put_ bh a--  get bh = do-      tag <- getByte bh-      case tag of-           1 -> do a <- get bh-                   return $ IfacePhantomProv a-           2 -> do a <- get bh-                   return $ IfaceProofIrrelProv a-           3 -> do a <- get bh-                   return $ IfacePluginProv a-           4 -> do a <- get bh-                   return (IfaceCorePrepProv a)-           _ -> panic ("get IfaceUnivCoProv " ++ show tag)+instance Binary IfaceAxiomRule where+  put_ bh (IfaceAR_X n)   = putByte bh 0 >> put_ bh n+  put_ bh (IfaceAR_U n)   = putByte bh 1 >> put_ bh n+  put_ bh (IfaceAR_B n i) = putByte bh 2 >> put_ bh n >> put_ bh i +  get bh = do h <- getByte bh+              case h of+                0 -> do { n <- get bh; return (IfaceAR_X n) }+                1 -> do { n <- get bh; return (IfaceAR_U n) }+                _ -> do { n <- get bh; i <- get bh; return (IfaceAR_B n i) }  instance Binary (DefMethSpec IfaceType) where     put_ bh VanillaDM     = putByte bh 0@@ -2261,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@@ -2283,43 +2604,54 @@ 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 -> rnf f1 `seq` rnf f2 `seq` rnf f3+    IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5     IfaceCoVarCo f1 -> rnf f1-    IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3-    IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2-    IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4+    IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2+    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` () -instance NFData IfaceUnivCoProv where-  rnf x = seq x ()+instance NFData IfaceAxiomRule where+  rnf = \case+    IfaceAR_X n   -> rnf n+    IfaceAR_U n   -> rnf n+    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 -> () +instance NFData IfLclName where+  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@@ -2332,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/Iface/Type.hs-boot view
@@ -1,11 +1,12 @@ module GHC.Iface.Type    ( IfaceType, IfaceTyCon, IfaceBndr    , IfaceCoercion, IfaceTyLit, IfaceAppArgs+   , ShowSub    ) where  -- Empty import to influence the compilation ordering.--- See Note [Depend on GHC.Num.Integer] in GHC.Base+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base import GHC.Base ()  data IfaceAppArgs@@ -15,3 +16,4 @@ data IfaceTyLit data IfaceCoercion data IfaceBndr+data ShowSub
+ compiler/GHC/JS/Ident.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DerivingStrategies          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.Ident+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.Ident defines identifiers for the JS backend. We keep this module+--     separate to prevent coupling between GHC and the backend and between+--     unrelated modules is the JS backend.+--+-- * Consumers+--+--     The entire JavaScript Backend consumes this module including modules in+--     GHC.JS.\* and modules in GHC.StgToJS.\*+--+-- * Additional Notes+--+--     This module should be kept as small as possible. Anything added to it+--     will be coupled to the JS backend EDSL and the JS Backend including the+--     linker and rts. You have been warned.+--+-----------------------------------------------------------------------------++module GHC.JS.Ident+  ( Ident(..)+  , name+  ) where++import GHC.Prelude++import GHC.Data.FastString+import GHC.Types.Unique+import GHC.Utils.Outputable++--------------------------------------------------------------------------------+--                            Identifiers+--------------------------------------------------------------------------------++-- | A newtype wrapper around 'FastString' for JS identifiers.+newtype Ident = TxtI { identFS :: FastString }+ deriving stock   (Show, Eq)+ deriving newtype (Uniquable, Outputable)++-- | To give a thing a name is to have power over it. This smart constructor+-- serves two purposes: first, it isolates the JS backend from the rest of GHC.+-- The backend should not explicitly use types provided by GHC but instead+-- should wrap them such as we do here. Second it creates a symbol in the JS+-- backend, but it does not yet give that symbols meaning. Giving the symbol+-- meaning only occurs once it is used with a combinator from @GHC.JS.Make@.+name :: FastString -> Ident+name = TxtI
+ compiler/GHC/JS/JStg/Monad.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE OverloadedStrings          #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.JStg.Monad+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.JStg.Monad defines the computational environment for the eDSL that+--     we use to write the JS Backend's RTS. Its purpose is to ensure unique+--     identifiers are generated throughout the backend and that we can use the+--     host language to ensure references are not mixed.+--+-- * Strategy+--+--     The monad is a straightforward state monad which holds an environment+--     holds a pointer to a prefix to tag identifiers with and an infinite+--     stream of identifiers.+--+-- * Usage+--+--     One should almost never need to directly use the functions in this+--     module. Instead one should opt to use the combinators in 'GHC.JS.Make',+--     the sole exception to this is the @withTag@ function which is used to+--     change the prefix of identifiers for a given computation. For example,+--     the rts uses this function to tag all identifiers generated by the RTS+--     code as RTS_N, where N is some unique.+-----------------------------------------------------------------------------+module GHC.JS.JStg.Monad+  ( runJSM+  , JSM+  , withTag+  , newIdent+  , initJSM+  ) where++import Prelude++import GHC.JS.Ident++import GHC.Types.Unique+import GHC.Types.Unique.Supply+import Control.Monad.Trans.State.Strict+import GHC.Data.FastString++--------------------------------------------------------------------------------+--                            JSM Monad+--------------------------------------------------------------------------------++-- | Environment for the JSM Monad. We maintain the prefix of each ident in the+-- environment to allow consumers to tag idents with a new prefix. See @withTag@+data JEnv = JEnv { prefix :: !FastString -- ^ prefix for generated names, e.g.,+                                         -- prefix = "RTS" will generate names+                                         -- such as 'h$RTS_jUt'+                 , ids    :: UniqSupply  -- ^ The supply of uniques for names+                                         -- generated by the JSM monad.+                 }++type JSM a = State JEnv a++runJSM :: JEnv -> JSM a -> a+runJSM env m = evalState m env++-- | create a new environment using the input tag.+initJSMState :: FastString -> UniqSupply -> JEnv+initJSMState tag supply = JEnv { prefix = tag+                               , ids    = supply+                               }+initJSM :: IO JEnv+initJSM = do supply <- mkSplitUniqSupply 'j'+             return (initJSMState "js" supply)++update_stream :: UniqSupply -> JSM ()+update_stream new = modify' $ \env -> env {ids = new}++-- | generate a fresh Ident+newIdent :: JSM Ident+newIdent = do env <- get+              let tag    = prefix env+                  supply = ids    env+                  (id,rest) = takeUniqFromSupply supply+              update_stream rest+              return  $ mk_ident tag id++mk_ident :: FastString -> Unique -> Ident+mk_ident t i = name (mconcat [t, "_", mkFastString (show i)])++-- | Set the tag for @Ident@s for all remaining computations.+tag_names :: FastString -> JSM ()+tag_names tag = modify' (\env -> env {prefix = tag})++-- | tag the name generater with a prefix for the monadic action.+withTag+  :: FastString -- ^ new name to tag with+  -> JSM a      -- ^ action to run with new tags+  -> JSM a      -- ^ result+withTag tag go = do+  old <- gets prefix+  tag_names tag+  result <- go+  tag_names old+  return result
+ compiler/GHC/JS/JStg/Syntax.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.JStg.Syntax+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.JStg.Syntax defines the eDSL that the JS backend's runtime system+--     is written in. Nothing fancy, its just a straightforward deeply embedded+--     DSL.+--+--     In general, one should not use these constructors explicitly in the JS+--     backend. Instead, prefer using the combinators in GHC.JS.Make, if those+--     are suitable then prefer using the patterns exported from this module++-----------------------------------------------------------------------------+module GHC.JS.JStg.Syntax+  ( -- * Deeply embedded JS datatypes+    JStgStat(..)+  , JStgExpr(..)+  , JVal(..)+  , Op(..)+  , AOp(..)+  , UOp(..)+  , JsLabel+  -- * pattern synonyms over JS operators+  , pattern New+  , pattern Not+  , pattern Negate+  , pattern Add+  , pattern Sub+  , pattern Mul+  , pattern Div+  , pattern Mod+  , pattern BOr+  , pattern BAnd+  , pattern BXor+  , pattern BNot+  , pattern LOr+  , pattern LAnd+  , pattern Int+  , pattern String+  , pattern Var+  , pattern PreInc+  , pattern PostInc+  , pattern PreDec+  , pattern PostDec+  -- * Utility+  , SaneDouble(..)+  , pattern Func+  , global+  , local+  ) where++import GHC.Prelude+import GHC.Utils.Outputable++import GHC.JS.Ident++import Control.DeepSeq++import Data.Data+import qualified Data.Semigroup as Semigroup++import GHC.Generics++import GHC.Data.FastString+import GHC.Types.Unique.Map+import GHC.Types.SaneDouble++--------------------------------------------------------------------------------+--                            Statements+--------------------------------------------------------------------------------+-- | JavaScript statements, see the [ECMA262+-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)+-- for details+data JStgStat+  = DeclStat   !Ident !(Maybe JStgExpr)         -- ^ Variable declarations: var foo [= e]+  | ReturnStat JStgExpr                         -- ^ Return+  | IfStat     JStgExpr JStgStat JStgStat       -- ^ If+  | WhileStat  Bool JStgExpr JStgStat           -- ^ While, bool is "do" when True+  | ForStat    JStgStat JStgExpr JStgStat JStgStat -- ^ For+  | ForInStat  Bool Ident JStgExpr JStgStat     -- ^ For-in, bool is "each' when True+  | SwitchStat JStgExpr [(JStgExpr, JStgStat)] JStgStat  -- ^ Switch+  | TryStat    JStgStat Ident JStgStat JStgStat          -- ^ Try+  | BlockStat  [JStgStat]                       -- ^ Blocks+  | ApplStat   JStgExpr [JStgExpr]              -- ^ Application+  | UOpStat UOp JStgExpr                        -- ^ Unary operators+  | AssignStat JStgExpr AOp JStgExpr            -- ^ Binding form: @foo = bar@+  | LabelStat JsLabel JStgStat                  -- ^ Statement Labels, makes me nostalgic for qbasic+  | BreakStat (Maybe JsLabel)                   -- ^ Break+  | ContinueStat (Maybe JsLabel)                -- ^ Continue+  | FuncStat   !Ident [Ident] JStgStat          -- ^ an explicit function definition+  deriving (Eq, Generic)++-- | A Label used for 'JStgStat', specifically 'BreakStat', 'ContinueStat' and of+-- course 'LabelStat'+type JsLabel = LexicalFastString++instance Semigroup JStgStat where+  (<>) = appendJStgStat++instance Monoid JStgStat where+  mempty = BlockStat []++-- | Append a statement to another statement. 'appendJStgStat' only returns a+-- 'JStgStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty+-- 'BlockStat'. That is:+-- > (BlockStat [] , y           ) = y+-- > (x            , BlockStat []) = x+appendJStgStat :: JStgStat -> JStgStat -> JStgStat+appendJStgStat mx my = case (mx,my) of+  (BlockStat [] , y           ) -> y+  (x            , BlockStat []) -> x+  (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys+  (BlockStat xs , ys          ) -> BlockStat $ xs ++ [ys]+  (xs           , BlockStat ys) -> BlockStat $ xs : ys+  (xs           , ys          ) -> BlockStat [xs,ys]+++--------------------------------------------------------------------------------+--                            Expressions+--------------------------------------------------------------------------------+-- | JavaScript Expressions+data JStgExpr+  = ValExpr    JVal                 -- ^ All values are trivially expressions+  | SelExpr    JStgExpr Ident       -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'+  | IdxExpr    JStgExpr JStgExpr    -- ^ Indexing:  Obj[foo], see 'GHC.JS.Make..!'+  | InfixExpr  Op JStgExpr JStgExpr -- ^ Infix Expressions, see 'JStgExpr' pattern synonyms+  | UOpExpr    UOp JStgExpr               -- ^ Unary Expressions+  | IfExpr     JStgExpr JStgExpr JStgExpr  -- ^ If-expression+  | ApplExpr   JStgExpr [JStgExpr]         -- ^ Application+  deriving (Eq, Generic)++instance Outputable JStgExpr where+  ppr x = case x of+    ValExpr _ -> text ("ValExpr" :: String)+    SelExpr x' _ -> text ("SelExpr" :: String) <+> ppr x'+    IdxExpr x' y' -> text ("IdxExpr" :: String) <+> ppr (x', y')+    InfixExpr _ x' y' -> text ("InfixExpr" :: String) <+> ppr (x', y')+    UOpExpr _ x' -> text ("UOpExpr" :: String) <+> ppr x'+    IfExpr p t e -> text ("IfExpr" :: String) <+> ppr (p, t, e)+    ApplExpr x' xs -> text ("ApplExpr" :: String) <+> ppr (x', xs)++-- * Useful pattern synonyms to ease programming with the deeply embedded JS+--   AST. Each pattern wraps @UOp@ and @Op@ into a @JStgExpr@s to save typing and+--   for convienience. In addition we include a string wrapper for JS string+--   and Integer literals.++-- | pattern synonym for a unary operator new+pattern New :: JStgExpr -> JStgExpr+pattern New x = UOpExpr NewOp x++-- | pattern synonym for prefix increment @++x@+pattern PreInc :: JStgExpr -> JStgExpr+pattern PreInc x = UOpExpr PreIncOp x++-- | pattern synonym for postfix increment @x++@+pattern PostInc :: JStgExpr -> JStgExpr+pattern PostInc x = UOpExpr PostIncOp x++-- | pattern synonym for prefix decrement @--x@+pattern PreDec :: JStgExpr -> JStgExpr+pattern PreDec x = UOpExpr PreDecOp x++-- | pattern synonym for postfix decrement @--x@+pattern PostDec :: JStgExpr -> JStgExpr+pattern PostDec x = UOpExpr PostDecOp x++-- | pattern synonym for logical not @!@+pattern Not :: JStgExpr -> JStgExpr+pattern Not x = UOpExpr NotOp x++-- | pattern synonym for unary negation @-@+pattern Negate :: JStgExpr -> JStgExpr+pattern Negate x = UOpExpr NegOp x++-- | pattern synonym for addition @+@+pattern Add :: JStgExpr -> JStgExpr -> JStgExpr+pattern Add x y = InfixExpr AddOp x y++-- | pattern synonym for subtraction @-@+pattern Sub :: JStgExpr -> JStgExpr -> JStgExpr+pattern Sub x y = InfixExpr SubOp x y++-- | pattern synonym for multiplication @*@+pattern Mul :: JStgExpr -> JStgExpr -> JStgExpr+pattern Mul x y = InfixExpr MulOp x y++-- | pattern synonym for division @*@+pattern Div :: JStgExpr -> JStgExpr -> JStgExpr+pattern Div x y = InfixExpr DivOp x y++-- | pattern synonym for remainder @%@+pattern Mod :: JStgExpr -> JStgExpr -> JStgExpr+pattern Mod x y = InfixExpr ModOp x y++-- | pattern synonym for Bitwise Or @|@+pattern BOr :: JStgExpr -> JStgExpr -> JStgExpr+pattern BOr x y = InfixExpr BOrOp x y++-- | pattern synonym for Bitwise And @&@+pattern BAnd :: JStgExpr -> JStgExpr -> JStgExpr+pattern BAnd x y = InfixExpr BAndOp x y++-- | pattern synonym for Bitwise XOr @^@+pattern BXor :: JStgExpr -> JStgExpr -> JStgExpr+pattern BXor x y = InfixExpr BXorOp x y++-- | pattern synonym for Bitwise Not @~@+pattern BNot :: JStgExpr -> JStgExpr+pattern BNot x = UOpExpr BNotOp x++-- | pattern synonym for logical Or @||@+pattern LOr :: JStgExpr -> JStgExpr -> JStgExpr+pattern LOr x y = InfixExpr LOrOp x y++-- | pattern synonym for logical And @&&@+pattern LAnd :: JStgExpr -> JStgExpr -> JStgExpr+pattern LAnd x y = InfixExpr LAndOp x y++-- | pattern synonym to create integer values+pattern Int :: Integer -> JStgExpr+pattern Int x = ValExpr (JInt x)++-- | pattern synonym to create string values+pattern String :: FastString -> JStgExpr+pattern String x = ValExpr (JStr x)++-- | pattern synonym to create a local variable reference+pattern Var :: Ident -> JStgExpr+pattern Var x = ValExpr (JVar x)++-- | pattern synonym to create an anonymous function+pattern Func :: [Ident] -> JStgStat -> JStgExpr+pattern Func args body = ValExpr (JFunc args body)++--------------------------------------------------------------------------------+--                            Values+--------------------------------------------------------------------------------+-- | JavaScript values+data JVal+  = JVar     Ident                      -- ^ A variable reference+  | JList    [JStgExpr]                 -- ^ A JavaScript list, or what JS+                                        --   calls an Array+  | JDouble  SaneDouble                 -- ^ A Double+  | JInt     Integer                    -- ^ A BigInt+  | JStr     FastString                 -- ^ A String+  | JRegEx   FastString                 -- ^ A Regex+  | JBool    Bool                       -- ^ A Boolean+  | JHash    (UniqMap FastString JStgExpr) -- ^ A JS HashMap: @{"foo": 0}@+  | JFunc    [Ident] JStgStat              -- ^ A function+  deriving (Eq, Generic)++--------------------------------------------------------------------------------+--                            Operators+--------------------------------------------------------------------------------+-- | JS Binary Operators. We do not deeply embed the comma operator and the+-- assignment operators+data Op+  = EqOp            -- ^ Equality:              `==`+  | StrictEqOp      -- ^ Strict Equality:       `===`+  | NeqOp           -- ^ InEquality:            `!=`+  | StrictNeqOp     -- ^ Strict InEquality      `!==`+  | GtOp            -- ^ Greater Than:          `>`+  | GeOp            -- ^ Greater Than or Equal: `>=`+  | LtOp            -- ^ Less Than:              <+  | LeOp            -- ^ Less Than or Equal:     <=+  | AddOp           -- ^ Addition:               ++  | SubOp           -- ^ Subtraction:            -+  | MulOp           -- ^ Multiplication          \*+  | DivOp           -- ^ Division:               \/+  | ModOp           -- ^ Remainder:              %+  | LeftShiftOp     -- ^ Left Shift:             \<\<+  | RightShiftOp    -- ^ Right Shift:            \>\>+  | ZRightShiftOp   -- ^ Unsigned RightShift:    \>\>\>+  | BAndOp          -- ^ Bitwise And:            &+  | BOrOp           -- ^ Bitwise Or:             |+  | BXorOp          -- ^ Bitwise XOr:            ^+  | LAndOp          -- ^ Logical And:            &&+  | LOrOp           -- ^ Logical Or:             ||+  | InstanceofOp    -- ^ @instanceof@+  | InOp            -- ^ @in@+  deriving (Show, Eq, Ord, Enum, Data, Generic)++instance NFData Op++-- | JS Unary Operators+data UOp+  = NotOp           -- ^ Logical Not: @!@+  | BNotOp          -- ^ Bitwise Not: @~@+  | NegOp           -- ^ Negation:    @-@+  | PlusOp          -- ^ Unary Plus:  @+x@+  | NewOp           -- ^ new    x+  | TypeofOp        -- ^ typeof x+  | DeleteOp        -- ^ delete x+  | YieldOp         -- ^ yield  x+  | VoidOp          -- ^ void   x+  | PreIncOp        -- ^ Prefix Increment:  @++x@+  | PostIncOp       -- ^ Postfix Increment: @x++@+  | PreDecOp        -- ^ Prefix Decrement:  @--x@+  | PostDecOp       -- ^ Postfix Decrement: @x--@+  deriving (Show, Eq, Ord, Enum, Data, Generic)++instance NFData UOp++-- | JS Unary Operators+data AOp+  = AssignOp    -- ^ Vanilla  Assignment: =+  | AddAssignOp -- ^ Addition Assignment: +=+  | SubAssignOp -- ^ Subtraction Assignment: -=+  deriving (Show, Eq, Ord, Enum, Data, Generic)++instance NFData AOp++-- | construct a JS reference, intended to refer to a global name+global :: FastString -> JStgExpr+global = Var . name++-- | construct a JS reference, intended to refer to a local name+local :: FastString -> JStgExpr+local = Var . name
+ compiler/GHC/JS/Make.hs view
@@ -0,0 +1,836 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JStgExpr++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.Make+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.Make defines helper functions to ease the creation of JavaScript+--     ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL+--     more ergonomic to program in, and make errors in the EDSL /look/ obvious+--     because the EDSL is untyped. It is primarily concerned with injecting+--     terms into the domain of the EDSL to construct JS programs in Haskell.+--+-- * Strategy+--+--     The strategy for this module comes straight from gentzen; where we have+--     two types of helper functions. Functions which inject terms into the+--     EDSL, and combinator functions which operate on terms in the EDSL to+--     construct new terms in the EDSL. Crucially, missing from this module are+--     corresponding /elimination/ or /destructing/ functions which would+--     project information from the EDSL back to Haskell. See+--     'GHC.StgToJS.Utils' for such functions.+--+--      * /Introduction/ functions+--+--           We define various primitive helpers which /introduce/ terms in the+--           EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'.+--           Similarly this module exports four typeclasses 'ToExpr', 'ToStat',+--           'JVarMagic', 'JSArgument'. 'ToExpr' injects values as a JS+--           expression into the EDSL. 'ToStat' injects values as JS statements+--           into the EDSL. @JVarMagic@ provides a polymorphic way to introduce+--           a new name into the EDSL and @JSArgument@ provides a polymorphic+--           way to bind variable names for use in JS functions with different+--           arities.+--+--      * /Combinator/ functions+--+--           The rest of the module defines combinators which create terms in+--           the EDSL from terms in the EDSL. Notable examples are '|=' and+--           '||=', '|=' is sugar for 'AssignStat', it is a binding form that+--           declares @foo = bar@ /assuming/ foo has been already declared.+--           '||=' is more sugar on top of '|=', it is also a binding form that+--           declares the LHS of '|=' before calling '|=' to bind a value, bar,+--           to a variable foo. Other common examples are the 'if_' and 'math_'+--           helpers such as 'math_cos'.+--+-- * Consumers+--+--     The entire JS backend consumes this module, e.g., the modules in+--     GHC.StgToJS.\*.+--+-- * Notation+--+--     In this module we use @==>@ in docstrings to show the translation from+--     the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo+--     = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results+--     in the JS code @var foo; foo = bar;@ when compiled.+--+--     In most cases functions prefixed with a 'j' are monadic because the+--     observably allocate. Notable exceptions are `jwhenS`, 'jString' and the+--     helpers for HashMaps.+-----------------------------------------------------------------------------+module GHC.JS.Make+  ( -- * Injection Type classes+    -- $classes+    ToJExpr(..)+  , ToStat(..)+  , JVarMagic(..)+  , JSArgument(..)+  -- * Introduction functions+  -- $intro_funcs+  , jString+  , jLam, jLam', jFunction, jFunctionSized, jFunction'+  , jVar, jVars, jFor, jForIn, jForEachIn, jTryCatchFinally+  -- * Combinators+  -- $combinators+  , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)+  , (.>.), (.>=.), (.<.), (.<=.)+  , (.<<.), (.>>.), (.>>>.)+  , (.|.), (.||.), (.&&.)+  , if_, if10, if01, ifS, ifBlockS, jBlock, jIf+  , jwhenS+  , app, appS, returnS+  , loop, loopBlockS+  , preIncrS, postIncrS+  , preDecrS, postDecrS+  , off8, off16, off32, off64+  , mask8, mask16+  , signExtend8, signExtend16+  , typeOf+  , returnStack, assignAllEqual, assignAll, assignAllReverseOrder+  , declAssignAll+  , nullStat, (.^)+  -- ** Hash combinators+  , jhEmpty+  , jhSingle+  , jhAdd+  , jhFromList+  -- * Literals+  -- $literals+  , null_+  , undefined_+  , false_+  , true_+  , zero_+  , one_+  , two_+  , three_+  -- ** Math functions+  -- $math+  , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin,+    math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh,+    math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround,+    math_min, math_max+  -- * Statement helpers+  , Solo(..)+  , decl+  )+where++import GHC.Prelude hiding ((.|.))++import GHC.JS.Ident+import GHC.JS.JStg.Syntax+import GHC.JS.JStg.Monad+import GHC.JS.Transform++import Control.Arrow ((***))+import Control.Monad (replicateM)+import Data.Tuple++import qualified Data.Map as M++import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.Map++--------------------------------------------------------------------------------+--                        Type Classes+--------------------------------------------------------------------------------+-- $classes+-- The 'ToJExpr' class handles injection of of things into the EDSL as a JS+-- expression++-- | Things that can be marshalled into javascript values.+-- Instantiate for any necessary data structures.+class ToJExpr a where+    toJExpr         :: a   -> JStgExpr+    toJExprFromList :: [a] -> JStgExpr+    toJExprFromList = ValExpr . JList . map toJExpr++instance ToJExpr a => ToJExpr [a] where+    toJExpr = toJExprFromList++instance ToJExpr JStgExpr where+    toJExpr = id++instance ToJExpr () where+    toJExpr _ = ValExpr $ JList []++instance ToJExpr Bool where+    toJExpr True  = global "true"+    toJExpr False = global "false"++instance ToJExpr JVal where+    toJExpr = ValExpr++instance ToJExpr a => ToJExpr (UniqMap FastString a) where+    toJExpr = ValExpr . JHash . mapUniqMap toJExpr++instance ToJExpr a => ToJExpr (M.Map String a) where+    toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList++instance ToJExpr Double where+    toJExpr = ValExpr . JDouble . SaneDouble++instance ToJExpr Int where+    toJExpr = ValExpr . JInt . fromIntegral++instance ToJExpr Integer where+    toJExpr = ValExpr . JInt++instance ToJExpr Char where+    toJExpr = ValExpr . JStr . mkFastString . (:[])+    toJExprFromList = ValExpr . JStr . mkFastString+--        where escQuotes = tailDef "" . initDef "" . show++instance ToJExpr Ident where+    toJExpr = ValExpr . JVar++instance ToJExpr FastString where+    toJExpr = ValExpr . JStr++instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where+    toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b]++instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where+    toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c]++instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where+    toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d]+instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where+    toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e]+instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where+    toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f]+++-- | The 'ToStat' class handles injection of of things into the EDSL as a JS+-- statement. This ends up being polymorphic sugar for JS blocks, see helper+-- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data+-- structures.+class ToStat a where+    toStat :: a -> JStgStat++instance ToStat JStgStat where+    toStat = id++instance ToStat [JStgStat] where+    toStat = BlockStat++instance ToStat JStgExpr where+    toStat = expr2stat++instance ToStat [JStgExpr] where+    toStat = BlockStat . map expr2stat++-- | Convert A JS expression to a JS statement where applicable. This only+-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary+-- expression; 'UOpExpr'.+expr2stat :: JStgExpr -> JStgStat+expr2stat (ApplExpr x y) = (ApplStat x y)+expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z)+expr2stat (UOpExpr o x) = UOpStat o x+expr2stat _ = nullStat++--------------------------------------------------------------------------------+--                        Introduction Functions+--------------------------------------------------------------------------------+-- $intro_functions+-- Introduction functions are functions that map values or terms in the Haskell+-- domain to the JS EDSL domain++-- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr'+-- expression.+-- Usage:+--+-- > jLam $ \x -> jVar x + one_+-- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x)))+jLam :: JSArgument args => (args -> JSM JStgStat) -> JSM JStgExpr+jLam body = do xs <- args+               ValExpr . JFunc (argList xs) <$> body xs++-- | Special case of @jLam@ where the anonymous function requires no fresh+-- arguments.+jLam' :: JStgStat -> JStgExpr+jLam' body = ValExpr $ JFunc mempty body++-- | Introduce only one new variable into scope for the duration of the+-- enclosed expression. The result is a block statement. Usage:+--+-- 'jVar $ \x -> mconcat [jVar x ||= one_, ...'+jVar :: (JVarMagic t, ToJExpr t) => (t -> JSM JStgStat) -> JSM JStgStat+jVar f = jVars $ \(MkSolo only_one) -> f only_one++-- | Introduce one or many new variables into scope for the duration of the+-- enclosed expression. This function reifies the number of arguments based on+-- the container of the input function. We intentionally avoid lists and instead+-- opt for tuples because lists are not sized in general. The result is a block+-- statement. Usage:+--+-- @jVars $ \(x,y) -> mconcat [ x |= one_,  y |= two_,  x + y]@+jVars :: (JSArgument args) => (args -> JSM JStgStat) -> JSM JStgStat+jVars f = do as   <- args+             body <- f as+             return $ mconcat $ fmap decl (argList as) ++ [body]++-- | Construct a top-level function subject to JS hoisting. This combinator is+-- polymorphic over function arity so you can you use to define a JS syntax+-- object in Haskell, which is a function in JS that takes 2 or 4 or whatever+-- arguments. For a singleton function use the @Solo@ constructor @MkSolo@.+-- Usage:+--+-- an example from the Rts that defines a 1-arity JS function+-- > jFunction (global "h$getReg") (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty)+--+-- an example of a two argument function from the Rts+-- > jFunction (global "h$bh_lne") (\(x, frameSize) -> bhLneStats s x frameSize)+jFunction+  :: (JSArgument args)+  => Ident                  -- ^ global name+  -> (args -> JSM JStgStat) -- ^ function body, input is locally unique generated variables+  -> JSM JStgStat+jFunction name body = do+  func_args <- args+  FuncStat name (argList func_args) <$> (body func_args)++-- | Construct a top-level function subject to JS hoisting. Special case where+-- the arity cannot be deduced from the 'args' parameter (atleast not without+-- dependent types).+jFunctionSized+  :: Ident                        -- ^ global name+  -> Int                          -- ^ Arity+  -> ([JStgExpr] -> JSM JStgStat) -- ^ function body, input is locally unique generated variables+  -> JSM JStgStat+jFunctionSized name arity body = do+  func_args <- replicateM arity newIdent+  FuncStat name func_args <$> (body $ toJExpr <$> func_args)++-- | Construct a top-level function subject to JS hoisting. Special case where+-- the function binds no parameters+jFunction'+  :: Ident        -- ^ global name+  -> JSM JStgStat -- ^ function body, input is locally unique generated variables+  -> JSM JStgStat+jFunction' name body = FuncStat name mempty <$> body++jBlock :: Monoid a => [JSM a] -> JSM a+jBlock =  fmap mconcat . sequence++-- | Create a 'for in' statement.+-- Usage:+--+-- @jForIn {expression} $ \x -> {block involving x}@+jForIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat+jForIn e f = do+  i <- newIdent+  return $ decl i `mappend` ForInStat False i e (f (ValExpr $! JVar i))++-- | As with "jForIn" but creating a \"for each in\" statement.+jForEachIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat+jForEachIn e f = do i     <- newIdent+                    return $ decl i `mappend` ForInStat True i e (f (ValExpr $! JVar i))++-- | Create a 'for' statement given a function for initialization, a predicate+-- to step to, a step and a body+-- Usage:+--+-- @ jFor (|= zero_) (.<. Int 65536) preIncrS+--        (\j -> ...something with the counter j...)@+--+jFor :: (JStgExpr -> JStgStat) -- ^ initialization function+     -> (JStgExpr -> JStgExpr) -- ^ predicate+     -> (JStgExpr -> JStgStat) -- ^ step function+     -> (JStgExpr -> JStgStat) -- ^ body+     -> JSM JStgStat+jFor init pred step body = do id <- newIdent+                              let i = ValExpr (JVar id)+                              return+                                $ decl id `mappend` ForStat (init i) (pred i) (step i) (body i)++-- | As with "jForIn" but creating a \"for each in\" statement.+jTryCatchFinally :: (Ident -> JStgStat) -> (Ident -> JStgStat) -> (Ident -> JStgStat) -> JSM JStgStat+jTryCatchFinally c f f2 = do i <- newIdent+                             return $ TryStat (c i) i (f i) (f2 i)++-- | Convert a FastString to a Javascript String+jString :: FastString -> JStgExpr+jString = toJExpr++-- | construct a js declaration with the given identifier+decl :: Ident -> JStgStat+decl i = DeclStat i Nothing++-- | The empty JS HashMap+jhEmpty :: M.Map k JStgExpr+jhEmpty = M.empty++-- | A singleton JS HashMap+jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr+jhSingle k v = jhAdd k v jhEmpty++-- | insert a key-value pair into a JS HashMap+jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr -> M.Map k JStgExpr+jhAdd  k v m = M.insert k (toJExpr v) m++-- | Construct a JS HashMap from a list of key-value pairs+jhFromList :: [(FastString, JStgExpr)] -> JVal+jhFromList = JHash . listToUniqMap++-- | The empty JS statement+nullStat :: JStgStat+nullStat = BlockStat []+++--------------------------------------------------------------------------------+--                             Combinators+--------------------------------------------------------------------------------+-- $combinators+-- Combinators operate on terms in the JS EDSL domain to create new terms in the+-- EDSL domain.++-- | JS infix Equality operators+(.==.), (.===.), (.!=.), (.!==.) :: JStgExpr -> JStgExpr -> JStgExpr+(.==.)  = InfixExpr EqOp+(.===.) = InfixExpr StrictEqOp+(.!=.)  = InfixExpr NeqOp+(.!==.) = InfixExpr StrictNeqOp++infixl 6 .==., .===., .!=., .!==.++-- | JS infix Ord operators+(.>.), (.>=.), (.<.), (.<=.) :: JStgExpr -> JStgExpr -> JStgExpr+(.>.)  = InfixExpr GtOp+(.>=.) = InfixExpr GeOp+(.<.)  = InfixExpr LtOp+(.<=.) = InfixExpr LeOp++infixl 7 .>., .>=., .<., .<=.++-- | JS infix bit operators+(.|.), (.||.), (.&&.)  :: JStgExpr -> JStgExpr -> JStgExpr+(.|.)   = InfixExpr BOrOp+(.||.)  = InfixExpr LOrOp+(.&&.)  = InfixExpr LAndOp++infixl 8 .||., .&&.++-- | JS infix bit shift operators+(.<<.), (.>>.), (.>>>.) :: JStgExpr -> JStgExpr -> JStgExpr+(.<<.)  = InfixExpr LeftShiftOp+(.>>.)  = InfixExpr RightShiftOp+(.>>>.) = InfixExpr ZRightShiftOp++infixl 9 .<<., .>>., .>>>.++-- | Given a 'JStgExpr', return the its type.+typeOf :: JStgExpr -> JStgExpr+typeOf = UOpExpr TypeofOp++-- | JS if-expression+--+-- > if_ e1 e2 e3 ==> e1 ? e2 : e3+if_ :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr+if_ e1 e2 e3 = IfExpr e1 e2 e3++-- | If-expression which returns statements, see related 'ifBlockS'+--+-- > if e s1 s2 ==> if(e) { s1 } else { s2 }+ifS :: JStgExpr -> JStgStat -> JStgStat -> JStgStat+ifS e s1 s2 = IfStat e s1 s2+++-- | Version of a JS if-expression which admits monadic actions in its branches+jIf :: JStgExpr -> JSM JStgStat -> JSM JStgStat -> JSM JStgStat+jIf e ma mb = do+  !a <- ma+  !b <- mb+  pure $ IfStat e a b++-- | A when-statement as syntactic sugar via `ifS`+--+-- > jwhenS cond block ==> if(cond) { block } else {  }+jwhenS :: JStgExpr -> JStgStat -> JStgStat+jwhenS cond block = IfStat cond block mempty++-- | If-expression which returns blocks+--+-- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 }+ifBlockS :: JStgExpr -> [JStgStat] -> [JStgStat] -> JStgStat+ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2)++-- | if-expression that returns 1 if condition <=> true, 0 otherwise+--+-- > if10 e ==> e ? 1 : 0+if10 :: JStgExpr -> JStgExpr+if10 e = IfExpr e one_ zero_++-- | if-expression that returns 0 if condition <=> true, 1 otherwise+--+-- > if01 e ==> e ? 0 : 1+if01 :: JStgExpr -> JStgExpr+if01 e = IfExpr e zero_ one_++-- | an application expression, see related 'appS'+--+-- > app f xs ==> f(xs)+app :: FastString -> [JStgExpr] -> JStgExpr+app f xs = ApplExpr (global f) xs++-- | A statement application, see the expression form 'app'+appS :: FastString -> [JStgExpr] -> JStgStat+appS f xs = ApplStat (global f) xs++-- | Return a 'JStgExpr'+returnS :: JStgExpr -> JStgStat+returnS e = ReturnStat e++-- | "for" loop with increment at end of body+loop :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat+loop initial test body_ = jVar $ \i ->+  do body <- body_ i+     return $+       mconcat [ i |= initial+               , WhileStat False (test i) body+               ]++-- | "for" loop with increment at end of body+loopBlockS :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> [JStgStat]) -> JSM JStgStat+loopBlockS initial test body = jVar $ \i ->+  return $+  mconcat [ i |= initial+          , WhileStat False (test i) (mconcat (body i))+          ]++-- | Prefix-increment a 'JStgExpr'+preIncrS :: JStgExpr -> JStgStat+preIncrS x = UOpStat PreIncOp x++-- | Postfix-increment a 'JStgExpr'+postIncrS :: JStgExpr -> JStgStat+postIncrS x = UOpStat PostIncOp x++-- | Prefix-decrement a 'JStgExpr'+preDecrS :: JStgExpr -> JStgStat+preDecrS x = UOpStat PreDecOp x++-- | Postfix-decrement a 'JStgExpr'+postDecrS :: JStgExpr -> JStgStat+postDecrS x = UOpStat PostDecOp x++-- | Byte indexing of o with a 64-bit offset+off64 :: JStgExpr -> JStgExpr -> JStgExpr+off64 o i = Add o (i .<<. three_)++-- | Byte indexing of o with a 32-bit offset+off32 :: JStgExpr -> JStgExpr -> JStgExpr+off32 o i = Add o (i .<<. two_)++-- | Byte indexing of o with a 16-bit offset+off16 :: JStgExpr -> JStgExpr -> JStgExpr+off16 o i = Add o (i .<<. one_)++-- | Byte indexing of o with a 8-bit offset+off8 :: JStgExpr -> JStgExpr -> JStgExpr+off8 o i = Add o i++-- | a bit mask to retrieve the lower 8-bits+mask8 :: JStgExpr -> JStgExpr+mask8 x = BAnd x (Int 0xFF)++-- | a bit mask to retrieve the lower 16-bits+mask16 :: JStgExpr -> JStgExpr+mask16 x = BAnd x (Int 0xFFFF)++-- | Sign-extend/narrow a 8-bit value+signExtend8 :: JStgExpr -> JStgExpr+signExtend8 x = (BAnd x (Int 0x7F  )) `Sub` (BAnd x (Int 0x80))++-- | Sign-extend/narrow a 16-bit value+signExtend16 :: JStgExpr -> JStgExpr+signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000))++-- | Select a property 'prop', from and object 'obj'+--+-- > obj .^ prop ==> obj.prop+(.^) :: JStgExpr -> FastString -> JStgExpr+obj .^ prop = SelExpr obj (name prop)+infixl 8 .^++-- | Assign a variable to an expression+--+-- > foo |= expr ==> var foo = expr;+(|=) :: JStgExpr -> JStgExpr -> JStgStat+(|=) l r = AssignStat l AssignOp r++-- | Declare a variable and then Assign the variable to an expression+--+-- > foo |= expr ==> var foo; foo = expr;+(||=) :: Ident -> JStgExpr -> JStgStat+i ||= ex = DeclStat i (Just ex)++infixl 2 ||=, |=++-- | return the expression at idx of obj+--+-- > obj .! idx ==> obj[idx]+(.!) :: JStgExpr -> JStgExpr -> JStgExpr+(.!) = IdxExpr++infixl 8 .!++assignAllEqual :: HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat+assignAllEqual xs ys = mconcat (zipWithEqual (|=) xs ys)++assignAll :: [JStgExpr] -> [JStgExpr] -> JStgStat+assignAll xs ys = mconcat (zipWith (|=) xs ys)++assignAllReverseOrder :: [JStgExpr] -> [JStgExpr] -> JStgStat+assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys))++declAssignAll :: [Ident] -> [JStgExpr] -> JStgStat+declAssignAll xs ys = mconcat (zipWith (||=) xs ys)+++--------------------------------------------------------------------------------+--                             Literals+--------------------------------------------------------------------------------+-- $literals+-- Literals in the JS EDSL are constants in the Haskell domain. These are useful+-- helper values and never change++-- | The JS literal 'null'+null_ :: JStgExpr+null_ = global "null"++-- | The JS literal 0+zero_ :: JStgExpr+zero_ = Int 0++-- | The JS literal 1+one_ :: JStgExpr+one_ = Int 1++-- | The JS literal 2+two_ :: JStgExpr+two_ = Int 2++-- | The JS literal 3+three_ :: JStgExpr+three_ = Int 3++-- | The JS literal 'undefined'+undefined_ :: JStgExpr+undefined_ = global "undefined"++-- | The JS literal 'true'+true_ :: JStgExpr+true_ = ValExpr (JBool True)++-- | The JS literal 'false'+false_ :: JStgExpr+false_ = ValExpr (JBool False)++returnStack :: JStgStat+returnStack = ReturnStat (ApplExpr (global "h$rs") [])+++--------------------------------------------------------------------------------+--                             Math functions+--------------------------------------------------------------------------------+-- $math+-- Math functions in the EDSL are literals, with the exception of 'math_' which+-- is the sole math introduction function.++math :: JStgExpr+math = global "Math"++math_ :: FastString -> [JStgExpr] -> JStgExpr+math_ op args = ApplExpr (math .^ op) args++math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan,+  math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign,+  math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround,+  math_min, math_max+  :: [JStgExpr] -> JStgExpr+math_log   = math_ "log"+math_sin   = math_ "sin"+math_cos   = math_ "cos"+math_tan   = math_ "tan"+math_exp   = math_ "exp"+math_acos  = math_ "acos"+math_asin  = math_ "asin"+math_atan  = math_ "atan"+math_abs   = math_ "abs"+math_pow   = math_ "pow"+math_sign  = math_ "sign"+math_sqrt  = math_ "sqrt"+math_asinh = math_ "asinh"+math_acosh = math_ "acosh"+math_atanh = math_ "atanh"+math_sinh  = math_ "sinh"+math_cosh  = math_ "cosh"+math_tanh  = math_ "tanh"+math_expm1 = math_ "expm1"+math_log1p = math_ "log1p"+math_fround = math_ "fround"+math_min    = math_ "min"+math_max    = math_ "max"++instance Num JStgExpr where+    x + y = InfixExpr AddOp x y+    x - y = InfixExpr SubOp x y+    x * y = InfixExpr MulOp x y+    abs x    = math_abs [x]+    negate x = UOpExpr NegOp x+    signum x = math_sign [x]+    fromInteger x = ValExpr (JInt x)++instance Fractional JStgExpr where+    x / y = InfixExpr DivOp x y+    fromRational x = ValExpr (JDouble (realToFrac x))++++--------------------------------------------------------------------------------+-- New Identifiers+--------------------------------------------------------------------------------++-- | Type class that generates fresh @a@'s for the JS backend. You should almost+-- never need to use this directly. Instead use @JSArgument@, for examples of+-- how to employ these classes please see @jVar@, @jFunction@ and call sites in+-- the Rts.+class JVarMagic a where+  fresh :: JSM a++-- | Type class that finds the form of arguments required for a JS syntax+-- object. This class gives us a single interface to generate variables for+-- functions that have different arities. Thus with it, we can have only one+-- @jFunction@ which is polymorphic over its arity, instead of 'jFunction2',+-- 'jFunction3' and so on.+class JSArgument args where+  argList :: args -> [Ident]+  args :: JSM args++instance JVarMagic Ident where+  fresh = newIdent++instance JVarMagic JVal where+  fresh = JVar <$> fresh++instance JVarMagic JStgExpr where+  fresh = do i <- fresh+             return $ ValExpr $ JVar i++instance (JVarMagic a, ToJExpr a) => JSArgument (Solo a) where+  argList (MkSolo a) = concatMap identsE [toJExpr a]+  args = do i <- fresh+            return $ MkSolo i++instance (JVarMagic a, JVarMagic b, ToJExpr a, ToJExpr b) => JSArgument (a,b) where+  argList (a,b) = concatMap identsE [toJExpr a , toJExpr b]+  args = (,) <$> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         ) => JSArgument (a,b,c) where+  argList (a,b,c) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c]+  args = (,,) <$> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         ) => JSArgument (a,b,c,d) where+  argList (a,b,c,d) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d]+  args = (,,,) <$> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         ) => JSArgument (a,b,c,d,e) where+  argList (a,b,c,d,e) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e]+  args = (,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         ) => JSArgument (a,b,c,d,e,f) where+  argList (a,b,c,d,e,f) =  concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f]+  args = (,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         ) => JSArgument (a,b,c,d,e,f,g) where+  argList (a,b,c,d,e,f,g) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g]+  args = (,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         , JVarMagic h, ToJExpr h+         ) => JSArgument (a,b,c,d,e,f,g,h) where+  argList (a,b,c,d,e,f,g,h) =  concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h]+  args = (,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         , JVarMagic h, ToJExpr h+         , JVarMagic i, ToJExpr i+         ) => JSArgument (a,b,c,d,e,f,g,h,i) where+  argList (a,b,c,d,e,f,g,h,i) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i]+  args = (,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh+++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         , JVarMagic h, ToJExpr h+         , JVarMagic i, ToJExpr i+         , JVarMagic j, ToJExpr j+         ) => JSArgument (a,b,c,d,e,f,g,h,i,j) where+  argList (a,b,c,d,e,f,g,h,i,j) =  concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i, toJExpr j]+  args = (,,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh
+ compiler/GHC/JS/Ppr.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BlockArguments #-}++-- For Outputable instances for JS syntax+{-# OPTIONS_GHC -Wno-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.Ppr+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.Ppr defines the code generation facilities for the JavaScript+--     backend. That is, this module exports a function from the JS backend IR+--     to JavaScript compliant concrete syntax that can readily be executed by+--     nodejs or called in a browser.+--+-- * Design+--+--     This module follows the architecture and style of the other backends in+--     GHC: it instances Outputable for the relevant types, creates a class that+--     describes a morphism from the IR domain to JavaScript concrete Syntax and+--     then generates that syntax on a case by case basis.+--+-- * How to use+--+--     The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record.+--     Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for+--     specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a+--     custom renderer ensures all @Ident@ generated by the linker optimization+--     pass are prefixed differently than the default. Use @renderJS@ to+--     generate JavaScript concrete syntax in the general case, suitable for+--     human consumption.+-----------------------------------------------------------------------------++module GHC.JS.Ppr+  ( renderJs+  , renderPrefixJs+  , renderPrefixJs'+  , JsToDoc(..)+  , defaultRenderJs+  , RenderJs(..)+  , JsRender(..)+  , jsToDoc+  , pprStringLit+  , interSemi+  , braceNest+  , hangBrace+  )+where++import GHC.Prelude++import GHC.JS.Ident+import GHC.JS.Syntax++import Data.Char (isControl, ord)+import Data.List (sortOn)++import Numeric(showHex)++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Types.Unique.Map++instance Outputable JExpr where+  ppr = renderJs++instance Outputable JVal where+  ppr = renderJs++--------------------------------------------------------------------------------+--                            Top level API+--------------------------------------------------------------------------------++-- | Render a syntax tree as a pretty-printable document+-- (simply showing the resultant doc produces a nice,+-- well formatted String).+renderJs :: (JsToDoc a) => a -> SDoc+renderJs = renderJs' defaultRenderJs++{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs HLine -> a -> HLine #-}+{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs SDoc  -> a -> SDoc  #-}+renderJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc+renderJs' r = jsToDocR r++data RenderJs doc = RenderJs+  { renderJsS :: !(JsRender doc => RenderJs doc -> JStat -> doc)+  , renderJsE :: !(JsRender doc => RenderJs doc -> JExpr -> doc)+  , renderJsV :: !(JsRender doc => RenderJs doc -> JVal  -> doc)+  , renderJsI :: !(JsRender doc => RenderJs doc -> Ident -> doc)+  }++defaultRenderJs :: RenderJs doc+defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI++jsToDoc :: JsToDoc a => a -> SDoc+jsToDoc = jsToDocR defaultRenderJs++-- | Render a syntax tree as a pretty-printable document, using a given prefix+-- to all generated names. Use this with distinct prefixes to ensure distinct+-- generated names between independent calls to render(Prefix)Js.+renderPrefixJs :: (JsToDoc a) => a -> SDoc+renderPrefixJs = renderPrefixJs' defaultRenderJs++renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc+renderPrefixJs' r = jsToDocR r++--------------------------------------------------------------------------------+--                            Code Generator+--------------------------------------------------------------------------------++class JsToDoc a where jsToDocR :: JsRender doc => RenderJs doc -> a -> doc+instance JsToDoc JStat   where jsToDocR r = renderJsS r r+instance JsToDoc JExpr   where jsToDocR r = renderJsE r r+instance JsToDoc JVal    where jsToDocR r = renderJsV r r+instance JsToDoc Ident   where jsToDocR r = renderJsI r r+instance JsToDoc [JExpr] where jsToDocR r = jcat . map (addSemi . jsToDocR r)+instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r)++defRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc+defRenderJsS r = \case+  IfStat cond x y -> jcat+                        [ hangBrace (text "if" <+?> parens (jsToDocR r cond)) (optBlock r x)+                        , mbElse+                        ]+        where mbElse | y == BlockStat []  = empty+                     | otherwise = hangBrace (text "else") (optBlock r y)+  DeclStat x Nothing  -> text "var" <+> jsToDocR r x+    -- special treatment for functions, otherwise there is too much left padding+    -- (more than the length of the expression assigned to). E.g.+    --+    --    var long_variable_name = (function()+    --                               {+    --                               ...+    --                             });+    --+  DeclStat x (Just (ValExpr f@(JFunc {}))) -> jhang (text "var" <+> jsToDocR r x <+?> char '=') (jsToDocR r f)+  DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e+  WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (optBlock r b)+  WhileStat True  p b -> hangBrace (text "do") (optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p)+  BreakStat l         -> addSemi $ maybe (text "break")    (\(LexicalFastString s) -> (text "break"    <+> ftext s)) l+  ContinueStat l      -> addSemi $ maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l+  LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$$ printBS s+        where+          printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss+          printBS x = jsToDocR r x++  ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (optBlock r sb)+    where+      forCond = jsToDocR r init <> semi <+?> jsToDocR r p <> semi <+?> parens (jsToDocR r s1)+  ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (optBlock r b)+        where txt | each = "for each"+                  | otherwise = "for"+  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 ($$$) $ 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+                                  <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is))+                             (optBlock r b)+  TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) <+?> mbCatch <+?> mbFinally+        where mbCatch | s1 == BlockStat [] = empty+                      | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (optBlock r s1)+              mbFinally | s2 == BlockStat [] = empty+                        | otherwise = hangBrace (text "finally") (optBlock r s2)+  AssignStat i op x    -> case x of+    -- special treatment for functions, otherwise there is too much left padding+    -- (more than the length of the expression assigned to). E.g.+    --+    --    long_variable_name = (function()+    --                               {+    --                               ...+    --                             });+    --+    ValExpr f@(JFunc {}) -> jhang (jsToDocR r i <> ftext (aOpText op)) (jsToDocR r f)+    _                    -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x+  UOpStat op x+    | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x+    | isPre op                 -> ftext (uOpText op) <+> optParens r x+    | otherwise                -> optParens r x <+> ftext (uOpText op)+  BlockStat xs -> jsToDocR r xs++-- | Remove one Block layering if we know we already have braces around the+-- statement+optBlock :: JsRender doc => RenderJs doc -> JStat -> doc+optBlock r x = case x of+  BlockStat{} -> jsToDocR r x+  _           -> addSemi (jsToDocR r x)++optParens :: JsRender doc => RenderJs doc -> JExpr -> doc+optParens r x = case x of+  UOpExpr _ _ -> parens (jsToDocR r x)+  _           -> jsToDocR r x++defRenderJsE :: JsRender doc => RenderJs doc -> JExpr -> doc+defRenderJsE r = \case+  ValExpr x         -> jsToDocR r x+  SelExpr x y       -> jsToDocR r x <> char '.' <> jsToDocR r y+  IdxExpr x y       -> jsToDocR r x <> brackets (jsToDocR r y)+  IfExpr x y z      -> parens (jsToDocR r x <+?> char '?' <+?> jsToDocR r y <+?> colon <+?> jsToDocR r z)+  InfixExpr op x y  -> parens $ jsToDocR r x <+?> ftext (opText op) <+?> jsToDocR r y+  UOpExpr op x+    | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x+    | isPre op                 -> ftext (uOpText op) <+> optParens r x+    | otherwise                -> optParens r x <+> ftext (uOpText op)+  ApplExpr je xs -> jsToDocR r je <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs)++defRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc+defRenderJsV r = \case+  JVar i    -> jsToDocR r i+  JList xs  -> brackets . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs+  JDouble (SaneDouble d)+    | d < 0 || isNegativeZero d -> parens (double d)+    | otherwise                 -> double d+  JInt i+    | i < 0     -> parens (integer i)+    | otherwise -> integer i+  JStr   s -> pprStringLit s+  JRegEx s -> char '/' <> ftext s <> char '/'+  JBool b -> text (if b then "true" else "false")+  JHash m+    | isNullUniqMap m  -> text "{}"+    | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma .+                          map (\(x,y) -> char '\'' <> ftext x <> char '\'' <> colon <+?> jsToDocR r y)+                          -- nonDetKeysUniqMap doesn't introduce non-determinism here+                          -- because we sort the elements lexically+                          $ sortOn (LexicalFastString . fst) (nonDetUniqMapToList m)+  JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)++defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc+defRenderJsI _  t = ftext (identFS t)++aOpText :: AOp -> FastString+aOpText = \case+  AssignOp    -> "="+  AddAssignOp -> "+="+  SubAssignOp -> "-="+++uOpText :: UOp -> FastString+uOpText = \case+  NotOp     -> "!"+  BNotOp    -> "~"+  NegOp     -> "-"+  PlusOp    -> "+"+  NewOp     -> "new"+  TypeofOp  -> "typeof"+  DeleteOp  -> "delete"+  YieldOp   -> "yield"+  VoidOp    -> "void"+  PreIncOp  -> "++"+  PostIncOp -> "++"+  PreDecOp  -> "--"+  PostDecOp -> "--"++opText :: Op -> FastString+opText = \case+  EqOp          -> "=="+  StrictEqOp    -> "==="+  NeqOp         -> "!="+  StrictNeqOp   -> "!=="+  GtOp          -> ">"+  GeOp          -> ">="+  LtOp          -> "<"+  LeOp          -> "<="+  AddOp         -> "+"+  SubOp         -> "-"+  MulOp         -> "*"+  DivOp         -> "/"+  ModOp         -> "%"+  LeftShiftOp   -> "<<"+  RightShiftOp  -> ">>"+  ZRightShiftOp -> ">>>"+  BAndOp        -> "&"+  BOrOp         -> "|"+  BXorOp        -> "^"+  LAndOp        -> "&&"+  LOrOp         -> "||"+  InstanceofOp  -> "instanceof"+  InOp          -> "in"+++isPre :: UOp -> Bool+isPre = \case+  PostIncOp -> False+  PostDecOp -> False+  _         -> True++isAlphaOp :: UOp -> Bool+isAlphaOp = \case+  NewOp    -> True+  TypeofOp -> True+  DeleteOp -> True+  YieldOp  -> True+  VoidOp   -> True+  _        -> False++pprStringLit :: IsLine doc => FastString -> doc+pprStringLit s = char '\"' <> encodeJson s <> char '\"'++--------------------------------------------------------------------------------+--                            Utilities+--------------------------------------------------------------------------------++encodeJson :: IsLine doc => FastString -> doc+encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))++encodeJsonChar :: IsLine doc => Char -> doc+encodeJsonChar = \case+  '/'  -> text "\\/"+  '\b' -> text "\\b"+  '\f' -> text "\\f"+  '\n' -> text "\\n"+  '\r' -> text "\\r"+  '\t' -> text "\\t"+  '"'  -> text "\\\""+  '\\' -> text "\\\\"+  c+    | not (isControl c) && ord c <= 127 -> char c+    | ord c <= 0xff   -> hexxs "\\x" 2 (ord c)+    | ord c <= 0xffff -> hexxs "\\u" 4 (ord c)+    | otherwise      -> let cp0 = ord c - 0x10000 -- output surrogate pair+                        in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <>+                           hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00)+    where hexxs prefix pad cp =+            let h = showHex cp ""+            in  text (prefix ++ replicate (pad - length h) '0' ++ h)+++interSemi :: JsRender doc => [doc] -> doc+interSemi = foldl ($$$) empty . punctuateFinal semi semi++-- | The structure `{body}`, optionally indented over multiple lines+{-# INLINE braceNest #-}+braceNest :: JsRender doc => doc -> doc+braceNest x = lbrace $$$ jnest x $$$ rbrace++-- | The structure `hdr {body}`, optionally indented over multiple lines+{-# INLINE hangBrace #-}+hangBrace :: JsRender doc => doc -> doc -> doc+hangBrace hdr body = jcat [ hdr <> char ' ' <> char '{', jnest body, char '}' ]++{-# INLINE jhang #-}+jhang :: JsRender doc => doc -> doc -> doc+jhang hdr body = jcat [ hdr, jnest body]++-- | JsRender controls the differences in whitespace between HLine and SDoc.+-- Generally, this involves the indentation and newlines in the human-readable+-- SDoc implementation being replaced in the HLine version by the minimal+-- whitespace required for valid JavaScript syntax.+class IsLine doc => JsRender doc where++  -- | Concatenate with an optional single space+  (<+?>)    :: doc -> doc -> doc+  -- | Concatenate with an optional newline+  ($$$)     :: doc -> doc -> doc+  -- | Concatenate these `doc`s, either vertically (SDoc) or horizontally (HLine)+  jcat      :: [doc] -> doc+  -- | Optionally indent the following+  jnest     :: doc -> doc+  -- | Append semi-colon (and line-break in HLine mode)+  addSemi   :: doc -> doc++instance JsRender SDoc where+  (<+?>) = (<+>)+  {-# INLINE (<+?>) #-}+  ($$$)  = ($+$)+  {-# INLINE ($$$) #-}+  jcat               = vcat+  {-# INLINE jcat #-}+  jnest              = nest 2+  {-# INLINE jnest #-}+  addSemi x = x <> semi+  {-# INLINE addSemi #-}+++instance JsRender HLine where+  (<+?>) = (<>)+  {-# INLINE (<+?>) #-}+  ($$$)  = (<>)+  {-# INLINE ($$$) #-}+  jcat               = hcat+  {-# INLINE jcat #-}+  jnest              = id+  {-# INLINE jnest #-}+  addSemi x = x <> semi <> char '\n'+  -- we add a line-break to avoid issues with lines too long in minified outputs+  {-# INLINE addSemi #-}
+ compiler/GHC/JS/Syntax.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.Syntax+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.Syntax defines the Syntax for the JS backend in GHC. It comports+--     with the [ECMA-262](https://tc39.es/ecma262/) although not every+--     production rule of the standard is represented. Code in this module is a+--     fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3+--     Clause) by Gershom Bazerman, heavily modified to accomodate GHC's+--     constraints.+--+--+-- * Strategy+--+--     Nothing fancy in this module, this is a classic deeply embedded AST for+--     JS. We define numerous ADTs and pattern synonyms to make pattern matching+--     and constructing ASTs easier.+--+--+-- * Consumers+--+--     The entire JS backend consumes this module, e.g., the modules in+--     GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides+--     helper functions that use the deeply embedded DSL defined in this module+--     to provide some of the benefits of a shallow embedding.+--+-----------------------------------------------------------------------------++module GHC.JS.Syntax+  ( -- * Deeply embedded JS datatypes+    JStat(..)+  , JExpr(..)+  , JVal(..)+  , Op(..)+  , UOp(..)+  , AOp(..)+  , Ident(..)+  , JLabel+  -- * pattern synonyms over JS operators+  , pattern New+  , pattern Not+  , pattern Negate+  , pattern Add+  , pattern Sub+  , pattern Mul+  , pattern Div+  , pattern Mod+  , pattern BOr+  , pattern BAnd+  , pattern BXor+  , pattern BNot+  , pattern LOr+  , pattern LAnd+  , pattern Int+  , pattern String+  , pattern Var+  , pattern PreInc+  , pattern PostInc+  , pattern PreDec+  , pattern PostDec+  -- * Utility+  , SaneDouble(..)+  , var+  , true_+  , false_+  ) where++import GHC.Prelude++import GHC.JS.Ident++import GHC.Data.FastString+import GHC.Types.Unique.Map+import GHC.Types.SaneDouble++import Control.DeepSeq++import Data.Data+import qualified Data.Semigroup as Semigroup++import GHC.Generics+++--------------------------------------------------------------------------------+--                            Statements+--------------------------------------------------------------------------------+-- | JavaScript statements, see the [ECMA262+-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)+-- for details+data JStat+  = DeclStat   !Ident !(Maybe JExpr)  -- ^ Variable declarations: var foo [= e]+  | ReturnStat JExpr                  -- ^ Return+  | IfStat     JExpr JStat JStat      -- ^ If+  | WhileStat  Bool JExpr JStat       -- ^ While, bool is "do" when True+  | ForStat    JStat JExpr JStat JStat  -- ^ For+  | ForInStat  Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True+  | SwitchStat JExpr [(JExpr, JStat)] JStat  -- ^ Switch+  | TryStat    JStat Ident JStat JStat -- ^ Try+  | BlockStat  [JStat]                 -- ^ Blocks+  | ApplStat   JExpr [JExpr]           -- ^ Application+  | UOpStat UOp JExpr                  -- ^ Unary operators+  | AssignStat JExpr AOp JExpr         -- ^ Binding form: @<foo> <op> <bar>@+  | LabelStat JLabel JStat             -- ^ Statement Labels, makes me nostalgic for qbasic+  | BreakStat (Maybe JLabel)           -- ^ Break+  | ContinueStat (Maybe JLabel)        -- ^ Continue+  | FuncStat   !Ident [Ident] JStat    -- ^ an explicit function definition+  deriving (Eq, Generic)++-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of+-- course 'LabelStat'+type JLabel = LexicalFastString++instance Semigroup JStat where+  (<>) = appendJStat++instance Monoid JStat where+  mempty = BlockStat []++-- | Append a statement to another statement. 'appendJStat' only returns a+-- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty+-- 'BlockStat'. That is:+-- > (BlockStat [] , y           ) = y+-- > (x            , BlockStat []) = x+appendJStat :: JStat -> JStat -> JStat+appendJStat mx my = case (mx,my) of+  (BlockStat [] , y           ) -> y+  (x            , BlockStat []) -> x+  (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys+  (BlockStat xs , ys          ) -> BlockStat $! xs ++ [ys]+  (xs           , BlockStat ys) -> BlockStat $! xs : ys+  (xs           , ys          ) -> BlockStat [xs,ys]+++--------------------------------------------------------------------------------+--                            Expressions+--------------------------------------------------------------------------------+-- | JavaScript Expressions+data JExpr+  = ValExpr    JVal              -- ^ All values are trivially expressions+  | SelExpr    JExpr Ident       -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'+  | IdxExpr    JExpr JExpr       -- ^ Indexing:  Obj[foo], see 'GHC.JS.Make..!'+  | InfixExpr  Op JExpr JExpr    -- ^ Infix Expressions, see 'JExpr' pattern synonyms+  | UOpExpr    UOp JExpr         -- ^ Unary Expressions+  | IfExpr     JExpr JExpr JExpr -- ^ If-expression+  | ApplExpr   JExpr [JExpr]     -- ^ Application+  deriving (Eq, Generic)++-- * Useful pattern synonyms to ease programming with the deeply embedded JS+--   AST. Each pattern wraps @UOp@ and @Op@ into a @JExpr@s to save typing and+--   for convienience. In addition we include a string wrapper for JS string+--   and Integer literals.++-- | pattern synonym for a unary operator new+pattern New :: JExpr -> JExpr+pattern New x = UOpExpr NewOp x++-- | pattern synonym for prefix increment @++x@+pattern PreInc :: JExpr -> JExpr+pattern PreInc x = UOpExpr PreIncOp x++-- | pattern synonym for postfix increment @x++@+pattern PostInc :: JExpr -> JExpr+pattern PostInc x = UOpExpr PostIncOp x++-- | pattern synonym for prefix decrement @--x@+pattern PreDec :: JExpr -> JExpr+pattern PreDec x = UOpExpr PreDecOp x++-- | pattern synonym for postfix decrement @--x@+pattern PostDec :: JExpr -> JExpr+pattern PostDec x = UOpExpr PostDecOp x++-- | pattern synonym for logical not @!@+pattern Not :: JExpr -> JExpr+pattern Not x = UOpExpr NotOp x++-- | pattern synonym for unary negation @-@+pattern Negate :: JExpr -> JExpr+pattern Negate x = UOpExpr NegOp x++-- | pattern synonym for addition @+@+pattern Add :: JExpr -> JExpr -> JExpr+pattern Add x y = InfixExpr AddOp x y++-- | pattern synonym for subtraction @-@+pattern Sub :: JExpr -> JExpr -> JExpr+pattern Sub x y = InfixExpr SubOp x y++-- | pattern synonym for multiplication @*@+pattern Mul :: JExpr -> JExpr -> JExpr+pattern Mul x y = InfixExpr MulOp x y++-- | pattern synonym for division @*@+pattern Div :: JExpr -> JExpr -> JExpr+pattern Div x y = InfixExpr DivOp x y++-- | pattern synonym for remainder @%@+pattern Mod :: JExpr -> JExpr -> JExpr+pattern Mod x y = InfixExpr ModOp x y++-- | pattern synonym for Bitwise Or @|@+pattern BOr :: JExpr -> JExpr -> JExpr+pattern BOr x y = InfixExpr BOrOp x y++-- | pattern synonym for Bitwise And @&@+pattern BAnd :: JExpr -> JExpr -> JExpr+pattern BAnd x y = InfixExpr BAndOp x y++-- | pattern synonym for Bitwise XOr @^@+pattern BXor :: JExpr -> JExpr -> JExpr+pattern BXor x y = InfixExpr BXorOp x y++-- | pattern synonym for Bitwise Not @~@+pattern BNot :: JExpr -> JExpr+pattern BNot x = UOpExpr BNotOp x++-- | pattern synonym for logical Or @||@+pattern LOr :: JExpr -> JExpr -> JExpr+pattern LOr x y = InfixExpr LOrOp x y++-- | pattern synonym for logical And @&&@+pattern LAnd :: JExpr -> JExpr -> JExpr+pattern LAnd x y = InfixExpr LAndOp x y++-- | pattern synonym to create integer values+pattern Int :: Integer -> JExpr+pattern Int x = ValExpr (JInt x)++-- | pattern synonym to create string values+pattern String :: FastString -> JExpr+pattern String x = ValExpr (JStr x)++-- | pattern synonym to create a local variable reference+pattern Var :: Ident -> JExpr+pattern Var x = ValExpr (JVar x)++--------------------------------------------------------------------------------+--                            Values+--------------------------------------------------------------------------------++-- | JavaScript values+data JVal+  = JVar     Ident        -- ^ A variable reference+  | JList    [JExpr]      -- ^ A JavaScript list, or what JS calls an Array+  | JDouble  SaneDouble   -- ^ A Double+  | JInt     Integer      -- ^ A BigInt+  | JStr     FastString   -- ^ A String+  | JRegEx   FastString   -- ^ A Regex+  | JBool    Bool         -- ^ A Boolean+  | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@+  | JFunc    [Ident] JStat             -- ^ A function+  deriving (Eq, Generic)+++--------------------------------------------------------------------------------+--                            Operators+--------------------------------------------------------------------------------++-- | JS Binary Operators. We do not deeply embed the comma operator and the+-- assignment operators+data Op+  = EqOp            -- ^ Equality:              `==`+  | StrictEqOp      -- ^ Strict Equality:       `===`+  | NeqOp           -- ^ InEquality:            `!=`+  | StrictNeqOp     -- ^ Strict InEquality      `!==`+  | GtOp            -- ^ Greater Than:          `>`+  | GeOp            -- ^ Greater Than or Equal: `>=`+  | LtOp            -- ^ Less Than:              <+  | LeOp            -- ^ Less Than or Equal:     <=+  | AddOp           -- ^ Addition:               ++  | SubOp           -- ^ Subtraction:            -+  | MulOp           -- ^ Multiplication          \*+  | DivOp           -- ^ Division:               \/+  | ModOp           -- ^ Remainder:              %+  | LeftShiftOp     -- ^ Left Shift:             \<\<+  | RightShiftOp    -- ^ Right Shift:            \>\>+  | ZRightShiftOp   -- ^ Unsigned RightShift:    \>\>\>+  | BAndOp          -- ^ Bitwise And:            &+  | BOrOp           -- ^ Bitwise Or:             |+  | BXorOp          -- ^ Bitwise XOr:            ^+  | LAndOp          -- ^ Logical And:            &&+  | LOrOp           -- ^ Logical Or:             ||+  | InstanceofOp    -- ^ @instanceof@+  | InOp            -- ^ @in@+  deriving (Show, Eq, Ord, Enum, Data, Generic)++instance NFData Op++-- | JS Unary Operators+data UOp+  = NotOp           -- ^ Logical Not: @!@+  | BNotOp          -- ^ Bitwise Not: @~@+  | NegOp           -- ^ Negation:    @-@+  | PlusOp          -- ^ Unary Plus:  @+x@+  | NewOp           -- ^ new    x+  | TypeofOp        -- ^ typeof x+  | DeleteOp        -- ^ delete x+  | YieldOp         -- ^ yield  x+  | VoidOp          -- ^ void   x+  | PreIncOp        -- ^ Prefix Increment:  @++x@+  | PostIncOp       -- ^ Postfix Increment: @x++@+  | PreDecOp        -- ^ Prefix Decrement:  @--x@+  | PostDecOp       -- ^ Postfix Decrement: @x--@+  deriving (Show, Eq, Ord, Enum, Data, Generic)++instance NFData UOp++-- | JS Unary Operators+data AOp+  = AssignOp    -- ^ Vanilla  Assignment: =+  | AddAssignOp -- ^ Addition Assignment: +=+  | SubAssignOp -- ^ Subtraction Assignment: -=+  deriving (Show, Eq, Ord, Enum, Data, Generic)++instance NFData AOp++-- | construct a JS variable reference+var :: FastString -> JExpr+var = Var . name++-- | The JS literal 'true'+true_ :: JExpr+true_ = ValExpr (JBool True)++-- | The JS literal 'false'+false_ :: JExpr+false_ = ValExpr (JBool False)
+ compiler/GHC/JS/Transform.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TupleSections #-}++module GHC.JS.Transform+  ( identsS+  , identsV+  , identsE+  , jStgExprToJS+  , jStgStatToJS+  )+where++import GHC.Prelude++import GHC.JS.Ident+import GHC.JS.JStg.Syntax+import qualified GHC.JS.Syntax as JS++import Data.List (sortBy)++import GHC.Data.FastString+import GHC.Types.Unique.Map+import GHC.Types.Unique.FM+++{-# INLINE identsS #-}+identsS :: JStgStat -> [Ident]+identsS = \case+  DeclStat i e       -> [i] ++ maybe [] identsE e+  ReturnStat e       -> identsE e+  IfStat e s1 s2     -> identsE e ++ identsS s1 ++ identsS s2+  WhileStat _ e s    -> identsE e ++ identsS s+  ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body+  ForInStat _ i e s  -> [i] ++ identsE e ++ identsS s+  SwitchStat e xs s  -> identsE e ++ concatMap traverseCase xs ++ identsS s+                           where traverseCase (e,s) = identsE e ++ identsS s+  TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3+  BlockStat xs       -> concatMap identsS xs+  ApplStat e es      -> identsE e ++ concatMap identsE es+  UOpStat _op e      -> identsE e+  AssignStat e1 _op e2 -> identsE e1 ++ identsE e2+  LabelStat _l s     -> identsS s+  BreakStat{}        -> []+  ContinueStat{}     -> []+  FuncStat i args body -> [i] ++ args ++ identsS body++{-# INLINE identsE #-}+identsE :: JStgExpr -> [Ident]+identsE = \case+  ValExpr v         -> identsV v+  SelExpr e _i      -> identsE e -- do not rename properties+  IdxExpr e1 e2     -> identsE e1 ++ identsE e2+  InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2+  UOpExpr _ e       -> identsE e+  IfExpr e1 e2 e3   -> identsE e1 ++ identsE e2 ++ identsE e3+  ApplExpr e es     -> identsE e  ++ concatMap identsE es++{-# INLINE identsV #-}+identsV :: JVal -> [Ident]+identsV = \case+  JVar i       -> [i]+  JList xs     -> concatMap identsE xs+  JDouble{}    -> []+  JInt{}       -> []+  JStr{}       -> []+  JRegEx{}     -> []+  JBool{}      -> []+  JHash m      -> concatMap identsE (nonDetEltsUniqMap m)+  JFunc args s -> args ++ identsS s++--------------------------------------------------------------------------------+--                            Translation+--+--------------------------------------------------------------------------------+jStgStatToJS :: JStgStat -> JS.JStat+jStgStatToJS  = \case+  DeclStat i rhs        -> JS.DeclStat i $ fmap jStgExprToJS rhs+  ReturnStat e          -> JS.ReturnStat $ jStgExprToJS e+  IfStat c t e          -> JS.IfStat (jStgExprToJS c) (jStgStatToJS t) (jStgStatToJS e)+  WhileStat is_do c e   -> JS.WhileStat is_do (jStgExprToJS c) (jStgStatToJS e)+  ForStat init p step body -> JS.ForStat  (jStgStatToJS init) (jStgExprToJS p)+                                           (jStgStatToJS step) (jStgStatToJS body)+  ForInStat is_each i iter body -> JS.ForInStat (is_each) i (jStgExprToJS iter) (jStgStatToJS body)+  SwitchStat struct ps def -> JS.SwitchStat+                              (jStgExprToJS struct)+                              (map (\(p1, p2) -> (jStgExprToJS p1, jStgStatToJS p2)) ps)+                              (jStgStatToJS def)+  TryStat t i c f       -> JS.TryStat (jStgStatToJS t) i (jStgStatToJS c) (jStgStatToJS f)+  BlockStat bs          -> JS.BlockStat $ map jStgStatToJS bs+  ApplStat rator rand   -> JS.ApplStat (jStgExprToJS rator) $ map jStgExprToJS rand+  UOpStat  rator rand   -> JS.UOpStat (jStgUOpToJS rator) (jStgExprToJS rand)+  AssignStat lhs op rhs -> JS.AssignStat (jStgExprToJS lhs) (jStgAOpToJS op) (jStgExprToJS rhs)+  LabelStat lbl stmt    -> JS.LabelStat lbl (jStgStatToJS stmt)+  BreakStat m_l         -> JS.BreakStat $! m_l+  ContinueStat m_l      -> JS.ContinueStat $! m_l+  FuncStat i args body  -> JS.FuncStat i args $ jStgStatToJS body++jStgExprToJS :: JStgExpr -> JS.JExpr+jStgExprToJS = \case+  ValExpr v            -> JS.ValExpr $ jStgValToJS v+  SelExpr obj i        -> JS.SelExpr (jStgExprToJS obj) i+  IdxExpr o i          -> JS.IdxExpr (jStgExprToJS o) (jStgExprToJS i)+  InfixExpr op l r     -> JS.InfixExpr (jStgOpToJS op) (jStgExprToJS l) (jStgExprToJS r)+  UOpExpr op r         -> JS.UOpExpr (jStgUOpToJS op) (jStgExprToJS r)+  IfExpr c t e         -> JS.IfExpr (jStgExprToJS c) (jStgExprToJS t) (jStgExprToJS e)+  ApplExpr rator rands -> JS.ApplExpr (jStgExprToJS rator) $ map jStgExprToJS rands++jStgValToJS :: JVal -> JS.JVal+jStgValToJS = \case+  JVar i   -> JS.JVar i+  JList xs -> JS.JList $ map jStgExprToJS xs+  JDouble d -> JS.JDouble d+  JInt i    -> JS.JInt   i+  JStr s    -> JS.JStr   s+  JRegEx f  -> JS.JRegEx f+  JBool b   -> JS.JBool  b+  JHash m   -> JS.JHash $ mapUniqMapM satHash m+    where+      satHash (i, x) = (i,) . (i,) $ jStgExprToJS x+      compareHash (i,_) (j,_) = lexicalCompareFS i j+      -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided+      mapUniqMapM f (UniqMap m) = UniqMap . listToUFM $ (map f . sortBy compareHash $ nonDetEltsUFM m)+  JFunc args body   -> JS.JFunc args $ jStgStatToJS body++jStgOpToJS :: Op -> JS.Op+jStgOpToJS = go+  where+    go EqOp         = JS.EqOp+    go StrictEqOp   = JS.StrictEqOp+    go NeqOp        = JS.NeqOp+    go StrictNeqOp  = JS.StrictNeqOp+    go GtOp         = JS.GtOp+    go GeOp         = JS.GeOp+    go LtOp         = JS.LtOp+    go LeOp         = JS.LeOp+    go AddOp        = JS.AddOp+    go SubOp        = JS.SubOp+    go MulOp        = JS.MulOp+    go DivOp        = JS.DivOp+    go ModOp        = JS.ModOp+    go LeftShiftOp  = JS.LeftShiftOp+    go RightShiftOp = JS.RightShiftOp+    go ZRightShiftOp = JS.ZRightShiftOp+    go BAndOp       = JS.BAndOp+    go BOrOp        = JS.BOrOp+    go BXorOp       = JS.BXorOp+    go LAndOp       = JS.LAndOp+    go LOrOp        = JS.LOrOp+    go InstanceofOp = JS.InstanceofOp+    go InOp         = JS.InOp++jStgUOpToJS :: UOp -> JS.UOp+jStgUOpToJS = go+  where+    go NotOp     = JS.NotOp+    go BNotOp    = JS.BNotOp+    go NegOp     = JS.NegOp+    go PlusOp    = JS.PlusOp+    go NewOp     = JS.NewOp+    go TypeofOp  = JS.TypeofOp+    go DeleteOp  = JS.DeleteOp+    go YieldOp   = JS.YieldOp+    go VoidOp    = JS.VoidOp+    go PreIncOp  = JS.PreIncOp+    go PostIncOp = JS.PostIncOp+    go PreDecOp  = JS.PreDecOp+    go PostDecOp = JS.PostDecOp++jStgAOpToJS :: AOp -> JS.AOp+jStgAOpToJS AssignOp    = JS.AssignOp+jStgAOpToJS AddAssignOp = JS.AddAssignOp+jStgAOpToJS SubAssignOp = JS.SubAssignOp
+ compiler/GHC/Linker/Config.hs view
@@ -0,0 +1,27 @@+-- | Linker configuration++module GHC.Linker.Config+  ( FrameworkOpts(..)+  , LinkerConfig(..)+  )+where++import GHC.Prelude+import GHC.Utils.TmpFs+import GHC.Utils.CliOption++-- used on darwin only+data FrameworkOpts = FrameworkOpts+  { foFrameworkPaths    :: [String]+  , foCmdlineFrameworks :: [String]+  }++-- | External linker configuration+data LinkerConfig = LinkerConfig+  { linkerProgram     :: String           -- ^ Linker program+  , 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+  }+
compiler/GHC/Linker/Types.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}+ ----------------------------------------------------------------------------- -- -- Types for the linkers and the loader@@ -5,7 +8,6 @@ -- (c) The University of Glasgow 2019 -- ------------------------------------------------------------------------------{-# LANGUAGE TypeApplications #-} module GHC.Linker.Types    ( Loader (..)    , LoaderState (..)@@ -16,46 +18,62 @@    , ClosureEnv    , emptyClosureEnv    , extendClosureEnv-   , Linkable(..)+   , LinkedBreaks(..)+   , filterLinkedBreaks    , LinkableSet    , mkLinkableSet    , unionLinkableSet    , ObjFile-   , Unlinked(..)    , SptEntry(..)-   , isObjectLinkable-   , linkableObjs-   , isObject-   , nameOfObject-   , nameOfObject_maybe-   , isInterpretable-   , byteCodeOfObject    , LibrarySpec(..)    , LoadedPkgInfo(..)    , PkgsLoaded++   -- * Linkable+   , Linkable(..)+   , LinkablePart(..)+   , LinkableObjectSort (..)+   , linkableIsNativeCodeOnly+   , linkableObjs+   , linkableLibs+   , linkableFiles+   , linkableBCOs+   , linkableNativeParts+   , linkablePartitionParts+   , linkablePartPath+   , linkablePartAllBCOs+   , isNativeCode+   , isNativeLib+   , linkableFilterByteCode+   , linkableFilterNative+   , partitionLinkables    ) where  import GHC.Prelude import GHC.Unit                ( UnitId, Module )-import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode )-import GHC.Fingerprint.Type    ( Fingerprint )-import GHCi.RemoteTypes        ( ForeignHValue )+import GHC.ByteCode.Types+import GHCi.BreakArray+import GHCi.RemoteTypes+import GHCi.Message            ( LoadedDLL ) -import GHC.Types.Var           ( Id )+import GHC.Stack.CCS import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) import GHC.Types.Name          ( Name )+import GHC.Types.SptEntry  import GHC.Utils.Outputable-import GHC.Utils.Panic  import Control.Concurrent.MVar+import Data.Array import Data.Time               ( UTCTime )-import Data.Maybe import GHC.Unit.Module.Env import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings+import Data.Maybe (mapMaybe)+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import qualified Data.List.NonEmpty as NE   {- **********************************************************************@@ -75,6 +93,53 @@  The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking.++Note [Looking up symbols in the relevant objects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #23415, we determined that a lot of time (>10s, or even up to >35s!) was+being spent on dynamically loading symbols before actually interpreting code+when `:main` was run in GHCi. The root cause was that for each symbol we wanted+to lookup, we would traverse the list of loaded objects and try find the symbol+in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in+the amount of loaded objects).++To drastically improve load time (from +-38 seconds down to +-2s), we now:++1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`.+  - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to+    `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`.++2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in+    the `pkgs_loaded` mapping,++3. And only look for the symbol (with `dlsym`) on the /handles relevant to that+    unit/, rather than in every loaded object.++Note [Symbols may not be found in pkgs_loaded]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently the `pkgs_loaded` mapping only contains the dynamic objects+associated with loaded units. Symbols defined in a static object (e.g. from a+statically-linked Haskell library) are found via the generic `lookupSymbol`+function call by `lookupHsSymbol` when the symbol is not found in any of the+dynamic objects of `pkgs_loaded`.++The rationale here is two-fold:++ * we have only observed major link-time issues in dynamic linking; lookups in+ the RTS linker's static symbol table seem to be fast enough++ * allowing symbol lookups restricted to a single ObjectCode would require the+ maintenance of a symbol table per `ObjectCode`, which would introduce time and+ space overhead++This fallback is further needed because we don't look in the haskell objects+loaded for the home units (see the call to `loadModuleLinkables` in+`loadDependencies`, as opposed to the call to `loadPackages'` in the same+function which updates `pkgs_loaded`). We should ultimately keep track of the+objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit+unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b)+and be able to lookup symbols specifically in them too (similarly to+`lookupSymbolInDLL`). -}  newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }@@ -96,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@@ -108,13 +176,13 @@     in pls { linker_env = le { closure_env = f ce } }  data LinkerEnv = LinkerEnv-  { closure_env :: ClosureEnv+  { closure_env :: !ClosureEnv       -- ^ Current global mapping from closure Names to their true values    , itbl_env    :: !ItblEnv       -- ^ The current global mapping from RdrNames of DataCons to       -- info table addresses.-      -- When a new Unlinked is linked into the running image, or an existing+      -- When a new LinkablePart is linked into the running image, or an existing       -- module in the image is replaced, the itbl_env must be updated       -- appropriately. @@ -124,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)@@ -139,6 +207,29 @@ 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  data LoadedPkgInfo@@ -146,11 +237,13 @@   { loaded_pkg_uid         :: !UnitId   , loaded_pkg_hs_objs     :: ![LibrarySpec]   , loaded_pkg_non_hs_objs :: ![LibrarySpec]+  , loaded_pkg_hs_dlls     :: ![RemotePtr LoadedDLL]+    -- ^ See Note [Looking up symbols in the relevant objects]   , loaded_pkg_trans_deps  :: UniqDSet UnitId   }  instance Outputable LoadedPkgInfo where-  ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) =+  ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) =     vcat [ppr uid          , ppr hs_objs          , ppr non_hs_objs@@ -158,15 +251,17 @@   -- | Information we can use to dynamically link modules into the compiler-data Linkable = LM {-  linkableTime     :: !UTCTime,          -- ^ Time at which this linkable was built-                                        -- (i.e. when the bytecodes were produced,-                                        --       or the mod date on the files)-  linkableModule   :: !Module,           -- ^ The linkable module itself-  linkableUnlinked :: [Unlinked]-    -- ^ Those files and chunks of code we have yet to link.-    ---    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.+data Linkable = Linkable+  { linkableTime     :: !UTCTime+      -- ^ Time at which this linkable was built+      -- (i.e. when the bytecodes were produced,+      --       or the mod date on the files)++  , linkableModule   :: !Module+      -- ^ The linkable module itself++  , linkableParts :: NonEmpty LinkablePart+    -- ^ Files and chunks of code to link.  }  type LinkableSet = ModuleEnv Linkable@@ -174,6 +269,9 @@ mkLinkableSet :: [Linkable] -> LinkableSet mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls] +-- | Union of LinkableSets.+--+-- In case of conflict, keep the most recent Linkable (as per linkableTime) unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet unionLinkableSet = plusModuleEnv_C go   where@@ -182,85 +280,200 @@       | otherwise = l2  instance Outputable Linkable where-  ppr (LM when_made mod unlinkeds)-     = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)-       $$ nest 3 (ppr unlinkeds)+  ppr (Linkable when_made mod parts)+     = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)+       $$ nest 3 (ppr parts)  type ObjFile = FilePath +-- | Classify the provenance of @.o@ products.+data LinkableObjectSort =+  -- | The object is the final product for a module.+  -- When linking splices, its file extension will be adapted to the+  -- interpreter's way if needed.+  ModuleObject+  |+  -- | The object was created from generated code for foreign stubs or foreign+  -- sources added by the user.+  -- Its file extension must be preserved, since there are no objects for+  -- alternative ways available.+  ForeignObject+ -- | Objects which have yet to be linked by the compiler-data Unlinked-  = DotO ObjFile       -- ^ An object file (.o)-  | DotA FilePath      -- ^ Static archive file (.a)-  | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)-  | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend-                       -- See Note [Interface Files with Core Definitions]-  | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid-                          -- being too strict.+data LinkablePart+  = DotO+      ObjFile+      -- ^ An object file (.o)+      LinkableObjectSort+      -- ^ Whether the object is an internal, intermediate build product that+      -- should not be adapted to the interpreter's way. Used for foreign stubs+      -- loaded from interfaces.++  | DotA FilePath+      -- ^ Static archive file (.a)++  | DotDLL FilePath+      -- ^ Dynamically linked library file (.so, .dll, .dylib)++  | CoreBindings WholeCoreBindings+      -- ^ Serialised core which we can turn into BCOs (or object files), or+      -- used by some other backend See Note [Interface Files with Core+      -- Definitions]++  | LazyBCOs+      CompiledByteCode+      -- ^ Some BCOs generated on-demand when forced. This is used for+      -- WholeCoreBindings, see Note [Interface Files with Core Definitions]+      [FilePath]+      -- ^ Objects containing foreign stubs and files+   | BCOs CompiledByteCode-         [SptEntry]    -- ^ A byte-code object, lives only in memory. Also-                       -- carries some static pointer table entries which-                       -- should be loaded along with the BCOs.-                       -- See Note [Grand plan for static forms] in-                       -- "GHC.Iface.Tidy.StaticPtrTable".+    -- ^ A byte-code object, lives only in memory. -instance Outputable Unlinked where-  ppr (DotO path)   = text "DotO" <+> text path-  ppr (DotA path)   = text "DotA" <+> text path-  ppr (DotDLL path) = text "DotDLL" <+> text path-  ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt-  ppr (LoadedBCOs{})  = text "LoadedBCOs"-  ppr (CoreBindings {})       = text "FI"+instance Outputable LinkablePart where+  ppr (DotO path sort)   = text "DotO" <+> text path <+> pprSort sort+    where+      pprSort = \case+        ModuleObject -> empty+        ForeignObject -> brackets (text "foreign")+  ppr (DotA path)       = text "DotA" <+> text path+  ppr (DotDLL path)     = text "DotDLL" <+> text path+  ppr (BCOs bco)        = text "BCOs" <+> ppr bco+  ppr (LazyBCOs{})      = text "LazyBCOs"+  ppr (CoreBindings {}) = text "CoreBindings" --- | An entry to be inserted into a module's static pointer table.--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-data SptEntry = SptEntry Id Fingerprint+-- | Return true if the linkable only consists of native code (no BCO)+linkableIsNativeCodeOnly :: Linkable -> Bool+linkableIsNativeCodeOnly l = all isNativeCode (NE.toList (linkableParts l)) -instance Outputable SptEntry where-  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr+-- | List the BCOs parts of a linkable.+--+-- This excludes the LazyBCOs and the CoreBindings parts+linkableBCOs :: Linkable -> [CompiledByteCode]+linkableBCOs l = [ cbc | BCOs cbc <- NE.toList (linkableParts l) ] +-- | List the native linkable parts (.o/.so/.dll) of a linkable+linkableNativeParts :: Linkable -> [LinkablePart]+linkableNativeParts l = NE.filter isNativeCode (linkableParts l) -isObjectLinkable :: Linkable -> Bool-isObjectLinkable l = not (null unlinked) && all isObject unlinked-  where unlinked = linkableUnlinked l-        -- A linkable with no Unlinked's is treated as a BCO.  We can-        -- generate a linkable with no Unlinked's as a result of-        -- compiling a module in NoBackend mode, and this choice-        -- happens to work well with checkStability in module GHC.+-- | Split linkable parts into (native code parts, BCOs parts)+linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart])+linkablePartitionParts l = NE.partition isNativeCode (linkableParts l) +-- | List the native objects (.o) of a linkable linkableObjs :: Linkable -> [FilePath]-linkableObjs l = [ f | DotO f <- linkableUnlinked l ]+linkableObjs l = concatMap linkablePartObjectPaths (linkableParts l) +-- | List the native libraries (.so/.dll) of a linkable+linkableLibs :: Linkable -> [LinkablePart]+linkableLibs l = NE.filter isNativeLib (linkableParts l)++-- | List the paths of the native objects and libraries (.o/.so/.dll)+linkableFiles :: Linkable -> [FilePath]+linkableFiles l = concatMap linkablePartNativePaths (NE.toList (linkableParts l))+ ------------------------------------------- --- | Is this an actual file on disk we can link in somehow?-isObject :: Unlinked -> Bool-isObject (DotO _)   = True-isObject (DotA _)   = True-isObject (DotDLL _) = True-isObject _          = False+-- | Is the part a native object or library? (.o/.so/.dll)+isNativeCode :: LinkablePart -> Bool+isNativeCode = \case+  DotO {}         -> True+  DotA {}         -> True+  DotDLL {}       -> True+  BCOs {}         -> False+  LazyBCOs{}      -> False+  CoreBindings {} -> False --- | Is this a bytecode linkable with no file on disk?-isInterpretable :: Unlinked -> Bool-isInterpretable = not . isObject+-- | Is the part a native library? (.so/.dll)+isNativeLib :: LinkablePart -> Bool+isNativeLib = \case+  DotO {}         -> False+  DotA {}         -> True+  DotDLL {}       -> True+  BCOs {}         -> False+  LazyBCOs{}      -> False+  CoreBindings {} -> False -nameOfObject_maybe :: Unlinked -> Maybe FilePath-nameOfObject_maybe (DotO fn)   = Just fn-nameOfObject_maybe (DotA fn)   = Just fn-nameOfObject_maybe (DotDLL fn) = Just fn-nameOfObject_maybe (CoreBindings {}) = Nothing-nameOfObject_maybe (LoadedBCOs{}) = Nothing-nameOfObject_maybe (BCOs {})   = Nothing+-- | Get the FilePath of linkable part (if applicable)+linkablePartPath :: LinkablePart -> Maybe FilePath+linkablePartPath = \case+  DotO fn _       -> Just fn+  DotA fn         -> Just fn+  DotDLL fn       -> Just fn+  CoreBindings {} -> Nothing+  LazyBCOs {}     -> Nothing+  BCOs {}         -> Nothing --- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object-nameOfObject :: Unlinked -> FilePath-nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o)+-- | Return the paths of all object code files (.o, .a, .so) contained in this+-- 'LinkablePart'.+linkablePartNativePaths :: LinkablePart -> [FilePath]+linkablePartNativePaths = \case+  DotO fn _       -> [fn]+  DotA fn         -> [fn]+  DotDLL fn       -> [fn]+  CoreBindings {} -> []+  LazyBCOs _ fos  -> fos+  BCOs {}         -> [] --- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable-byteCodeOfObject :: Unlinked -> [CompiledByteCode]-byteCodeOfObject (BCOs bc _) = [bc]-byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul-byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)+-- | Return the paths of all object files (.o) contained in this 'LinkablePart'.+linkablePartObjectPaths :: LinkablePart -> [FilePath]+linkablePartObjectPaths = \case+  DotO fn _ -> [fn]+  DotA _ -> []+  DotDLL _ -> []+  CoreBindings {} -> []+  LazyBCOs _ fos -> fos+  BCOs {} -> []++-- | Retrieve the compiled byte-code from the linkable part.+--+-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.+linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]+linkablePartAllBCOs = \case+  BCOs bco    -> [bco]+  LazyBCOs bcos _ -> [bcos]+  _           -> []++linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable+linkableFilter f linkable = do+  new <- nonEmpty (concatMap f (linkableParts linkable))+  Just linkable {linkableParts = new}++linkablePartNative :: LinkablePart -> [LinkablePart]+linkablePartNative = \case+  u@DotO {}  -> [u]+  u@DotA {} -> [u]+  u@DotDLL {} -> [u]+  LazyBCOs _ os -> [DotO f ForeignObject | f <- os]+  _ -> []++linkablePartByteCode :: LinkablePart -> [LinkablePart]+linkablePartByteCode = \case+  u@BCOs {}  -> [u]+  LazyBCOs bcos _ -> [BCOs bcos]+  _ -> []++-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only+-- object code files (.o, .a, .so) without 'LazyBCOs'.+-- If no 'LinkablePart' remains, return 'Nothing'.+linkableFilterNative :: Linkable -> Maybe Linkable+linkableFilterNative = linkableFilter linkablePartNative++-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only byte+-- code without 'LazyBCOs'.+-- If no 'LinkablePart' remains, return 'Nothing'.+linkableFilterByteCode :: Linkable -> Maybe Linkable+linkableFilterByteCode = linkableFilter linkablePartByteCode++-- | Split the 'LinkablePart' lists in each 'Linkable' into only object code+-- files (.o, .a, .so) and only byte code, without 'LazyBCOs', and return two+-- lists containing the nonempty 'Linkable's for each.+partitionLinkables :: [Linkable] -> ([Linkable], [Linkable])+partitionLinkables linkables =+  (+    mapMaybe linkableFilterNative linkables,+    mapMaybe linkableFilterByteCode linkables+  )  {- **********************************************************************
compiler/GHC/Parser.y view
@@ -13,4483 +13,4747 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-}---- | This module provides the generated Happy parser for Haskell. It exports--- a number of parsers which may be used in any library that uses the GHC API.--- A common usage pattern is to initialize the parser state with a given string--- and then parse that string:------ @---     runParser :: ParserOpts -> String -> P a -> ParseResult a---     runParser opts str parser = unP parser parseState---     where---       filename = "\<interactive\>"---       location = mkRealSrcLoc (mkFastString filename) 1 1---       buffer = stringToStringBuffer str---       parseState = initParserState opts buffer location--- @-module GHC.Parser-   ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack-   , parseDeclaration, parseExpression, parsePattern-   , parseTypeSignature-   , parseStmt, parseIdentifier-   , parseType, parseHeader-   , parseModuleNoHaddock-   )-where---- base-import Control.Monad    ( unless, liftM, when, (<=<) )-import GHC.Exts-import Data.Maybe       ( maybeToList )-import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.List.NonEmpty as NE-import qualified Prelude -- for happy-generated code--import GHC.Hs--import GHC.Driver.Backpack.Syntax--import GHC.Unit.Info-import GHC.Unit.Module-import GHC.Unit.Module.Warnings--import GHC.Data.OrdList-import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue )-import GHC.Data.FastString-import GHC.Data.Maybe          ( orElse )--import GHC.Utils.Outputable-import GHC.Utils.Error-import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )-import GHC.Utils.Panic-import GHC.Prelude-import qualified GHC.Data.Strict as Strict--import GHC.Types.Name.Reader-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS)-import GHC.Types.SrcLoc-import GHC.Types.Basic-import GHC.Types.Error ( GhcHint(..) )-import GHC.Types.Fixity-import GHC.Types.ForeignCall-import GHC.Types.SourceFile-import GHC.Types.SourceText-import GHC.Types.PkgQual--import GHC.Core.Type    ( Specificity(..) )-import GHC.Core.Class   ( FunDep )-import GHC.Core.DataCon ( DataCon, dataConName )--import GHC.Parser.PostProcess-import GHC.Parser.PostProcess.Haddock-import GHC.Parser.Lexer-import GHC.Parser.HaddockLex-import GHC.Parser.Annotation-import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr ()--import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,-                           tupleTyCon, tupleDataCon, nilDataCon,-                           unboxedUnitTyCon, unboxedUnitDataCon,-                           listTyCon_RDR, consDataCon_RDR,-                           unrestrictedFunTyCon )--import Language.Haskell.Syntax.Basic (FieldLabelString(..))--import qualified Data.Semigroup as Semi-}--%expect 0 -- shift/reduce conflicts--{- Note [shift/reduce conflicts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The 'happy' tool turns this grammar into an efficient parser that follows the-shift-reduce parsing model. There's a parse stack that contains items parsed so-far (both terminals and non-terminals). Every next token produced by the lexer-results in one of two actions:--  SHIFT:    push the token onto the parse stack--  REDUCE:   pop a few items off the parse stack and combine them-            with a function (reduction rule)--However, sometimes it's unclear which of the two actions to take.-Consider this code example:--    if x then y else f z--There are two ways to parse it:--    (if x then y else f) z-    if x then y else (f z)--How is this determined? At some point, the parser gets to the following state:--  parse stack:  'if' exp 'then' exp 'else' "f"-  next token:   "z"--Scenario A (simplified):--  1. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp-             next token:  "z"-        (Note that "f" reduced to exp here)--  2. REDUCE, parse stack: exp-             next token:  "z"--  3. SHIFT,  parse stack: exp "z"-             next token:  ...--  4. REDUCE, parse stack: exp-             next token:  ...--  This way we get:  (if x then y else f) z--Scenario B (simplified):--  1. SHIFT,  parse stack: 'if' exp 'then' exp 'else' "f" "z"-             next token:  ...--  2. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp-             next token:  ...--  3. REDUCE, parse stack: exp-             next token:  ...--  This way we get:  if x then y else (f z)--The end result is determined by the chosen action. When Happy detects this, it-reports a shift/reduce conflict. At the top of the file, we have the following-directive:--  %expect 0--It means that we expect no unresolved shift/reduce conflicts in this grammar.-If you modify the grammar and get shift/reduce conflicts, follow the steps-below to resolve them.--STEP ONE-  is to figure out what causes the conflict.-  That's where the -i flag comes in handy:--      happy -agc --strict compiler/GHC/Parser.y -idetailed-info--  By analysing the output of this command, in a new file `detailed-info`, you-  can figure out which reduction rule causes the issue. At the top of the-  generated report, you will see a line like this:--      state 147 contains 67 shift/reduce conflicts.--  Scroll down to section State 147 (in your case it could be a different-  state). The start of the section lists the reduction rules that can fire-  and shows their context:--        exp10 -> fexp .                 (rule 492)-        fexp -> fexp . aexp             (rule 498)-        fexp -> fexp . PREFIX_AT atype  (rule 499)--  And then, for every token, it tells you the parsing action:--        ']'            reduce using rule 492-        '::'           reduce using rule 492-        '('            shift, and enter state 178-        QVARID         shift, and enter state 44-        DO             shift, and enter state 182-        ...--  But if you look closer, some of these tokens also have another parsing action-  in parentheses:--        QVARID    shift, and enter state 44-                   (reduce using rule 492)--  That's how you know rule 492 is causing trouble.-  Scroll back to the top to see what this rule is:--        -----------------------------------        Grammar-        -----------------------------------        ...-        ...-        exp10 -> fexp                (492)-        optSemi -> ';'               (493)-        ...-        ...--  Hence the shift/reduce conflict is caused by this parser production:--        exp10 :: { ECP }-                : '-' fexp    { ... }-                | fexp        { ... }    -- problematic rule--STEP TWO-  is to mark the problematic rule with the %shift pragma. This signals to-  'happy' that any shift/reduce conflicts involving this rule must be resolved-  in favor of a shift. There's currently no dedicated pragma to resolve in-  favor of the reduce.--STEP THREE-  is to add a dedicated Note for this specific conflict, as is done for all-  other conflicts below.--}--{- Note [%shift: rule_activation -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule -> STRING . rule_activation rule_foralls infixexp '=' exp--Example:-    {-# RULES "name" [0] f = rhs #-}--Ambiguity:-    If we reduced, then we'd get an empty activation rule, and [0] would be-    parsed as part of the left-hand side expression.--    We shift, so [0] is parsed as an activation rule.--}--{- Note [%shift: rule_foralls -> 'forall' rule_vars '.']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'-    rule_foralls -> 'forall' rule_vars '.' .--Example:-    {-# RULES "name" forall a1. forall a2. lhs = rhs #-}--Ambiguity:-    Same as in Note [%shift: rule_foralls -> {- empty -}]-    but for the second 'forall'.--}--{- Note [%shift: rule_foralls -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule -> STRING rule_activation . rule_foralls infixexp '=' exp--Example:-    {-# RULES "name" forall a1. lhs = rhs #-}--Ambiguity:-    If we reduced, then we would get an empty rule_foralls; the 'forall', being-    a valid term-level identifier, would be parsed as part of the left-hand-    side expression.--    We shift, so the 'forall' is parsed as part of rule_foralls.--}--{- Note [%shift: type -> btype]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    context -> btype .-    type -> btype .-    type -> btype . '->' ctype-    type -> btype . '->.' ctype--Example:-    a :: Maybe Integer -> Bool--Ambiguity:-    If we reduced, we would get:   (a :: Maybe Integer) -> Bool-    We shift to get this instead:  a :: (Maybe Integer -> Bool)--}--{- Note [%shift: infixtype -> ftype]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    infixtype -> ftype .-    infixtype -> ftype . tyop infixtype-    ftype -> ftype . tyarg-    ftype -> ftype . PREFIX_AT tyarg--Example:-    a :: Maybe Integer--Ambiguity:-    If we reduced, we would get:    (a :: Maybe) Integer-    We shift to get this instead:   a :: (Maybe Integer)--}--{- Note [%shift: atype -> tyvar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    atype -> tyvar .-    tv_bndr_no_braces -> '(' tyvar . '::' kind ')'--Example:-    class C a where type D a = (a :: Type ...--Ambiguity:-    If we reduced, we could specify a default for an associated type like this:--      class C a where type D a-                      type D a = (a :: Type)--    But we shift in order to allow injectivity signatures like this:--      class C a where type D a = (r :: Type) | r -> a--}--{- Note [%shift: exp -> infixexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp -> infixexp . '::' sigtype-    exp -> infixexp . '-<' exp-    exp -> infixexp . '>-' exp-    exp -> infixexp . '-<<' exp-    exp -> infixexp . '>>-' exp-    exp -> infixexp .-    infixexp -> infixexp . qop exp10p--Examples:-    1) if x then y else z -< e-    2) if x then y else z :: T-    3) if x then y else z + 1   -- (NB: '+' is in VARSYM)--Ambiguity:-    If we reduced, we would get:--      1) (if x then y else z) -< e-      2) (if x then y else z) :: T-      3) (if x then y else z) + 1--    We shift to get this instead:--      1) if x then y else (z -< e)-      2) if x then y else (z :: T)-      3) if x then y else (z + 1)--}--{- Note [%shift: exp10 -> '-' fexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp10 -> '-' fexp .-    fexp -> fexp . aexp-    fexp -> fexp . PREFIX_AT atype--Examples & Ambiguity:-    Same as in Note [%shift: exp10 -> fexp],-    but with a '-' in front.--}--{- Note [%shift: exp10 -> fexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp10 -> fexp .-    fexp -> fexp . aexp-    fexp -> fexp . PREFIX_AT atype--Examples:-    1) if x then y else f z-    2) if x then y else f @z--Ambiguity:-    If we reduced, we would get:--      1) (if x then y else f) z-      2) (if x then y else f) @z--    We shift to get this instead:--      1) if x then y else (f z)-      2) if x then y else (f @z)--}--{- Note [%shift: aexp2 -> ipvar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    aexp2 -> ipvar .-    dbind -> ipvar . '=' exp--Example:-    let ?x = ...--Ambiguity:-    If we reduced, ?x would be parsed as the LHS of a normal binding,-    eventually producing an error.--    We shift, so it is parsed as the LHS of an implicit binding.--}--{- Note [%shift: aexp2 -> TH_TY_QUOTE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    aexp2 -> TH_TY_QUOTE . tyvar-    aexp2 -> TH_TY_QUOTE . gtycon-    aexp2 -> TH_TY_QUOTE .--Examples:-    1) x = ''-    2) x = ''a-    3) x = ''T--Ambiguity:-    If we reduced, the '' would result in reportEmptyDoubleQuotes even when-    followed by a type variable or a type constructor. But the only reason-    this reduction rule exists is to improve error messages.--    Naturally, we shift instead, so that ''a and ''T work as expected.--}--{- Note [%shift: tup_tail -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    tup_exprs -> commas . tup_tail-    sysdcon_nolist -> '(' commas . ')'-    sysdcon_nolist -> '(#' commas . '#)'-    commas -> commas . ','--Example:-    (,,)--Ambiguity:-    A tuple section with no components is indistinguishable from the Haskell98-    data constructor for a tuple.--    If we reduced, (,,) would be parsed as a tuple section.-    We shift, so (,,) is parsed as a data constructor.--    This is preferable because we want to accept (,,) without -XTupleSections.-    See also Note [ExplicitTuple] in GHC.Hs.Expr.--}--{- Note [%shift: qtyconop -> qtyconsym]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    oqtycon -> '(' qtyconsym . ')'-    qtyconop -> qtyconsym .--Example:-    foo :: (:%)--Ambiguity:-    If we reduced, (:%) would be parsed as a parenthesized infix type-    expression without arguments, resulting in the 'failOpFewArgs' error.--    We shift, so it is parsed as a type constructor.--}--{- Note [%shift: special_id -> 'group']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    transformqual -> 'then' 'group' . 'using' exp-    transformqual -> 'then' 'group' . 'by' exp 'using' exp-    special_id -> 'group' .--Example:-    [ ... | then group by dept using groupWith-          , then take 5 ]--Ambiguity:-    If we reduced, 'group' would be parsed as a term-level identifier, just as-    'take' in the other clause.--    We shift, so it is parsed as part of the 'group by' clause introduced by-    the -XTransformListComp extension.--}--{- Note [%shift: activation -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'-    activation -> {- empty -}-    activation -> explicit_activation--Example:--    {-# INLINE [0] Something #-}--Ambiguity:-    We don't know whether the '[' is the start of the activation or the beginning-    of the [] data constructor.-    We parse this as having '[0]' activation for inlining 'Something', rather than-    empty activation and inlining '[0] Something'.--}--{- Note [Parser API Annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A lot of the productions are now cluttered with calls to-aa,am,acs,acsA etc.--These are helper functions to make sure that the locations of the-various keywords such as do / let / in are captured for use by tools-that want to do source to source conversions, such as refactorers or-structured editors.--The helper functions are defined at the bottom of this file.--See-  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and-  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations-for some background.---}--{- Note [Parsing lists]-~~~~~~~~~~~~~~~~~~~~~~~-You might be wondering why we spend so much effort encoding our lists this-way:--importdecls-        : importdecls ';' importdecl-        | importdecls ';'-        | importdecl-        | {- empty -}--This might seem like an awfully roundabout way to declare a list; plus, to add-insult to injury you have to reverse the results at the end.  The answer is that-left recursion prevents us from running out of stack space when parsing long-sequences.  See: https://www.haskell.org/happy/doc/html/sec-sequences.html for-more guidance.--By adding/removing branches, you can affect what lists are accepted.  Here-are the most common patterns, rewritten as regular expressions for clarity:--    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)-    xs : xs ';' x-       | xs ';'-       | x-       | {- empty -}--    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)-    xs : xs ';' x-       | xs ';'-       | x--    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)-    alts : alts1-         | ';' alts-    alts1 : alts1 ';' alt-          | alts1 ';'-          | alt--    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)-    xs : x-       | x ',' xs--}--%token- '_'            { L _ ITunderscore }            -- Haskell keywords- 'as'           { L _ ITas }- 'case'         { L _ ITcase }- 'class'        { L _ ITclass }- 'data'         { L _ ITdata }- 'default'      { L _ ITdefault }- 'deriving'     { L _ ITderiving }- 'else'         { L _ ITelse }- 'hiding'       { L _ IThiding }- 'if'           { L _ ITif }- 'import'       { L _ ITimport }- 'in'           { L _ ITin }- 'infix'        { L _ ITinfix }- 'infixl'       { L _ ITinfixl }- 'infixr'       { L _ ITinfixr }- 'instance'     { L _ ITinstance }- 'let'          { L _ ITlet }- 'module'       { L _ ITmodule }- 'newtype'      { L _ ITnewtype }- 'of'           { L _ ITof }- 'qualified'    { L _ ITqualified }- 'then'         { L _ ITthen }- 'type'         { L _ ITtype }- 'where'        { L _ ITwhere }-- 'forall'       { L _ (ITforall _) }                -- GHC extension keywords- 'foreign'      { L _ ITforeign }- 'export'       { L _ ITexport }- 'label'        { L _ ITlabel }- 'dynamic'      { L _ ITdynamic }- 'safe'         { L _ ITsafe }- 'interruptible' { L _ ITinterruptible }- 'unsafe'       { L _ ITunsafe }- 'family'       { L _ ITfamily }- 'role'         { L _ ITrole }- 'stdcall'      { L _ ITstdcallconv }- 'ccall'        { L _ ITccallconv }- 'capi'         { L _ ITcapiconv }- 'prim'         { L _ ITprimcallconv }- 'javascript'   { L _ ITjavascriptcallconv }- 'proc'         { L _ ITproc }          -- for arrow notation extension- 'rec'          { L _ ITrec }           -- for arrow notation extension- 'group'    { L _ ITgroup }     -- for list transform extension- 'by'       { L _ ITby }        -- for list transform extension- 'using'    { L _ ITusing }     -- for list transform extension- 'pattern'      { L _ ITpattern } -- for pattern synonyms- 'static'       { L _ ITstatic }  -- for static pointers extension- 'stock'        { L _ ITstock }    -- for DerivingStrategies extension- 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension- 'via'          { L _ ITvia }      -- for DerivingStrategies extension-- 'unit'         { L _ ITunit }- 'signature'    { L _ ITsignature }- 'dependency'   { L _ ITdependency }-- '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE- '{-# OPAQUE'             { L _ (ITopaque_prag _) }- '{-# SPECIALISE'         { L _ (ITspec_prag _) }- '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }- '{-# SOURCE'             { L _ (ITsource_prag _) }- '{-# RULES'              { L _ (ITrules_prag _) }- '{-# SCC'                { L _ (ITscc_prag _)}- '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }- '{-# WARNING'            { L _ (ITwarning_prag _) }- '{-# UNPACK'             { L _ (ITunpack_prag _) }- '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }- '{-# ANN'                { L _ (ITann_prag _) }- '{-# MINIMAL'            { L _ (ITminimal_prag _) }- '{-# CTYPE'              { L _ (ITctype _) }- '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }- '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }- '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }- '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }- '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }- '#-}'                    { L _ ITclose_prag }-- '..'           { L _ ITdotdot }                        -- reserved symbols- ':'            { L _ ITcolon }- '::'           { L _ (ITdcolon _) }- '='            { L _ ITequal }- '\\'           { L _ ITlam }- 'lcase'        { L _ ITlcase }- 'lcases'       { L _ ITlcases }- '|'            { L _ ITvbar }- '<-'           { L _ (ITlarrow _) }- '->'           { L _ (ITrarrow _) }- '->.'          { L _ ITlolly }- TIGHT_INFIX_AT { L _ ITat }- '=>'           { L _ (ITdarrow _) }- '-'            { L _ ITminus }- PREFIX_TILDE   { L _ ITtilde }- PREFIX_BANG    { L _ ITbang }- PREFIX_MINUS   { L _ ITprefixminus }- '*'            { L _ (ITstar _) }- '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation- '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation- '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation- '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation- '.'            { L _ ITdot }- PREFIX_PROJ    { L _ (ITproj True) }               -- RecordDotSyntax- TIGHT_INFIX_PROJ { L _ (ITproj False) }            -- RecordDotSyntax- PREFIX_AT      { L _ ITtypeApp }- PREFIX_PERCENT { L _ ITpercent }                   -- for linear types-- '{'            { L _ ITocurly }                        -- special symbols- '}'            { L _ ITccurly }- vocurly        { L _ ITvocurly } -- virtual open curly (from layout)- vccurly        { L _ ITvccurly } -- virtual close curly (from layout)- '['            { L _ ITobrack }- ']'            { L _ ITcbrack }- '('            { L _ IToparen }- ')'            { L _ ITcparen }- '(#'           { L _ IToubxparen }- '#)'           { L _ ITcubxparen }- '(|'           { L _ (IToparenbar _) }- '|)'           { L _ (ITcparenbar _) }- ';'            { L _ ITsemi }- ','            { L _ ITcomma }- '`'            { L _ ITbackquote }- SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x-- VARID          { L _ (ITvarid    _) }          -- identifiers- CONID          { L _ (ITconid    _) }- VARSYM         { L _ (ITvarsym   _) }- CONSYM         { L _ (ITconsym   _) }- QVARID         { L _ (ITqvarid   _) }- QCONID         { L _ (ITqconid   _) }- QVARSYM        { L _ (ITqvarsym  _) }- QCONSYM        { L _ (ITqconsym  _) }--- -- QualifiedDo- DO             { L _ (ITdo  _) }- MDO            { L _ (ITmdo _) }-- IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension- LABELVARID     { L _ (ITlabelvarid _ _) }-- CHAR           { L _ (ITchar   _ _) }- STRING         { L _ (ITstring _ _) }- INTEGER        { L _ (ITinteger _) }- RATIONAL       { L _ (ITrational _) }-- PRIMCHAR       { L _ (ITprimchar   _ _) }- PRIMSTRING     { L _ (ITprimstring _ _) }- PRIMINTEGER    { L _ (ITprimint    _ _) }- PRIMWORD       { L _ (ITprimword   _ _) }- PRIMFLOAT      { L _ (ITprimfloat  _) }- PRIMDOUBLE     { L _ (ITprimdouble _) }---- Template Haskell-'[|'            { L _ (ITopenExpQuote _ _) }-'[p|'           { L _ ITopenPatQuote  }-'[t|'           { L _ ITopenTypQuote  }-'[d|'           { L _ ITopenDecQuote  }-'|]'            { L _ (ITcloseQuote _) }-'[||'           { L _ (ITopenTExpQuote _) }-'||]'           { L _ ITcloseTExpQuote  }-PREFIX_DOLLAR   { L _ ITdollar }-PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }-TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T-TH_QUASIQUOTE   { L _ (ITquasiQuote _) }-TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }--%monad { P } { >>= } { return }-%lexer { (lexer True) } { L _ ITeof }-  -- Replace 'lexer' above with 'lexerDbg'-  -- to dump the tokens fed to the parser.-%tokentype { (Located Token) }---- Exported parsers-%name parseModuleNoHaddock module-%name parseSignature signature-%name parseImport importdecl-%name parseStatement e_stmt-%name parseDeclaration topdecl-%name parseExpression exp-%name parsePattern pat-%name parseTypeSignature sigdecl-%name parseStmt   maybe_stmt-%name parseIdentifier  identifier-%name parseType ktype-%name parseBackpack backpack-%partial parseHeader header-%%---------------------------------------------------------------------------------- Identifiers; one of the entry points-identifier :: { LocatedN RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }-        | qvarop                        { $1 }-        | qconop                        { $1 }-    | '(' '->' ')'      {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-    | '->'              {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnnRArrow (glAA $1) []) }---------------------------------------------------------------------------------- Backpack stuff--backpack :: { [LHsUnit PackageName] }-         : implicit_top units close { fromOL $2 }-         | '{' units '}'            { fromOL $2 }--units :: { OrdList (LHsUnit PackageName) }-         : units ';' unit { $1 `appOL` unitOL $3 }-         | units ';'      { $1 }-         | unit           { unitOL $1 }--unit :: { LHsUnit PackageName }-        : 'unit' pkgname 'where' unitbody-            { sL1 $1 $ HsUnit { hsunitName = $2-                              , hsunitBody = fromOL $4 } }--unitid :: { LHsUnitId PackageName }-        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }-        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }--msubsts :: { OrdList (LHsModuleSubst PackageName) }-        : msubsts ',' msubst { $1 `appOL` unitOL $3 }-        | msubsts ','        { $1 }-        | msubst             { unitOL $1 }--msubst :: { LHsModuleSubst PackageName }-        : modid '=' moduleid { sLL (reLoc $1) $> $ (reLoc $1, $3) }-        | modid VARSYM modid VARSYM { sLL (reLoc $1) $> $ (reLoc $1, sLL $2 $> $ HsModuleVar (reLoc $3)) }--moduleid :: { LHsModuleId PackageName }-          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar (reLoc $2) }-          | unitid ':' modid    { sLL $1 (reLoc $>) $ HsModuleId $1 (reLoc $3) }--pkgname :: { Located PackageName }-        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }-        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }--litpkgname_segment :: { Located FastString }-        : VARID  { sL1 $1 $ getVARID $1 }-        | CONID  { sL1 $1 $ getCONID $1 }-        | special_id { $1 }---- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.--- See Note [Minus tokens] in GHC.Parser.Lexer-HYPHEN :: { [AddEpAnn] }-      : '-'          { [mj AnnMinus $1 ] }-      | PREFIX_MINUS { [mj AnnMinus $1 ] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "-")-                   then return [mj AnnMinus $1]-                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ PsErrExpectedHyphen-                           ; return [] } }---litpkgname :: { Located FastString }-        : litpkgname_segment { $1 }-        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.-        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] }--mayberns :: { Maybe [LRenaming] }-        : {- empty -} { Nothing }-        | '(' rns ')' { Just (fromOL $2) }--rns :: { OrdList LRenaming }-        : rns ',' rn { $1 `appOL` unitOL $3 }-        | rns ','    { $1 }-        | rn         { unitOL $1 }--rn :: { LRenaming }-        : modid 'as' modid { sLL (reLoc $1) (reLoc $>) $ Renaming (reLoc $1) (Just (reLoc $3)) }-        | modid            { sL1 (reLoc $1)            $ Renaming (reLoc $1) Nothing }--unitbody :: { OrdList (LHsUnitDecl PackageName) }-        : '{'     unitdecls '}'   { $2 }-        | vocurly unitdecls close { $2 }--unitdecls :: { OrdList (LHsUnitDecl PackageName) }-        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }-        | unitdecls ';'         { $1 }-        | unitdecl              { unitOL $1 }--unitdecl :: { LHsUnitDecl PackageName }-        : 'module' maybe_src modid maybemodwarning maybeexports 'where' body-             -- XXX not accurate-             { sL1 $1 $ DeclD-                 (case snd $2 of-                   NotBoot -> HsSrcFile-                   IsBoot  -> HsBootFile)-                 (reLoc $3)-                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) }-        | 'signature' modid maybemodwarning maybeexports 'where' body-             { sL1 $1 $ DeclD-                 HsigFile-                 (reLoc $2)-                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) }-        | 'dependency' unitid mayberns-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2-                                              , idModRenaming = $3-                                              , idSignatureInclude = False }) }-        | 'dependency' 'signature' unitid-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3-                                              , idModRenaming = Nothing-                                              , idSignatureInclude = True }) }---------------------------------------------------------------------------------- Module Header---- The place for module deprecation is really too restrictive, but if it--- was allowed at its natural place just before 'module', we get an ugly--- s/r conflict with the second alternative. Another solution would be the--- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,--- either, and DEPRECATED is only expected to be used by people who really--- know what they are doing. :-)--signature :: { Located (HsModule GhcPs) }-       : 'signature' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                acs (\cs-> (L loc (HsModule (XModulePs-                                               (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)-                                               (thdOf3 $6) $3 Nothing)-                                            (Just $2) $4 (fst $ sndOf3 $6)-                                            (snd $ sndOf3 $6)))-                    ) }--module :: { Located (HsModule GhcPs) }-       : 'module' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                acsFinal (\cs -> (L loc (HsModule (XModulePs-                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)-                                                     (thdOf3 $6) $3 Nothing)-                                                  (Just $2) $4 (fst $ sndOf3 $6)-                                                  (snd $ sndOf3 $6))-                    )) }-        | body2-                {% fileSrcSpan >>= \ loc ->-                   acsFinal (\cs -> (L loc (HsModule (XModulePs-                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)-                                                        (thdOf3 $1) Nothing Nothing)-                                                     Nothing Nothing-                                                     (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }--missing_module_keyword :: { () }-        : {- empty -}                           {% pushModuleContext }--implicit_top :: { () }-        : {- empty -}                           {% pushModuleContext }--maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }-    : '{-# DEPRECATED' strings '#-}'-                      {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))-                              (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }-    | '{-# WARNING' strings '#-}'-                         {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))-                                 (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}-    |  {- empty -}                  { Nothing }--body    :: { (AnnList-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo GhcPs) }-        :  '{'            top '}'      { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)-                                         , snd $2, explicitBraces $1 $3) }-        |      vocurly    top close    { (AnnList Nothing Nothing Nothing [] (fst $2)-                                         , snd $2, VirtualBraces (getVOCURLY $1)) }--body2   :: { (AnnList-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo GhcPs) }-        :  '{' top '}'                          { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)-                                                  , snd $2, explicitBraces $1 $3) }-        |  missing_module_keyword top close     { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) }---top     :: { ([TrailingAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }-        : semis top1                            { (reverse $1, $2) }--top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }-        : importdecls_semi topdecls_cs_semi        { (reverse $1, cvTopDecls $2) }-        | importdecls_semi topdecls_cs             { (reverse $1, cvTopDecls $2) }-        | importdecls                              { (reverse $1, []) }---------------------------------------------------------------------------------- Module declaration & imports only--header  :: { Located (HsModule GhcPs) }-        : 'module' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   acs (\cs -> (L loc (HsModule (XModulePs-                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)-                                                   NoLayoutInfo $3 Nothing)-                                                (Just $2) $4 $6 []-                          ))) }-        | 'signature' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   acs (\cs -> (L loc (HsModule (XModulePs-                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)-                                                   NoLayoutInfo $3 Nothing)-                                                (Just $2) $4 $6 []-                          ))) }-        | header_body2-                {% fileSrcSpan >>= \ loc ->-                   return (L loc (HsModule (XModulePs noAnn NoLayoutInfo Nothing Nothing) Nothing Nothing $1 [])) }--header_body :: { [LImportDecl GhcPs] }-        :  '{'            header_top            { $2 }-        |      vocurly    header_top            { $2 }--header_body2 :: { [LImportDecl GhcPs] }-        :  '{' header_top                       { $2 }-        |  missing_module_keyword header_top    { $2 }--header_top :: { [LImportDecl GhcPs] }-        :  semis header_top_importdecls         { $2 }--header_top_importdecls :: { [LImportDecl GhcPs] }-        :  importdecls_semi                     { $1 }-        |  importdecls                          { $1 }---------------------------------------------------------------------------------- The Export List--maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }-        :  '(' exportlist ')'       {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2))-                                        (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }-        |  {- empty -}              { Nothing }--exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }-        : exportlist1     { ([], $1) }-        | {- empty -}     { ([], nilOL) }--        -- trailing comma:-        | exportlist1 ',' {% case $1 of-                               SnocOL hs t -> do-                                 t' <- addTrailingCommaA t (gl $2)-                                 return ([], snocOL hs t')}-        | ','             { ([mj AnnComma $1], nilOL) }--exportlist1 :: { OrdList (LIE GhcPs) }-        : exportlist1 ',' export-                          {% let ls = $1-                             in if isNilOL ls-                                  then return (ls `appOL` $3)-                                  else case ls of-                                         SnocOL hs t -> do-                                           t' <- addTrailingCommaA t (gl $2)-                                           return (snocOL hs t' `appOL` $3)}-        | export          { $1 }---   -- No longer allow things like [] and (,,,) to be exported-   -- They are built in syntax, always available-export  :: { OrdList (LIE GhcPs) }-        : qcname_ext export_subspec  {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2)-                                          >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) }-        |  'module' modid            {% fmap (unitOL . reLocA) (acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (EpAnn (glR $1) [mj AnnModule $1] cs) $2))) }-        |  'pattern' qcon            { unitOL (reLocA (sLL $1 (reLocN $>)-                                              (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2))))) }--export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }-        : {- empty -}             { sL0 ([],ImpExpAbs) }-        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))-                                      >>= \(as,ie) -> return $ sLL $1 $>-                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }--qcnames :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }-  : {- empty -}                   { ([],[]) }-  | qcnames1                      { $1 }--qcnames1 :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }     -- A reversed list-        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (snd $1) of-                                                    (l@(L la ImpExpQcWildcard):t) ->-                                                       do { l' <- addTrailingCommaA l (gl $2)-                                                          ; return ([mj AnnDotdot (reLoc l),-                                                                     mj AnnComma $2]-                                                                   ,(snd (unLoc $3)  : l' : t)) }-                                                    (l:t) ->-                                                       do { l' <- addTrailingCommaA l (gl $2)-                                                          ; return (fst $1 ++ fst (unLoc $3)-                                                                   , snd (unLoc $3) : l' : t)} }--        -- Annotations re-added in mkImpExpSubSpec-        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }---- Variable, data constructor or wildcard--- or tagged type constructor-qcname_ext_w_wildcard :: { Located ([AddEpAnn], LocatedA ImpExpQcSpec) }-        :  qcname_ext               { sL1A $1 ([],$1) }-        |  '..'                     { sL1  $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard)  }--qcname_ext :: { LocatedA ImpExpQcSpec }-        :  qcname                   { reLocA $ sL1N $1 (ImpExpQcName $1) }-        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2-                                          ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glAA $1) n) }}--qcname  :: { LocatedN RdrName }  -- Variable or type constructor-        :  qvar                 { $1 } -- Things which look like functions-                                       -- Note: This includes record selectors but-                                       -- also (-.->), see #11432-        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]---------------------------------------------------------------------------------- Import Declarations---- importdecls and topdecls must contain at least one declaration;--- top handles the fact that these may be optional.---- One or more semicolons-semis1  :: { Located [TrailingAnn] }-semis1  : semis1 ';'  { sLL $1 $> $ if isZeroWidthSpan (gl $2) then (unLoc $1) else (AddSemiAnn (glAA $2) : (unLoc $1)) }-        | ';'         { sL1 $1 $ msemi $1 }---- Zero or more semicolons-semis   :: { [TrailingAnn] }-semis   : semis ';'   { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }-        | {- empty -} { [] }---- No trailing semicolons, non-empty-importdecls :: { [LImportDecl GhcPs] }-importdecls-        : importdecls_semi importdecl-                                { $2 : $1 }---- May have trailing semicolons, can be empty-importdecls_semi :: { [LImportDecl GhcPs] }-importdecls_semi-        : importdecls_semi importdecl semis1-                                {% do { i <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                      ; return (i : $1)} }-        | {- empty -}           { [] }--importdecl :: { LImportDecl GhcPs }-        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec-                {% do {-                  ; let { ; mPreQual = unLoc $4-                          ; mPostQual = unLoc $7 }-                  ; checkImportDecl mPreQual mPostQual-                  ; let anns-                         = EpAnnImportDecl-                             { importDeclAnnImport    = glAA $1-                             , importDeclAnnPragma    = fst $ fst $2-                             , importDeclAnnSafe      = fst $3-                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual-                             , importDeclAnnPackage   = fst $5-                             , importDeclAnnAs        = fst $8-                             }-                  ; fmap reLocA $ acs (\cs -> L (comb5 $1 (reLoc $6) $7 (snd $8) $9) $-                      ImportDecl { ideclExt = XImportDeclPass (EpAnn (glR $1) 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 })-                  }-                }---maybe_src :: { ((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface) }-        : '{-# SOURCE' '#-}'        { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1)-                                      , IsBoot) }-        | {- empty -}               { ((Nothing,NoSourceText),NotBoot) }--maybe_safe :: { (Maybe EpaLocation,Bool) }-        : 'safe'                                { (Just (glAA $1),True) }-        | {- empty -}                           { (Nothing,      False) }--maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }-        : STRING  {% do { let { pkgFS = getSTRING $1 }-                        ; unless (looksLikePackageName (unpackFS pkgFS)) $-                             addError $ mkPlainErrorMsgEnvelope (getLoc $1) $-                               (PsErrInvalidPackageName pkgFS)-                        ; return (Just (glAA $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }-        | {- empty -}                           { (Nothing,NoRawPkgQual) }--optqualified :: { Located (Maybe EpaLocation) }-        : 'qualified'                           { sL1 $1 (Just (glAA $1)) }-        | {- empty -}                           { noLoc Nothing }--maybeas :: { (Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))) }-        : 'as' modid                           { (Just (glAA $1)-                                                 ,sLL $1 (reLoc $>) (Just $2)) }-        | {- empty -}                          { (Nothing,noLoc Nothing) }--maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])) }-        : impspec                  {% let (b, ie) = unLoc $1 in-                                       checkImportSpec ie-                                        >>= \checkedIe ->-                                          return (L (gl $1) (Just (b, checkedIe)))  }-        | {- empty -}              { noLoc Nothing }--impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) }-        :  '(' exportlist ')'               {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)-                                                               (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])-                                                  ; return $ sLL $1 $> (Exactly, es)} }-        |  'hiding' '(' exportlist ')'      {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)-                                                               (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])-                                                  ; return $ sLL $1 $> (EverythingBut, es)} }---------------------------------------------------------------------------------- Fixity Declarations--prec    :: { Maybe (Located (SourceText,Int)) }-        : {- empty -}           { Nothing }-        | INTEGER-                 { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }--infix   :: { Located FixityDirection }-        : 'infix'                               { sL1 $1 InfixN  }-        | 'infixl'                              { sL1 $1 InfixL  }-        | 'infixr'                              { sL1 $1 InfixR }--ops     :: { Located (OrdList (LocatedN RdrName)) }-        : ops ',' op       {% case (unLoc $1) of-                                SnocOL hs t -> do-                                  t' <- addTrailingCommaN t (gl $2)-                                  return (sLL $1 (reLocN $>) (snocOL hs t' `appOL` unitOL $3)) }-        | op               { sL1N $1 (unitOL $1) }---------------------------------------------------------------------------------- Top-Level Declarations---- No trailing semicolons, non-empty-topdecls :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                             ; return ($1 `snocOL` t) }}-        | {- empty -}                  { nilOL }----------------------------------------------------------------------------------- Each topdecl accumulates prior comments--- No trailing semicolons, non-empty-topdecls_cs :: { OrdList (LHsDecl GhcPs) }-        : topdecls_cs_semi topdecl_cs        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                                   ; return ($1 `snocOL` t) }}-        | {- empty -}                  { nilOL }---- Each topdecl accumulates prior comments-topdecl_cs :: { LHsDecl GhcPs }-topdecl_cs : topdecl {% commentsPA $1 }--------------------------------------------------------------------------------topdecl :: { LHsDecl GhcPs }-        : cl_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | ty_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | standalone_kind_sig                   { sL1 $1 (KindSigD noExtField (unLoc $1)) }-        | inst_decl                             { sL1 $1 (InstD noExtField (unLoc $1)) }-        | stand_alone_deriving                  { sL1 $1 (DerivD noExtField (unLoc $1)) }-        | role_annot                            { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }-        | 'default' '(' comma_types0 ')'        {% acsA (\cs -> sLL $1 $>-                                                    (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }-        | 'foreign' fdecl                       {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }-        | '{-# DEPRECATED' deprecations '#-}'   {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }-        | '{-# WARNING' warnings '#-}'          {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) }-        | '{-# RULES' rules '#-}'               {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glR $1) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) }-        | annotation { $1 }-        | decl_no_th                            { $1 }--        -- Template Haskell Extension-        -- The $(..) form is one possible form of infixexp-        -- but we treat an arbitrary expression just as if-        -- it had a $(..) wrapped around it-        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->-                                                    do { d <- mkSpliceDecl $1-                                                       ; commentsPA d }}---- Type classes----cl_decl :: { LTyClDecl GhcPs }-        : 'class' tycl_hdr fds where_cls-                {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))-                        (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }---- Type declarations (toplevel)----ty_decl :: { LTyClDecl GhcPs }-           -- ordinary type synonyms-        : 'type' type '=' ktype-                -- Note ktype, not sigtype, on the right of '='-                -- We allow an explicit for-all but we don't insert one-                -- in   type Foo a = (b,b)-                -- Instead we just say b is out of scope-                ---                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% mkTySynonym (comb2A $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }--           -- type family declarations-        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info-                          where_type_family-                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% mkFamDecl (comb5 $1 (reLoc $3) $4 $5 $6) (snd $ unLoc $6) TopLevel $3-                                   (snd $ unLoc $4) (snd $ unLoc $5)-                           (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)-                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }--          -- ordinary data type or newtype declaration-        | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings-                {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3-                           Nothing (reverse (snd $ unLoc $4))-                                   (fmap reverse $5)-                           ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)) }-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty--          -- ordinary GADT declaration-        | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3-                            (snd $ unLoc $4) (snd $ unLoc $5)-                            (fmap reverse $6)-                            ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty--          -- data/newtype family-        | 'data' 'family' type opt_datafam_kind_sig-                {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3-                                   (snd $ unLoc $4) Nothing-                          (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }---- standalone kind signature-standalone_kind_sig :: { LStandaloneKindSig GhcPs }-  : 'type' sks_vars '::' sigktype-      {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4-               [mj AnnType $1,mu AnnDcolon $3]}---- See also: sig_vars-sks_vars :: { Located [LocatedN RdrName] }  -- Returned in reverse order-  : sks_vars ',' oqtycon-      {% case unLoc $1 of-           (h:t) -> do-             h' <- addTrailingCommaN h (gl $2)-             return (sLL $1 (reLocN $>) ($3 : h' : t)) }-  | oqtycon { sL1N $1 [$1] }--inst_decl :: { LInstDecl GhcPs }-        : 'instance' overlap_pragma inst_type where_inst-       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)-             ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4))-             ; let cid cs = ClsInstDecl-                                     { cid_ext = (EpAnn (glR $1) anns cs, NoAnnSortKey)-                                     , cid_poly_ty = $3, cid_binds = binds-                                     , cid_sigs = mkClassOpSigs sigs-                                     , cid_tyfam_insts = ats-                                     , cid_overlap_mode = $2-                                     , cid_datafam_insts = adts }-             ; acsA (\cs -> L (comb3 $1 (reLoc $3) $4)-                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))-                   } }--           -- type instance declarations-        | 'type' 'instance' ty_fam_inst_eqn-                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)-                        (mj AnnType $1:mj AnnInstance $2:[]) }--          -- data/newtype instance declaration-        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs-                          maybe_derivings-            {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)-                                      Nothing (reverse (snd  $ unLoc $5))-                                              (fmap reverse $6)-                      ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }--          -- GADT instance declaration-        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)-                                   (snd $ unLoc $5) (snd $ unLoc $6)-                                   (fmap reverse $7)-                     ((fst $ unLoc $1):mj AnnInstance $2-                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }--overlap_pragma :: { Maybe (LocatedP OverlapMode) }-  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | {- empty -}                 { Nothing }--deriv_strategy_no_via :: { LDerivStrategy GhcPs }-  : 'stock'                     {% acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }-  | 'anyclass'                  {% acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }-  | 'newtype'                   {% acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }--deriv_strategy_via :: { LDerivStrategy GhcPs }-  : 'via' sigktype          {% acsA (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)-                                                                           $2))) }--deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }-  : 'stock'                     {% fmap Just $ acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }-  | 'anyclass'                  {% fmap Just $ acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }-  | 'newtype'                   {% fmap Just $ acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }-  | deriv_strategy_via          { Just $1 }-  | {- empty -}                 { Nothing }---- Injective type families--opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }-        : {- empty -}               { noLoc ([], Nothing) }-        | '|' injectivity_cond      { sLL $1 (reLoc $>) ([mj AnnVbar $1]-                                                , Just ($2)) }--injectivity_cond :: { LInjectivityAnn GhcPs }-        : tyvarid '->' inj_varids-           {% acsA (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }--inj_varids :: { Located [LocatedN RdrName] }-        : inj_varids tyvarid  { sLL $1 (reLocN $>) ($2 : unLoc $1) }-        | tyvarid             { sL1N  $1 [$1]               }---- Closed type families--where_type_family :: { Located ([AddEpAnn],FamilyInfo GhcPs) }-        : {- empty -}                      { noLoc ([],OpenTypeFamily) }-        | 'where' ty_fam_inst_eqn_list-               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }--ty_fam_inst_eqn_list :: { Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]) }-        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]-                                                ,Just (unLoc $2)) }-        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in-                                             L loc ([],Just (unLoc $2)) }-        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2-                                                 ,mcc $3],Nothing) }-        | vocurly '..' close               { let (L loc _) = $2 in-                                             L loc ([mj AnnDotdot $2],Nothing) }--ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }-        : ty_fam_inst_eqns ';' ty_fam_inst_eqn-                                      {% let (L loc eqn) = $3 in-                                         case unLoc $1 of-                                           [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLLlA $1 $> ($3 : h' : t)) }-        | ty_fam_inst_eqns ';'        {% case unLoc $1 of-                                           [] -> return (sLL $1 $> (unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLL $1 $>  (h':t)) }-        | ty_fam_inst_eqn             { sLLAA $1 $> [$1] }-        | {- empty -}                 { noLoc [] }--ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }-        : 'forall' tv_bndrs '.' type '=' ktype-              {% do { hintExplicitForall $1-                    ; tvbs <- fromSpecTyVarBndrs $2-                    ; let loc = comb2A $1 $>-                    ; cs <- getCommentsFor loc-                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}-        | type '=' ktype-              {% mkTyFamInstEqn (comb2A (reLoc $1) $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }-              -- Note the use of type for the head; this allows-              -- infix type constructors and type patterns---- Associated type family declarations------ * They have a different syntax than on the toplevel (no family special---   identifier).------ * They also need to be separate from instances; otherwise, data family---   declarations without a kind signature cause parsing conflicts with empty---   data declarations.----at_decl_cls :: { LHsDecl GhcPs }-        :  -- data family declarations, with optional 'family' keyword-          'data' opt_family type opt_datafam_kind_sig-                {% liftM mkTyClD (mkFamDecl (comb3 $1 (reLoc $3) $4) DataFamily NotTopLevel $3-                                                  (snd $ unLoc $4) Nothing-                        (mj AnnData $1:$2++(fst $ unLoc $4))) }--           -- type family declarations, with optional 'family' keyword-           -- (can't use opt_instance because you get shift/reduce errors-        | 'type' type opt_at_kind_inj_sig-               {% liftM mkTyClD-                        (mkFamDecl (comb3 $1 (reLoc $2) $3) OpenTypeFamily NotTopLevel $2-                                   (fst . snd $ unLoc $3)-                                   (snd . snd $ unLoc $3)-                         (mj AnnType $1:(fst $ unLoc $3)) )}-        | 'type' 'family' type opt_at_kind_inj_sig-               {% liftM mkTyClD-                        (mkFamDecl (comb3 $1 (reLoc $3) $4) OpenTypeFamily NotTopLevel $3-                                   (fst . snd $ unLoc $4)-                                   (snd . snd $ unLoc $4)-                         (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}--           -- default type instances, with optional 'instance' keyword-        | 'type' ty_fam_inst_eqn-                {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2)-                          [mj AnnType $1]) }-        | 'type' 'instance' ty_fam_inst_eqn-                {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3)-                              (mj AnnType $1:mj AnnInstance $2:[]) )}--opt_family   :: { [AddEpAnn] }-              : {- empty -}   { [] }-              | 'family'      { [mj AnnFamily $1] }--opt_instance :: { [AddEpAnn] }-              : {- empty -} { [] }-              | 'instance'  { [mj AnnInstance $1] }---- Associated type instances----at_decl_inst :: { LInstDecl GhcPs }-           -- type instance declarations, with optional 'instance' keyword-        : 'type' opt_instance ty_fam_inst_eqn-                -- Note the use of type for the head; this allows-                -- infix type constructors and type patterns-                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)-                          (mj AnnType $1:$2) }--        -- data/newtype instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings-               {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)-                                    Nothing (reverse (snd $ unLoc $5))-                                            (fmap reverse $6)-                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)) }--        -- GADT instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-                {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3-                                (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)-                                (fmap reverse $7)-                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }--type_data_or_newtype :: { Located ([AddEpAnn], Bool, NewOrData) }-        : 'data'        { sL1 $1 ([mj AnnData    $1],            False,DataType) }-        | 'newtype'     { sL1 $1 ([mj AnnNewtype $1],            False,NewType) }-        | 'type' 'data' { sL1 $1 ([mj AnnType $1, mj AnnData $2],True ,DataType) }--data_or_newtype :: { Located (AddEpAnn, NewOrData) }-        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }-        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }---- Family result/return kind signatures--opt_kind_sig :: { Located ([AddEpAnn], Maybe (LHsKind GhcPs)) }-        :               { noLoc     ([]               , Nothing) }-        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) }--opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }-        :               { noLoc     ([]               , noLocA (NoSig noExtField)         )}-        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig noExtField $2))}--opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }-        :              { noLoc     ([]               , noLocA     (NoSig    noExtField)   )}-        | '::' kind    { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig  noExtField $2))}-        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2-                             ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLLa $1 (reLoc $>) (TyVarSig noExtField tvb))} }--opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs-                                            , Maybe (LInjectivityAnn GhcPs)))}-        :            { noLoc ([], (noLocA (NoSig noExtField), Nothing)) }-        | '::' kind  { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]-                                 , (sL1a (reLoc $>) (KindSig noExtField $2), Nothing)) }-        | '='  tv_bndr_no_braces '|' injectivity_cond-                {% do { tvb <- fromSpecTyVarBndr $2-                      ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1, mj AnnVbar $3]-                                           , (sLLa $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }---- tycl_hdr parses the header of a class or data type decl,--- which takes the form---      T a b---      Eq a => T a---      (Eq a, Ord b) => T a b---      T Int [a]                       -- for associated types--- Rather a lot of inlining here, else we get reduce/reduce errors-tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }-        : context '=>' type         {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) }-        | type                      { sL1A $1 (Nothing, $1) }--datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }-        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1-                                                       >> fromSpecTyVarBndrs $2-                                                         >>= \tvbs ->-                                                             (acs (\cs -> (sLL $1 (reLoc $>)-                                                                                  (Just ( addTrailingDarrowC $4 $5 cs)-                                                                                        , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))-                                                    }-        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1-                                             ; tvbs <- fromSpecTyVarBndrs $2-                                             ; let loc = comb2 $1 (reLoc $>)-                                             ; cs <- getCommentsFor loc-                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))-                                       } }-        | context '=>' type         {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }-        | type                      { sL1A $1 (Nothing, mkHsOuterImplicit, $1) }---capi_ctype :: { Maybe (LocatedP CType) }-capi_ctype : '{-# CTYPE' STRING STRING '#-}'-                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))-                                        (getSTRINGs $3,getSTRING $3)))-                              (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }--           | '{-# CTYPE'        STRING '#-}'-                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))-                              (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }--           |           { Nothing }---------------------------------------------------------------------------------- Stand-alone deriving---- Glasgow extension: stand-alone deriving declarations-stand_alone_deriving :: { LDerivDecl GhcPs }-  : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type-                {% do { let { err = text "in the stand-alone deriving instance"-                                    <> colon <+> quotes (ppr $5) }-                      ; acsA (\cs -> sLL $1 (reLoc $>)-                                 (DerivDecl (EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}---------------------------------------------------------------------------------- Role annotations--role_annot :: { LRoleAnnotDecl GhcPs }-role_annot : 'type' 'role' oqtycon maybe_roles-          {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))-                   [mj AnnType $1,mj AnnRole $2] }---- Reversed!-maybe_roles :: { Located [Located (Maybe FastString)] }-maybe_roles : {- empty -}    { noLoc [] }-            | roles          { $1 }--roles :: { Located [Located (Maybe FastString)] }-roles : role             { sLL $1 $> [$1] }-      | roles role       { sLL $1 $> $ $2 : unLoc $1 }---- read it in as a varid for better error messages-role :: { Located (Maybe FastString) }-role : VARID             { sL1 $1 $ Just $ getVARID $1 }-     | '_'               { sL1 $1 Nothing }---- Pattern synonyms---- Glasgow extension: pattern synonyms-pattern_synonym_decl :: { LHsDecl GhcPs }-        : 'pattern' pattern_synonym_lhs '=' pat-         {%      let (name, args, as ) = $2 in-                 acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4-                                                    ImplicitBidirectional-                      (EpAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }--        | 'pattern' pattern_synonym_lhs '<-' pat-         {%    let (name, args, as) = $2 in-               acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 Unidirectional-                       (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }--        | 'pattern' pattern_synonym_lhs '<-' pat where_decls-            {% do { let (name, args, as) = $2-                  ; mg <- mkPatSynMatchGroup name $5-                  ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $-                           mkPatSynBind name args $4 (ExplicitBidirectional mg)-                            (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))-                   }}--pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) }-        : con vars0 { ($1, PrefixCon noTypeArgs $2, []) }-        | varid conop varid { ($2, InfixCon $1 $3, []) }-        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }--vars0 :: { [LocatedN RdrName] }-        : {- empty -}                 { [] }-        | varid vars0                 { $1 : $2 }--cvars1 :: { [RecordPatSynField GhcPs] }-       : var                          { [RecordPatSynField (mkFieldOcc $1) $1] }-       | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)-                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}--where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }-        : 'where' '{' decls '}'       {% amsrl (sLL $1 $> (snd $ unLoc $3))-                                              (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }-        | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))-                                              (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}--pattern_synonym_sig :: { LSig GhcPs }-        : 'pattern' con_list '::' sigtype-                   {% acsA (\cs -> sLL $1 (reLoc $>)-                                $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)-                                  (toList $ unLoc $2) $4) }--qvarcon :: { LocatedN RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }---------------------------------------------------------------------------------- Nested declarations---- Declaration in class bodies----decl_cls  :: { LHsDecl GhcPs }-decl_cls  : at_decl_cls                 { $1 }-          | decl                        { $1 }--          -- A 'default' signature used with the generic-programming extension-          | 'default' infixexp '::' sigtype-                    {% runPV (unECP $2) >>= \ $2 ->-                       do { v <- checkValSigLhs $2-                          ; let err = text "in default signature" <> colon <+>-                                      quotes (ppr $2)-                          ; acsA (\cs -> sLL $1 (reLoc $>) $ SigD noExtField $ ClassOpSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}--decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed-          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)-                                             then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                    , unitOL $3))-                                            else case (snd $ unLoc $1) of-                                              SnocOL hs t -> do-                                                 t' <- addTrailingSemiA t (gl $2)-                                                 return (sLLlA $1 $> (fst $ unLoc $1-                                                                , snocOL hs t' `appOL` unitOL $3)) }-          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                                   ,snd $ unLoc $1))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t')) }-          | decl_cls                    { sL1A $1 ([], unitOL $1) }-          | {- empty -}                 { noLoc ([],nilOL) }--decllist_cls-        :: { Located ([AddEpAnn]-                     , OrdList (LHsDecl GhcPs)-                     , LayoutInfo GhcPs) }      -- Reversed-        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)-                                             ,snd $ unLoc $2, explicitBraces $1 $3) }-        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }-                                           in L l (anns, decls, VirtualBraces (getVOCURLY $1)) }---- Class body----where_cls :: { Located ([AddEpAnn]-                       ,(OrdList (LHsDecl GhcPs))    -- Reversed-                       ,LayoutInfo GhcPs) }-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)-                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }-        | {- empty -}                   { noLoc ([],nilOL,NoLayoutInfo) }---- Declarations in instance bodies----decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }-decl_inst  : at_decl_inst               { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }-           | decl                       { sL1A $1 (unitOL $1) }--decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed-           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                    , unLoc $3))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t' `appOL` unLoc $3)) }-           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                                   ,snd $ unLoc $1))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t')) }-           | decl_inst                  { sL1 $1 ([],unLoc $1) }-           | {- empty -}                { noLoc ([],nilOL) }--decllist_inst-        :: { Located ([AddEpAnn]-                     , OrdList (LHsDecl GhcPs)) }      -- Reversed-        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }-        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }---- Instance body----where_inst :: { Located ([AddEpAnn]-                        , OrdList (LHsDecl GhcPs)) }   -- Reversed-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                                             ,(snd $ unLoc $2)) }-        | {- empty -}                   { noLoc ([],nilOL) }---- Declarations in binding groups other than classes and instances----decls   :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }-        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)-                                 then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (msemi $2)-                                                        , unitOL $3))-                                 else case (snd $ unLoc $1) of-                                   SnocOL hs t -> do-                                      t' <- addTrailingSemiA t (gl $2)-                                      let { this = unitOL $3;-                                            rest = snocOL hs t';-                                            these = rest `appOL` this }-                                      return (rest `seq` this `seq` these `seq`-                                                 (sLLlA $1 $> (fst $ unLoc $1, these))) }-        | decls ';'          {% if isNilOL (snd $ unLoc $1)-                                  then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemi $2)-                                                          ,snd $ unLoc $1)))-                                  else case (snd $ unLoc $1) of-                                    SnocOL hs t -> do-                                       t' <- addTrailingSemiA t (gl $2)-                                       return (sLL $1 $> (fst $ unLoc $1-                                                      , snocOL hs t')) }-        | decl                          { sL1A $1 ([], unitOL $1) }-        | {- empty -}                   { noLoc ([],nilOL) }--decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }-        : '{'            decls '}'     { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }-        |     vocurly    decls close   { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }---- Binding groups other than those of class and instance declarations----binds   ::  { Located (HsLocalBinds GhcPs) }-                                         -- May have implicit parameters-                                                -- No type declarations-        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)-                                  ; cs <- getCommentsFor (gl $1)-                                  ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }--        | '{'            dbinds '}'     {% acs (\cs -> (L (comb3 $1 $2 $3)-                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }--        |     vocurly    dbinds close   {% acs (\cs -> (L (gl $2)-                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }---wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }-                                                -- May have implicit parameters-                                                -- No type declarations-        : 'where' binds                 {% do { r <- acs (\cs ->-                                                (sLL $1 $> (annBinds (mj AnnWhere $1) cs (unLoc $2))))-                                              ; return $ Just r} }-        | {- empty -}                   { Nothing }---------------------------------------------------------------------------------- Transformation Rules--rules   :: { [LRuleDecl GhcPs] } -- Reversed-        :  rules ';' rule              {% case $1 of-                                            [] -> return ($3:$1)-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return ($3:h':t) }-        |  rules ';'                   {% case $1 of-                                            [] -> return $1-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return (h':t) }-        |  rule                        { [$1] }-        |  {- empty -}                 { [] }--rule    :: { LRuleDecl GhcPs }-        : STRING rule_activation rule_foralls infixexp '=' exp-         {%runPV (unECP $4) >>= \ $4 ->-           runPV (unECP $6) >>= \ $6 ->-           acsA (\cs -> (sLLlA $1 $> $ HsRule-                                   { rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, 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_lhs = $4, rd_rhs = $6 })) }---- Rules can be specified to be NeverActive, unlike inline/specialize pragmas-rule_activation :: { ([AddEpAnn],Maybe Activation) }-        -- See Note [%shift: rule_activation -> {- empty -}]-        : {- empty -} %shift                    { ([],Nothing) }-        | rule_explicit_activation              { (fst $1,Just (snd $1)) }---- This production is used to parse the tilde syntax in pragmas such as---   * {-# INLINE[~2] ... #-}---   * {-# SPECIALISE [~ 001] ... #-}---   * {-# RULES ... [~0] ... g #-}--- Note that it can be written either---   without a space [~1]  (the PREFIX_TILDE case), or---   with    a space [~ 1] (the VARSYM case).--- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-rule_activation_marker :: { [AddEpAnn] }-      : PREFIX_TILDE { [mj AnnTilde $1] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "~")-                   then return [mj AnnTilde $1]-                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $-                               PsErrInvalidRuleActivationMarker-                           ; return [] } }--rule_explicit_activation :: { ([AddEpAnn]-                              ,Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mos $1,mj AnnVal $3,mcs $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }-        | '[' rule_activation_marker ']'-                                { ($2++[mos $1,mcs $3]-                                  ,NeverActive) }--rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }-        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2-                                                              in hintExplicitForall $1-                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)-                                                              >> return (\anns -> HsRuleAnn-                                                                          (Just (mu AnnForall $1,mj AnnDot $3))-                                                                          (Just (mu AnnForall $4,mj AnnDot $6))-                                                                          anns,-                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }--        -- See Note [%shift: rule_foralls -> 'forall' rule_vars '.']-        | 'forall' rule_vars '.' %shift                    { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,-                                                              Nothing, mkRuleBndrs $2) }-        -- See Note [%shift: rule_foralls -> {- empty -}]-        | {- empty -}            %shift                    { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }--rule_vars :: { [LRuleTyTmVar] }-        : rule_var rule_vars                    { $1 : $2 }-        | {- empty -}                           { [] }--rule_var :: { LRuleTyTmVar }-        : varid                         { sL1l $1 (RuleTyTmVar noAnn $1 Nothing) }-        | '(' varid '::' ctype ')'      {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }--{- Note [Parsing explicit foralls in Rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We really want the above definition of rule_foralls to be:--  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'-               | 'forall' rule_vars '.'-               | {- empty -}--where rule_vars (term variables) can be named "forall", "family", or "role",-but tv_vars (type variables) cannot be. However, such a definition results-in a reduce/reduce conflict. For example, when parsing:-> {-# RULE "name" forall a ... #-}-before the '...' it is impossible to determine whether we should be in the-first or second case of the above.--This is resolved by using rule_vars (which is more general) for both, and-ensuring that type-level quantified variables do not have the names "forall",-"family", or "role" in the function 'checkRuleTyVarBndrNames' in-GHC.Parser.PostProcess.-Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative-to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.--}---------------------------------------------------------------------------------- Warnings and deprecations (c.f. rules)--warnings :: { OrdList (LWarnDecl GhcPs) }-        : warnings ';' warning         {% if isNilOL $1-                                           then return ($1 `appOL` $3)-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t' `appOL` $3) }-        | warnings ';'                 {% if isNilOL $1-                                           then return $1-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t') }-        | warning                      { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-warning :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-                {% fmap unitOL $ acsA (\cs -> sLL $1 $>-                     (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)-                              (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }--deprecations :: { OrdList (LWarnDecl GhcPs) }-        : deprecations ';' deprecation-                                       {% if isNilOL $1-                                           then return ($1 `appOL` $3)-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t' `appOL` $3) }-        | deprecations ';'             {% if isNilOL $1-                                           then return $1-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t') }-        | deprecation                  { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-deprecation :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-             {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)-                                          (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }--strings :: { Located ([AddEpAnn],[Located StringLiteral]) }-    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }-    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }--stringlist :: { Located (OrdList (Located StringLiteral)) }-    : stringlist ',' STRING {% if isNilOL (unLoc $1)-                                then return (sLL $1 $> (unLoc $1 `snocOL`-                                                  (L (gl $3) (getStringLiteral $3))))-                                else case (unLoc $1) of-                                   SnocOL hs t -> do-                                     let { t' = addTrailingCommaS t (glAA $2) }-                                     return (sLL $1 $> (snocOL hs t' `snocOL`-                                                  (L (gl $3) (getStringLiteral $3))))--}-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }-    | {- empty -}           { noLoc nilOL }---------------------------------------------------------------------------------- Annotations-annotation :: { LHsDecl GhcPs }-    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                            ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs),-                                            (getANN_PRAGs $1))-                                            (ValueAnnProvenance $2) $3)) }--    | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                            ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs),-                                            (getANN_PRAGs $1))-                                            (TypeAnnProvenance $3) $4)) }--    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                                ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs),-                                                (getANN_PRAGs $1))-                                                 ModuleAnnProvenance $3)) }---------------------------------------------------------------------------------- Foreign import and export declarations--fdecl :: { Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs) }-fdecl : 'import' callconv safety fspec-               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->-                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }-      | 'import' callconv        fspec-               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);-                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}-      | 'export' callconv fspec-               {% mkExport $2 (snd $ unLoc $3) >>= \i ->-                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }--callconv :: { Located CCallConv }-          : 'stdcall'                   { sLL $1 $> StdCallConv }-          | 'ccall'                     { sLL $1 $> CCallConv   }-          | 'capi'                      { sLL $1 $> CApiConv    }-          | 'prim'                      { sLL $1 $> PrimCallConv}-          | 'javascript'                { sLL $1 $> JavaScriptCallConv }--safety :: { Located Safety }-        : 'unsafe'                      { sLL $1 $> PlayRisky }-        | 'safe'                        { sLL $1 $> PlaySafe }-        | 'interruptible'               { sLL $1 $> PlayInterruptible }--fspec :: { Located ([AddEpAnn]-                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }-       : STRING var '::' sigtype        { sLL $1 (reLoc $>) ([mu AnnDcolon $3]-                                             ,(L (getLoc $1)-                                                    (getStringLiteral $1), $2, $4)) }-       |        var '::' sigtype        { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2]-                                             ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }-         -- if the entity string is missing, it defaults to the empty string;-         -- the meaning of an empty entity string depends on the calling-         -- convention---------------------------------------------------------------------------------- Type signatures--opt_sig :: { Maybe (AddEpAnn, LHsType GhcPs) }-        : {- empty -}                   { Nothing }-        | '::' ctype                    { Just (mu AnnDcolon $1, $2) }--opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }-             : {- empty -}              { ([], Nothing) }-             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }---- Like ktype, but for types that obey the forall-or-nothing rule.--- See Note [forall-or-nothing rule] in GHC.Hs.Type.-sigktype :: { LHsSigType GhcPs }-        : sigtype              { $1 }-        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $-                                               sLLa  (reLoc $1) (reLoc $>) $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }---- Like ctype, but for types that obey the forall-or-nothing rule.--- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the--- logic in ctype here, we simply reuse the ctype production and perform--- surgery on the LHsType it returns to turn it into an LHsSigType.-sigtype :: { LHsSigType GhcPs }-        : ctype                            { hsTypeToHsSigType $1 }--sig_vars :: { Located [LocatedN RdrName] }    -- Returned in reversed order-         : sig_vars ',' var           {% case unLoc $1 of-                                           [] -> return (sLL $1 (reLocN $>) ($3 : unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingCommaN h (gl $2)-                                             return (sLL $1 (reLocN $>) ($3 : h' : t)) }-         | var                        { sL1N $1 [$1] }--sigtypes1 :: { OrdList (LHsSigType GhcPs) }-   : sigtype                 { unitOL $1 }-   | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (gl $2)-                                   ; return $ unitOL st `appOL` $3 } }--------------------------------------------------------------------------------- Types--unpackedness :: { Located UnpackednessPragma }-        : '{-# UNPACK' '#-}'   { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }-        | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }--forall_telescope :: { Located (HsForAllTelescope GhcPs) }-        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1-                                       ; acs (\cs -> (sLL $1 $> $-                                           mkHsForAllInvisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}-        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1-                                       ; req_tvbs <- fromSpecTyVarBndrs $2-                                       ; acs (\cs -> (sLL $1 $> $-                                           mkHsForAllVisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}---- A ktype is a ctype, possibly with a kind annotation-ktype :: { LHsType GhcPs }-        : ctype                { $1 }-        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }---- A ctype is a for-all type-ctype   :: { LHsType GhcPs }-        : forall_telescope ctype      { reLocA $ sLL $1 (reLoc $>) $-                                              HsForAllTy { hst_tele = unLoc $1-                                                         , hst_xforall = noExtField-                                                         , hst_body = $2 } }-        | context '=>' ctype          {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $-                                            HsQualTy { hst_ctxt = addTrailingDarrowC $1 $2 cs-                                                     , hst_xqual = NoExtField-                                                     , hst_body = $3 })) }--        | ipvar '::' ctype            {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }-        | type                        { $1 }--------------------------- Notes for 'context'--- We parse a context as a btype so that we don't get reduce/reduce--- errors in ctype.  The basic problem is that---      (Eq a, Ord a)--- looks so much like a tuple type.  We can't tell until we find the =>--context :: { LHsContext GhcPs }-        :  btype                        {% checkContext $1 }--{- Note [GADT decl discards annotations]-~~~~~~~~~~~~~~~~~~~~~-The type production for--    btype `->` ctype--add the AnnRarrow annotation twice, in different places.--This is because if the type is processed as usual, it belongs on the annotations-for the type as a whole.--But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and-the top-level annotation will be disconnected. Hence for this specific case it-is connected to the first type too.--}--type :: { LHsType GhcPs }-        -- See Note [%shift: type -> btype]-        : btype %shift                 { $1 }-        | btype '->' ctype             {% acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                            $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok $2)) $1 $3) }--        | btype mult '->' ctype        {% hintLinear (getLoc $2)-                                       >> let arr = (unLoc $2) (hsUniTok $3)-                                          in acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                           $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) arr $1 $4) }--        | btype '->.' ctype            {% hintLinear (getLoc $2) >>-                                          acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                            $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok $2))) $1 $3) }-                                              -- [mu AnnLollyU $2] }--mult :: { Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs) }-        : PREFIX_PERCENT atype          { sLL $1 (reLoc $>) (mkMultTy (hsTok $1) $2) }--btype :: { LHsType GhcPs }-        : infixtype                     {% runPV $1 }--infixtype :: { forall b. DisambTD b => PV (LocatedA b) }-        -- See Note [%shift: infixtype -> ftype]-        : ftype %shift                  { $1 }-        | ftype tyop infixtype          { $1 >>= \ $1 ->-                                          $3 >>= \ $3 ->-                                          do { let (op, prom) = $2-                                             ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)-                                             ; mkHsOpTyPV prom $1 op $3 } }-        | unpackedness infixtype        { $2 >>= \ $2 ->-                                          mkUnpackednessPV $1 $2 }--ftype :: { forall b. DisambTD b => PV (LocatedA b) }-        : atype                         { mkHsAppTyHeadPV $1 }-        | tyop                          { failOpFewArgs (fst $1) }-        | ftype tyarg                   { $1 >>= \ $1 ->-                                          mkHsAppTyPV $1 $2 }-        | ftype PREFIX_AT atype         { $1 >>= \ $1 ->-                                          mkHsAppKindTyPV $1 (getLoc $2) $3 }--tyarg :: { LHsType GhcPs }-        : atype                         { $1 }-        | unpackedness atype            {% addUnpackednessP $1 $2 }--tyop :: { (LocatedN RdrName, PromotionFlag) }-        : qtyconop                      { ($1, NotPromoted) }-        | tyvarop                       { ($1, NotPromoted) }-        | SIMPLEQUOTE qconop            {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))-                                                            (NameAnnQuote (glAA $1) (gl $2) [])-                                              ; return (op, IsPromoted) } }-        | SIMPLEQUOTE varop             {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))-                                                            (NameAnnQuote (glAA $1) (gl $2) [])-                                              ; return (op, IsPromoted) } }--atype :: { LHsType GhcPs }-        : ntgtycon                       {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- Not including unit tuples-        -- See Note [%shift: atype -> tyvar]-        | tyvar %shift                   {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- (See Note [Unit tuples])-        | '*'                            {% do { warnStarIsType (getLoc $1)-                                               ; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }-        | PREFIX_BANG  atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }--        | '{' fielddecls '}'             {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))-                                               ; checkRecordSyntax decls }}-                                                        -- Constructor sigs only-        | '(' ')'                        {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)-                                                    HsBoxedOrConstraintTuple []) }-        | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)-                                               ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)-                                                        HsBoxedOrConstraintTuple (h : $4)) }}-        | '(#' '#)'                   {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }-        | '(#' comma_types1 '#)'      {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }-        | '(#' bar_types2 '#)'        {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }-        | '[' ktype ']'               {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }-        | '(' ktype ')'               {% acsA (\cs -> sLL $1 $> $ HsParTy  (EpAnn (glR $1) (AnnParen AnnParens       (glAA $1) (glAA $3)) cs) $2) }-        | quasiquote                  { mapLocA (HsSpliceTy noExtField) $1 }-        | splice_untyped              { mapLocA (HsSpliceTy noExtField) $1 }-                                      -- see Note [Promotion] for the followings-        | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }-        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'-                             {% do { h <- addTrailingCommaA $3 (gl $4)-                                   ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }-        | SIMPLEQUOTE var                       {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }--        -- Two or more [ty, ty, ty] must be a promoted list type, just as-        -- if you had written '[ty, ty, ty]-        -- (One means a list type, zero means the list type constructor,-        -- so you have to quote those.)-        | '[' ktype ',' comma_types1 ']'  {% do { h <- addTrailingCommaA $2 (gl $3)-                                                ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}-        | INTEGER              { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)-                                                           (il_value (getINTEGER $1)) }-        | CHAR                 { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)-                                                                        (getCHAR $1) }-        | STRING               { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)-                                                                     (getSTRING  $1) }-        | '_'                  { reLocA $ sL1 $1 $ mkAnonWildCardTy }---- An inst_type is what occurs in the head of an instance decl---      e.g.  (Foo a, Gaz b) => Wibble a b--- It's kept as a single type for convenience.-inst_type :: { LHsSigType GhcPs }-        : sigtype                       { $1 }--deriv_types :: { [LHsSigType GhcPs] }-        : sigktype                      { [$1] }--        | sigktype ',' deriv_types      {% do { h <- addTrailingCommaA $1 (gl $2)-                                           ; return (h : $3) } }--comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty-        : comma_types1                  { $1 }-        | {- empty -}                   { [] }--comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty-        : ktype                        { [$1] }-        | ktype  ',' comma_types1      {% do { h <- addTrailingCommaA $1 (gl $2)-                                             ; return (h : $3) }}--bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty-        : ktype  '|' ktype             {% do { h <- addTrailingVbarA $1 (gl $2)-                                             ; return [h,$3] }}-        | ktype  '|' bar_types2        {% do { h <- addTrailingVbarA $1 (gl $2)-                                             ; return (h : $3) }}--tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }-         : tv_bndr tv_bndrs             { $1 : $2 }-         | {- empty -}                  { [] }--tv_bndr :: { LHsTyVarBndr Specificity GhcPs }-        : tv_bndr_no_braces             { $1 }-        | '{' tyvar '}'                 {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [moc $1, mcc $3] cs) InferredSpec $2)) }-        | '{' tyvar '::' kind '}'       {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }--tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }-        : tyvar                         {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }-        | '(' tyvar '::' kind ')'       {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }--fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }-        : {- empty -}                   { noLoc ([],[]) }-        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]-                                                 ,reverse (unLoc $2))) }--fds1 :: { Located [LHsFunDep GhcPs] }-        : fds1 ',' fd   {%-                           do { let (h:t) = unLoc $1 -- Safe from fds1 rules-                              ; h' <- addTrailingCommaA h (gl $2)-                              ; return (sLLlA $1 $> ($3 : h' : t)) }}-        | fd            { sL1A $1 [$1] }--fd :: { LHsFunDep GhcPs }-        : varids0 '->' varids0  {% acsA (\cs -> L (comb3 $1 $2 $3)-                                       (FunDep (EpAnn (glR $1) [mu AnnRarrow $2] cs)-                                               (reverse (unLoc $1))-                                               (reverse (unLoc $3)))) }--varids0 :: { Located [LocatedN RdrName] }-        : {- empty -}                   { noLoc [] }-        | varids0 tyvar                 { sLL $1 (reLocN $>) ($2 : (unLoc $1)) }---------------------------------------------------------------------------------- Kinds--kind :: { LHsKind GhcPs }-        : ctype                  { $1 }--{- Note [Promotion]-   ~~~~~~~~~~~~~~~~--- Syntax of promoted qualified names-We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified-names. Moreover ticks are only allowed in types, not in kinds, for a-few reasons:-  1. we don't need quotes since we cannot define names in kinds-  2. if one day we merge types and kinds, tick would mean look in DataName-  3. we don't have a kind namespace anyway--- Name resolution-When the user write Zero instead of 'Zero in types, we parse it a-HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We-deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not-bounded in the type level, then we look for it in the term level (we-change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).-And both become a HsTyVar ("Zero", DataName) after the renamer.---}----------------------------------------------------------------------------------- Datatype declarations--gadt_constrlist :: { Located ([AddEpAnn]-                          ,[LConDecl GhcPs]) } -- Returned in order--        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1-                                                         ,moc $2-                                                         ,mcc $4]-                                                        , unLoc $3) }-        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1]-                                                        , unLoc $3) }-        | {- empty -}                            { noLoc ([],[]) }--gadt_constrs :: { Located [LConDecl GhcPs] }-        : gadt_constr ';' gadt_constrs-                  {% do { h <- addTrailingSemiA $1 (gl $2)-                        ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }}-        | gadt_constr                   { L (glA $1) [$1] }-        | {- empty -}                   { noLoc [] }---- We allow the following forms:---      C :: Eq a => a -> T a---      C :: forall a. Eq a => !a -> T a---      D { x,y :: a } :: T a---      forall a. Eq a => D { x,y :: a } :: T a--gadt_constr :: { LConDecl GhcPs }-    -- see Note [Difference in parsing GADT and data constructors]-    -- Returns a list because of:   C,D :: ty-    -- TODO:AZ capture the optSemi. Why leading?-        : optSemi con_list '::' sigtype-                {% mkGadtDecl (comb2A $2 $>) (unLoc $2) (hsUniTok $3) $4 }--{- Note [Difference in parsing GADT and data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GADT constructors have simpler syntax than usual data constructors:-in GADTs, types cannot occur to the left of '::', so they cannot be mixed-with constructor names (see Note [Parsing data constructors is hard]).--Due to simplified syntax, GADT constructor names (left-hand side of '::')-use simpler grammar production than usual data constructor names. As a-consequence, GADT constructor names are restricted (names like '(*)' are-allowed in usual data constructors, but not in GADTs).--}--constrs :: { Located ([AddEpAnn],[LConDecl GhcPs]) }-        : '=' constrs1    { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}--constrs1 :: { Located [LConDecl GhcPs] }-        : constrs1 '|' constr-            {% do { let (h:t) = unLoc $1-                  ; h' <- addTrailingVbarA h (gl $2)-                  ; return (sLLlA $1 $> ($3 : h' : t)) }}-        | constr                         { sL1A $1 [$1] }--constr :: { LConDecl GhcPs }-        : forall context '=>' constr_stuff-                {% acsA (\cs -> let (con,details) = unLoc $4 in-                  (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98-                                                       (EpAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4))-                                                                    (mu AnnDarrow $3:(fst $ unLoc $1)) cs)-                                                       con-                                                       (snd $ unLoc $1)-                                                       (Just $2)-                                                       details))) }-        | forall constr_stuff-                {% acsA (\cs -> let (con,details) = unLoc $2 in-                  (L (comb2 $1 $2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs)-                                                      con-                                                      (snd $ unLoc $1)-                                                      Nothing   -- No context-                                                      details))) }--forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }-        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }-        | {- empty -}                 { noLoc ([], Nothing) }--constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }-        : infixtype       {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,-                                                          dataConBuilderDetails b))))-                                     (runPV $1) }--fielddecls :: { [LConDeclField GhcPs] }-        : {- empty -}     { [] }-        | fielddecls1     { $1 }--fielddecls1 :: { [LConDeclField GhcPs] }-        : fielddecl ',' fielddecls1-            {% do { h <- addTrailingCommaA $1 (gl $2)-                  ; return (h : $3) }}-        | fielddecl   { [$1] }--fielddecl :: { LConDeclField GhcPs }-                                              -- A list because of   f,g :: Int-        : sig_vars '::' ctype-            {% acsA (\cs -> L (comb2 $1 (reLoc $3))-                      (ConDeclField (EpAnn (glR $1) [mu AnnDcolon $2] cs)-                                    (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}---- Reversed!-maybe_derivings :: { Located (HsDeriving GhcPs) }-        : {- empty -}             { noLoc [] }-        | derivings               { $1 }---- A list of one or more deriving clauses at the end of a datatype-derivings :: { Located (HsDeriving GhcPs) }-        : derivings deriving      { sLL $1 (reLoc $>) ($2 : unLoc $1) } -- AZ: order?-        | deriving                { sL1 (reLoc $>) [$1] }---- The outer Located is just to allow the caller to--- know the rightmost extremity of the 'deriving' clause-deriving :: { LHsDerivingClause GhcPs }-        : 'deriving' deriv_clause_types-              {% let { full_loc = comb2A $1 $> }-                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }--        | 'deriving' deriv_strategy_no_via deriv_clause_types-              {% let { full_loc = comb2A $1 $> }-                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }--        | 'deriving' deriv_clause_types deriv_strategy_via-              {% let { full_loc = comb2 $1 (reLoc $>) }-                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }--deriv_clause_types :: { LDerivClauseTys GhcPs }-        : qtycon              { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $-                                           sL1 (reLocL $1) $ HsTyVar noAnn NotPromoted $1 } in-                                sL1 (reLocC $1) (DctSingle noExtField tc) }-        | '(' ')'             {% amsrc (sLL $1 $> (DctMulti noExtField []))-                                       (AnnContext Nothing [glAA $1] [glAA $2]) }-        | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2))-                                       (AnnContext Nothing [glAA $1] [glAA $3])}---------------------------------------------------------------------------------- Value definitions--{- Note [Declaration/signature overlap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's an awkward overlap with a type signature.  Consider-        f :: Int -> Int = ...rhs...-   Then we can't tell whether it's a type signature or a value-   definition with a result signature until we see the '='.-   So we have to inline enough to postpone reductions until we know.--}--{--  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var-  instead of qvar, we get another shift/reduce-conflict. Consider the-  following programs:--     { (^^) :: Int->Int ; }          Type signature; only var allowed--     { (^^) :: Int->Int = ... ; }    Value defn with result signature;-                                     qvar allowed (because of instance decls)--  We can't tell whether to reduce var to qvar until after we've read the signatures.--}--decl_no_th :: { LHsDecl GhcPs }-        : sigdecl               { $1 }--        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->-                                       do { let { l = comb2Al $1 $> }-                                          ; r <- checkValDef l $1 $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) } }-        | pattern_synonym_decl  { $1 }--decl    :: { LHsDecl GhcPs }-        : decl_no_th            { $1 }--        -- Why do we only allow naked declaration splices in top-level-        -- declarations and not here? Short answer: because readFail009-        -- fails terribly with a panic in cvBindsAndSigs otherwise.-        | splice_exp            {% mkSpliceDecl $1 }--rhs     :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }-        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 ->-                                  do { let L l (bs, csw) = adaptWhereBinds $3-                                     ; let loc = (comb3 $1 (reLoc $2) (L l bs))-                                     ; acs (\cs ->-                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)-                                                      bs)) } }-        | gdrhs wherebinds      {% do { let {L l (bs, csw) = adaptWhereBinds $2}-                                      ; acs (\cs -> sL (comb2 $1 (L l bs))-                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}--gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }-        : gdrhs gdrh            { sLL $1 (reLoc $>) ($2 : unLoc $1) }-        | gdrh                  { sL1 (reLoc $1) [$1] }--gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }-        : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->-                                     acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }--sigdecl :: { LHsDecl GhcPs }-        :-        -- See Note [Declaration/signature overlap] for why we need infixexp here-          infixexp     '::' sigtype-                        {% do { $1 <- runPV (unECP $1)-                              ; v <- checkValSigLhs $1-                              ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $-                                  TypeSig (EpAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }--        | var ',' sig_vars '::' sigtype-           {% do { v <- addTrailingCommaN $1 (gl $2)-                 ; let sig cs = TypeSig (EpAnn (glNR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3))-                                      (mkHsWildCardBndrs $5)-                 ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }}--        | infix prec ops-             {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3-                                                      ; pure (mj AnnVal l2) })-                                       $2-                   ; let (fixText, fixPrec) = case $2 of-                                                -- If an explicit precedence isn't supplied,-                                                -- it defaults to maxPrecedence-                                                Nothing -> (NoSourceText, maxPrecedence)-                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)-                   ; acsA (\cs -> sLL $1 $> $ SigD noExtField-                            (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3)-                                    (Fixity fixText fixPrec (unLoc $1)))))-                   }}--        | pattern_synonym_sig   { sL1 $1 . SigD noExtField . unLoc $ $1 }--        | '{-# COMPLETE' qcon_list opt_tyconsig  '#-}'-                {% let (dcolon, tc) = $3-                   in acsA-                       (\cs -> sLL $1 $>-                         (SigD noExtField (CompleteMatchSig ((EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) }--        -- This rule is for both INLINE and INLINABLE pragmas-        | '{-# INLINE' activation qvarcon '#-}'-                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3-                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)-                                            (snd $2))))) }-        | '{-# OPAQUE' qvar '#-}'-                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2-                            (mkOpaquePragma (getOPAQUE_PRAGs $1))))) }-        | '{-# SCC' qvar '#-}'-          {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) }--        | '{-# SCC' qvar STRING '#-}'-          {% do { scc <- getSCC $3-                ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing-                ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}--        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'-             {% acsA (\cs ->-                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)-                                             (NoUserInlinePrag, FunLike) (snd $2)-                  in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }--        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'-             {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)-                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)-                                               (getSPEC_INLINE $1) (snd $2)))) }--        | '{-# SPECIALISE' 'instance' inst_type '#-}'-                {% acsA (\cs -> sLL $1 $>-                                  $ SigD noExtField (SpecInstSig ((EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) }--        -- A minimal complete definition-        | '{-# MINIMAL' name_boolformula_opt '#-}'-            {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glR $1) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) }--activation :: { ([AddEpAnn],Maybe Activation) }-        -- See Note [%shift: activation -> {- empty -}]-        : {- empty -} %shift                    { ([],Nothing) }-        | explicit_activation                   { (fst $1,Just (snd $1)) }--explicit_activation :: { ([AddEpAnn],Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }---------------------------------------------------------------------------------- Expressions--quasiquote :: { Located (HsUntypedSplice GhcPs) }-        : TH_QUASIQUOTE   { let { loc = getLoc $1-                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = 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) }-                            in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }--exp   :: { ECP }-        : infixexp '::' ctype-                                { ECP $-                                   unECP $1 >>= \ $1 ->-                                   rejectPragmaPV $1 >>-                                   mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3-                                          [(mu AnnDcolon $2)] }-        | infixexp '-<' exp     {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3-                                                        HsFirstOrderApp True) }-        | infixexp '>-' exp     {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1-                                                      HsFirstOrderApp False) }-        | infixexp '-<<' exp    {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3-                                                      HsHigherOrderApp True) }-        | infixexp '>>-' exp    {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1-                                                      HsHigherOrderApp False) }-        -- See Note [%shift: exp -> infixexp]-        | infixexp %shift       { $1 }-        | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]--infixexp :: { ECP }-        : exp10 { $1 }-        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]-                               { ECP $-                                 superInfixOp $-                                 $2 >>= \ $2 ->-                                 unECP $1 >>= \ $1 ->-                                 unECP $3 >>= \ $3 ->-                                 rejectPragmaPV $1 >>-                                 (mkHsOpAppPV (comb2A (reLoc $1) $3) $1 $2 $3) }-                 -- AnnVal annotation for NPlusKPat, which discards the operator--exp10p :: { ECP }-  : exp10            { $1 }-  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]--exp_prag(e) :: { ECP }-  : prag_e e  -- See Note [Pragmas and operator fixity]-      {% runPV (unECP $2) >>= \ $2 ->-         fmap ecpFromExp $-         return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) }--exp10 :: { ECP }-        -- See Note [%shift: exp10 -> '-' fexp]-        : '-' fexp %shift               { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkHsNegAppPV (comb2A $1 $>) $2-                                                 [mj AnnMinus $1] }-        -- See Note [%shift: exp10 -> fexp]-        | fexp %shift                  { $1 }--optSemi :: { (Maybe EpaLocation,Bool) }-        : ';'         { (msemim $1,True) }-        | {- empty -} { (Nothing,False) }--{- Note [Pragmas and operator fixity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'prag_e' is an expression pragma, such as {-# SCC ... #-}.--It must be used with care, or else #15730 happens. Consider this infix-expression:--         1 / 2 / 2--There are two ways to parse it:--    1.   (1 / 2) / 2   =  0.25-    2.   1 / (2 / 2)   =  1.0--Due to the fixity of the (/) operator (assuming it comes from Prelude),-option 1 is the correct parse. However, in the past GHC's parser used to get-confused by the SCC annotation when it occurred in the middle of an infix-expression:--         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2--There are several ways to address this issue, see GHC Proposal #176 for a-detailed exposition:--  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst--The accepted fix is to disallow pragmas that occur within infix expressions.-Infix expressions are assembled out of 'exp10', so 'exp10' must not accept-pragmas. Instead, we accept them in exactly two places:--* at the start of an expression or a parenthesized subexpression:--    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression-    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression--* immediately after the last operator:--    f = 1 / 2 / {-# SCC ann #-} 2--In both cases, the parse does not depend on operator fixity. The second case-may sound unnecessary, but it's actually needed to support a common idiom:--    f $ {-# SCC ann $-} ...---}-prag_e :: { Located (HsPragE GhcPs) }-      : '{-# SCC' STRING '#-}'      {% do { scc <- getSCC $2-                                          ; acs (\cs -> (sLL $1 $>-                                             (HsPragSCC-                                                ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs),-                                                (getSCC_PRAGs $1))-                                                (StringLiteral (getSTRINGs $2) scc Nothing))))} }-      | '{-# SCC' VARID  '#-}'      {% acs (\cs -> (sLL $1 $>-                                             (HsPragSCC-                                               ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs),-                                               (getSCC_PRAGs $1))-                                               (StringLiteral NoSourceText (getVARID $2) Nothing)))) }--fexp    :: { ECP }-        : fexp aexp                  { ECP $-                                          superFunArg $-                                          unECP $1 >>= \ $1 ->-                                          unECP $2 >>= \ $2 ->-                                          mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc $1) $>) $1 $2 }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | fexp PREFIX_AT atype       { ECP $-                                        unECP $1 >>= \ $1 ->-                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (hsTok $2) $3 }--        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->-                                        fmap ecpFromExp $-                                        acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (EpAnn (glR $1) [mj AnnStatic $1] cs) $2) }--        | aexp                       { $1 }--aexp    :: { ECP }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : qvar TIGHT_INFIX_AT aexp-                                { ECP $-                                   unECP $3 >>= \ $3 ->-                                     mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 (hsTok $2) $3 }---        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE aexp     { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsLazyPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnTilde $1] }-        | PREFIX_BANG aexp      { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsBangPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnBang $1] }-        | PREFIX_MINUS aexp     { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }--        | '\\' apats '->' exp-                   {  ECP $-                      unECP $4 >>= \ $4 ->-                      mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource-                            (reLocA $ sLLlA $1 $>-                            [reLocA $ sLLlA $1 $>-                                         $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs-                                                 , m_ctxt = LambdaExpr-                                                 , m_pats = $2-                                                 , m_grhss = unguardedGRHSs (comb2 $3 (reLoc $4)) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])) }-        | 'let' binds 'in' exp          {  ECP $-                                           unECP $4 >>= \ $4 ->-                                           mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }-        | '\\' 'lcase' altslist(pats1)-            {  ECP $ $3 >>= \ $3 ->-                 mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }-        | '\\' 'lcases' altslist(apats)-            {  ECP $ $3 >>= \ $3 ->-                 mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }-        | 'if' exp optSemi 'then' exp optSemi 'else' exp-                         {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->-                            return $ ECP $-                              unECP $5 >>= \ $5 ->-                              unECP $8 >>= \ $8 ->-                              mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8-                                    (AnnsIf-                                      { aiIf = glAA $1-                                      , aiThen = glAA $4-                                      , aiElse = glAA $7-                                      , aiThenSemi = fst $3-                                      , aiElseSemi = fst $6})}--        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->-                                           fmap ecpFromExp $-                                           acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)-                                                     (reverse $ snd $ unLoc $2)) }-        | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->-                                             return $ ECP $-                                               $4 >>= \ $4 ->-                                               mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4-                                                    (EpAnnHsCase (glAA $1) (glAA $3) []) }-        -- QualifiedDo.-        | DO  stmtlist               {% do-                                      hintQualifiedDo $1-                                      return $ ECP $-                                        $2 >>= \ $2 ->-                                        mkHsDoPV (comb2A $1 $2)-                                                 (fmap mkModuleNameFS (getDO $1))-                                                 $2-                                                 (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) }-        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->-                                       fmap ecpFromExp $-                                       acsA (\cs -> L (comb2A $1 $2)-                                              (mkHsDoAnns (MDoExpr $-                                                          fmap mkModuleNameFS (getMDO $1))-                                                          $2-                                           (EpAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }-        | 'proc' aexp '->' exp-                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->-                           runPV (unECP $4) >>= \ $4@cmd ->-                           fmap ecpFromExp $-                           acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 (reLoc $>) $ HsCmdTop noExtField cmd)) }--        | aexp1                 { $1 }--aexp1   :: { ECP }-        : aexp1 '{' fbinds '}' { ECP $-                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->-                                   unECP $1 >>= \ $1 ->-                                   $3 >>= \ $3 ->-                                   mkHsRecordPV overloaded (comb2 (reLoc $1) $>) (comb2 $2 $4) $1 $3-                                        [moc $2,mcc $4]-                               }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | aexp1 TIGHT_INFIX_PROJ field-            {% runPV (unECP $1) >>= \ $1 ->-               fmap ecpFromExp $ acsa (\cs ->-                 let fl = sLLa $2 (reLoc $>) (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in-                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }---        | aexp2                { $1 }--aexp2   :: { ECP }-        : qvar                          { ECP $ mkHsVarPV $! $1 }-        | qcon                          { ECP $ mkHsVarPV $! $1 }-        -- See Note [%shift: aexp2 -> ipvar]-        | ipvar %shift                  {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) }-        | overloaded_label              {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) }-        | literal                       { ECP $ pvA (mkHsLitPV $! $1) }--- This will enable overloaded strings permanently.  Normally the renamer turns HsString--- into HsOverLit when -XOverloadedStrings is on.---      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)---                                       (getSTRING $1) noExtField) }-        | INTEGER   { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral   (getINTEGER  $1)) }-        | RATIONAL  { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsFractional (getRATIONAL $1)) }--        -- N.B.: sections get parsed by these next two productions.-        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't-        -- correct Haskell (you'd have to write '((+ 3), (4 -))')-        -- but the less cluttered version fell out of having texps.-        | '(' texp ')'                  { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkHsParPV (comb2 $1 $>) (hsTok $1) $2 (hsTok $3) }-        | '(' tup_exprs ')'             { ECP $-                                           $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2-                                                [mop $1,mcp $3]}--        -- This case is only possible when 'OverloadedRecordDotBit' is enabled.-        | '(' projection ')'            { ECP $-                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))-                                            >>= ecpFromExp'-                                        }--        | '(#' texp '#)'                { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])-                                                 [moh $1,mch $3] }-        | '(#' tup_exprs '#)'           { ECP $-                                           $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2-                                                [moh $1,mch $3] }--        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) }-        | '_'               { ECP $ pvA $ mkHsWildCardPV (getLoc $1) }--        -- Template Haskell Extension-        | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }-        | splice_typed   { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }--        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }-        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }-        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }-        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }-        -- See Note [%shift: aexp2 -> TH_TY_QUOTE]-        | TH_TY_QUOTE %shift    {% reportEmptyDoubleQuotes (getLoc $1) }-        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->-                                 fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]-                                                                                         else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }-        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->-                                 fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) }-        | '[t|' ktype '|]'    {% fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }-        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->-                                      fmap ecpFromExp $-                                      acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }-        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $-                                  acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }-        | quasiquote          { ECP $ pvA $ mkHsSplicePV $1 }--        -- arrow notation extension-        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->-                                      fmap ecpFromCmd $-                                      acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix-                                                           Nothing (reverse $3)) }--projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }-projection-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer-        : projection TIGHT_INFIX_PROJ field-                             {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }-        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }--splice_exp :: { LHsExpr GhcPs }-        : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }-        | splice_typed   { fmap (uncurry HsTypedSplice) (reLocA $1) }--splice_untyped :: { Located (HsUntypedSplice GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->-                                   acs (\cs -> sLLlA $1 $> $ HsUntypedSpliceExpr (EpAnn (glR $1) [mj AnnDollar $1] cs) $2) }--splice_typed :: { Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR_DOLLAR aexp2-                                {% runPV (unECP $2) >>= \ $2 ->-                                   acs (\cs -> sLLlA $1 $> $ ((noAnn, EpAnn (glR $1) [mj AnnDollarDollar $1] cs), $2)) }--cmdargs :: { [LHsCmdTop GhcPs] }-        : cmdargs acmd                  { $2 : $1 }-        | {- empty -}                   { [] }--acmd    :: { LHsCmdTop GhcPs }-        : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->-                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->-                                   return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd) }--cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }-        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1-                                                  ,mj AnnCloseC $3],$2) }-        |      vocurly    cvtopdecls0 close    { ([],$2) }--cvtopdecls0 :: { [LHsDecl GhcPs] }-        : topdecls_semi         { cvTopDecls $1 }-        | topdecls              { cvTopDecls $1 }---------------------------------------------------------------------------------- Tuple expressions---- "texp" is short for tuple expressions:--- things that can appear unparenthesized as long as they're--- inside parens or delimited by commas-texp :: { ECP }-        : exp                           { $1 }--        -- Note [Parsing sections]-        -- ~~~~~~~~~~~~~~~~~~~~~~~-        -- We include left and right sections here, which isn't-        -- technically right according to the Haskell standard.-        -- For example (3 +, True) isn't legal.-        -- However, we want to parse bang patterns like-        --      (!x, !y)-        -- and it's convenient to do so here as a section-        -- Then when converting expr to pattern we unravel it again-        -- Meanwhile, the renamer checks that real sections appear-        -- inside parens.-        | infixexp qop-                             {% runPV (unECP $1) >>= \ $1 ->-                                runPV (rejectPragmaPV $1) >>-                                runPV $2 >>= \ $2 ->-                                return $ ecpFromExp $-                                reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }-        | qopm infixexp      { ECP $-                                superInfixOp $-                                unECP $2 >>= \ $2 ->-                                $1 >>= \ $1 ->-                                pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }--       -- View patterns get parenthesized above-        | exp '->' texp   { ECP $-                             unECP $1 >>= \ $1 ->-                             unECP $3 >>= \ $3 ->-                             mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }---- Always at least one comma or bar.--- Though this can parse just commas (without any expressions), it won't--- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]--- in GHC.Hs.Expr.-tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }-           : texp commas_tup_tail-                           { unECP $1 >>= \ $1 ->-                             $2 >>= \ $2 ->-                             do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]-                                ; return (Tuple (Right t : snd $2)) } }-           | commas tup_tail-                 { $2 >>= \ $2 ->-                   do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (srcSpan2e ll) emptyComments))) (fst $1) }-                      ; return (Tuple (cos ++ $2)) } }--           | texp bars   { unECP $1 >>= \ $1 -> return $-                            (Sum 1  (snd $2 + 1) $1 [] (map srcSpan2e $ fst $2)) }--           | bars texp bars0-                { unECP $2 >>= \ $2 -> return $-                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2-                    (map srcSpan2e $ fst $1)-                    (map srcSpan2e $ fst $3)) }---- Always starts with commas; always follows an expr-commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }-commas_tup_tail : commas tup_tail-        { $2 >>= \ $2 ->-          do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (srcSpan2e l) emptyComments))) (tail $ fst $1) }-             ; return ((head $ fst $1, cos ++ $2)) } }---- Always follows a comma-tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] }-          : texp commas_tup_tail { unECP $1 >>= \ $1 ->-                                   $2 >>= \ $2 ->-                                   do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]-                                      ; return (Right t : snd $2) } }-          | texp                 { unECP $1 >>= \ $1 ->-                                   return [Right $1] }-          -- See Note [%shift: tup_tail -> {- empty -}]-          | {- empty -} %shift   { return [Left noAnn] }---------------------------------------------------------------------------------- List expressions---- The rules below are little bit contorted to keep lexps left-recursive while--- avoiding another shift/reduce-conflict.--- Never empty.-list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b) }-        : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->-                            mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) }-        | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->-                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) }-        | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->-                                  acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1))-                                      >>= ecpFromExp' }-        | texp ',' exp '..' { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3))-                                       >>= ecpFromExp' }-        | texp '..' exp  { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3))-                                       >>= ecpFromExp' }-        | texp ',' exp '..' exp { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   unECP $5 >>= \ $5 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5))-                                       >>= ecpFromExp' }-        | texp '|' flattenedpquals-             { \loc (ao,ac) ->-                checkMonadComp >>= \ ctxt ->-                unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2)-                ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs))-                    >>= ecpFromExp' } }--lexps :: { forall b. DisambECP b => PV [LocatedA b] }-        : lexps ',' texp           { $1 >>= \ $1 ->-                                     unECP $3 >>= \ $3 ->-                                     case $1 of-                                       (h:t) -> do-                                         h' <- addTrailingCommaA h (gl $2)-                                         return (((:) $! $3) $! (h':t)) }-        | texp ',' texp             { unECP $1 >>= \ $1 ->-                                      unECP $3 >>= \ $3 ->-                                      do { h <- addTrailingCommaA $1 (gl $2)-                                         ; return [$3,h] }}---------------------------------------------------------------------------------- List Comprehensions--flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : 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--                    qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |-                                            qs <- qss]-                                            noExpr noSyntaxExpr]-                    -- We actually found some actual parallel lists so-                    -- we wrap them into as a ParStmt-                }--pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }-    : squals '|' pquals-                     {% case unLoc $1 of-                          (h:t) -> do-                            h' <- addTrailingVbarA h (gl $2)-                            return (sLL $1 $> (reverse (h':t) : unLoc $3)) }-    | squals         { L (getLoc $1) [reverse (unLoc $1)] }--squals :: { Located [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' <- addTrailingCommaA h (gl $2)-                    return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) }-    | squals ',' qual-             {% runPV $3 >>= \ $3 ->-                case unLoc $1 of-                  (h:t) -> do-                    h' <- addTrailingCommaA h (gl $2)-                    return (sLL $1 (reLoc $>) ($3 : (h':t))) }-    | transformqual        {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) }-    | qual                               {% runPV $1 >>= \ $1 ->-                                            return $ sL1A $1 [$1] }---  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }---  | '{|' pquals '|}'                       { sL1 $1 [$2] }---- It is possible to enable bracketing (associating) qualifier lists--- by uncommenting the lines with {| |} above. Due to a lack of--- consensus on the syntax, this feature is not being used until we--- get user demand.--transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }-                        -- Function is applied to a list of stmts *in order*-    : 'then' exp              {% runPV (unECP $2) >>= \ $2 ->-                                 acs (\cs->-                                 sLLlA $1 $> (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen $1] cs) ss $2))) }-    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->-                                 runPV (unECP $4) >>= \ $4 ->-                                 acs (\cs -> sLLlA $1 $> (-                                                     \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) }-    | 'then' 'group' 'using' exp-            {% runPV (unECP $4) >>= \ $4 ->-               acs (\cs -> sLLlA $1 $> (-                                   \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) }--    | 'then' 'group' 'by' exp 'using' exp-            {% runPV (unECP $4) >>= \ $4 ->-               runPV (unECP $6) >>= \ $6 ->-               acs (\cs -> sLLlA $1 $> (-                                   \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) }---- Note that 'group' is a special_id, which means that you can enable--- TransformListComp while still using Data.List.group. However, this--- introduces a shift/reduce conflict. Happy chooses to resolve the conflict--- in by choosing the "group by" variant, which is what we want.---------------------------------------------------------------------------------- Guards--guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }--guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->-                               case unLoc $1 of-                                 (h:t) -> do-                                   h' <- addTrailingCommaA h (gl $2)-                                   return (sLL $1 (reLoc $>) ($3 : (h':t))) }-    | qual                  {% runPV $1 >>= \ $1 ->-                               return $ sL1A $1 [$1] }---------------------------------------------------------------------------------- Case alternatives--altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }-        : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsrl-                                           (sLL $1 $> (reverse (snd $ unLoc $2)))-                                           (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }-        | vocurly    alts(PATS)  close { $2 >>= \ $2 -> amsrl-                                           (L (getLoc $2) (reverse (snd $ unLoc $2)))-                                           (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }-        | '{'              '}'   { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }-        | vocurly          close { return $ noLocA [] }--alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }-        : alts1(PATS)              { $1 >>= \ $1 -> return $-                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-        | ';' alts(PATS)           { $2 >>= \ $2 -> return $-                                     sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) )-                                               ,snd $ unLoc $2) }--alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }-        : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 ->-                                        $3 >>= \ $3 ->-                                          case snd $ unLoc $1 of-                                            [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                            ,[$3]))-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }-        | alts1(PATS) ';'           {  $1 >>= \ $1 ->-                                         case snd $ unLoc $1 of-                                           [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                           ,[]))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLL $1 $> (fst $ unLoc $1, h' : t)) }-        | alt(PATS)                 { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }--alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }-        : PATS alt_rhs { $2 >>= \ $2 ->-                         acsA (\cs -> sLLAsl $1 $>-                                         (Match { m_ext = EpAnn (listAsAnchor $1) [] cs-                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing-                                                , m_pats = $1-                                                , m_grhss = unLoc $2 }))}--alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }-        : ralt wherebinds           { $1 >>= \alt ->-                                      do { let {L l (bs, csw) = adaptWhereBinds $2}-                                         ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }}--ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }-        : '->' exp            { unECP $2 >>= \ $2 ->-                                acs (\cs -> sLLlA $1 $> (unguardedRHS (EpAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }-        | gdpats              { $1 >>= \gdpats ->-                                return $ sL1 gdpats (reverse (unLoc gdpats)) }--gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }-        : gdpats gdpat { $1 >>= \gdpats ->-                         $2 >>= \gdpat ->-                         return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) }-        | gdpat        { $1 >>= \gdpat -> return $ sL1A gdpat [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 ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }-         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->-                                             return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }-         |     gdpats close               {% runPV $1 >>= \ $1 ->-                                             return $ sL1 $1 ([],unLoc $1) }--gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }-        : '|' guardquals '->' exp-                                   { unECP $4 >>= \ $4 ->-                                     acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }---- 'pat' recognises a pattern, including one with a bang at the top---      e.g.  "!x" or "!(x,y)" or "C a b" etc--- Bangs inside are parsed as infix operator applications, so that--- we parse them right when bang-patterns are off-pat     :: { LPat GhcPs }-pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }---- 'pats1' does the same thing as 'pat', but returns it as a singleton--- list so that it can be used with a parameterized production rule-pats1   :: { [LPat GhcPs] }-pats1   : pat { [ $1 ] }--bindpat :: { LPat GhcPs }-bindpat :  exp            {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess-                             checkPattern_details incompleteDoBlock-                                              (unECP $1) }--apat   :: { LPat GhcPs }-apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }--apats  :: { [LPat GhcPs] }-        : apat apats            { $1 : $2 }-        | {- empty -}           { [] }---------------------------------------------------------------------------------- Statement sequences--stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }-        : '{'           stmts '}'       { $2 >>= \ $2 ->-                                          amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }-        |     vocurly   stmts close     { $2 >>= \ $2 -> amsrl-                                          (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }----      do { ;; s ; s ; ; s ;; }--- The last Stmt should be an expression, but that's hard to enforce--- here, because we need too much lookahead if we see do { e ; }--- So we use BodyStmts throughout, and switch the last one over--- in ParseUtils.checkDo instead--stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])) }-        : stmts ';' stmt  { $1 >>= \ $1 ->-                            $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->-                            case (snd $ unLoc $1) of-                              [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2)-                                                     ,$3   : (snd $ unLoc $1)))-                              (h:t) -> do-                               { h' <- addTrailingSemiA h (gl $2)-                               ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }}--        | stmts ';'     {  $1 >>= \ $1 ->-                           case (snd $ unLoc $1) of-                             [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))-                             (h:t) -> do-                               { h' <- addTrailingSemiA h (gl $2)-                               ; return $ sL1 $1 (fst $ unLoc $1,h':t) }}-        | stmt                   { $1 >>= \ $1 ->-                                   return $ sL1A $1 (nilOL,[$1]) }-        | {- empty -}            { return $ noLoc (nilOL,[]) }----- For typing stmts at the GHCi prompt, where--- the input may consist of just comments.-maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }-        : stmt                          {% fmap Just (runPV $1) }-        | {- nothing -}                 { Nothing }---- For GHC API.-e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }-        : stmt                          {% runPV $1 }--stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }-        : qual                          { $1 }-        | 'rec' stmtlist                {  $2 >>= \ $2 ->-                                           acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt-                                                 (EpAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)-                                                  $2)) }--qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }-    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->-                                           acsA (\cs -> sLLlA (reLoc $1) $>-                                            $ mkPsBindStmt (EpAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) }-    | exp                                { unECP $1 >>= \ $1 ->-                                           return $ sL1 $1 $ mkBodyStmt $1 }-    | 'let' binds                        { acsA (\cs -> (sLL $1 $>-                                                $ mkLetStmt (EpAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) }---------------------------------------------------------------------------------- Record Field Update/Construction--fbinds  :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }-        : fbinds1                       { $1 }-        | {- empty -}                   { return ([], Nothing) }--fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }-        : fbind ',' fbinds1-                 { $1 >>= \ $1 ->-                   $3 >>= \ $3 -> do-                   h <- addTrailingCommaFBind $1 (gl $2)-                   return (case $3 of (flds, dd) -> (h : flds, dd)) }-        | fbind                         { $1 >>= \ $1 ->-                                          return ([$1], Nothing) }-        | '..'                          { return ([],   Just (getLoc $1)) }--fbind   :: { forall b. DisambECP b => PV (Fbind b) }-        : qvar '=' texp  { unECP $3 >>= \ $3 ->-                           fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1l $1 $ mkFieldOcc $1) $3 False) }-                        -- RHS is a 'texp', allowing view patterns (#6038)-                        -- and, incidentally, sections.  Eg-                        -- f (R { x = show -> s }) = ...--        | qvar          { placeHolderPunRhs >>= \rhs ->-                          fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (sL1l $1 $ mkFieldOcc $1) rhs True) }-                        -- In the punning case, use a place-holder-                        -- The renamer fills in the final value--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        -- AZ: need to pull out the let block into a helper-        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp-                        { do-                            let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1-                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)-                                lf' = comb2 $2 (reLoc $ L lf ())-                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t-                                final = last fields-                                l = comb2 (reLoc $1) $3-                                isPun = False-                            $5 <- unECP $5-                            fmap Right $ mkHsProjUpdatePV (comb2 (reLoc $1) (reLoc $5)) (L l fields) $5 isPun-                                            [mj AnnEqual $4]-                        }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        -- AZ: need to pull out the let block into a helper-        | field TIGHT_INFIX_PROJ fieldToUpdate-                        { do-                            let top =  sL1 (la2la $1) $ DotFieldOcc noAnn $1-                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)-                                lf' = comb2 $2 (reLoc $ L lf ())-                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t-                                final = last fields-                                l = comb2 (reLoc $1) $3-                                isPun = True-                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))-                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []-                        }--fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }-fieldToUpdate-        -- See Note [Whitespace-sensitive operator parsing] in Lexer.x-        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLocA $3) >>= \cs ->-                                                     return (sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }-        | field       {% getCommentsFor (getLocA $1) >>= \cs ->-                        return (sL1 (reLoc $1) [sL1a (reLoc $1) (DotFieldOcc (EpAnn (glNR $1) (AnnFieldLabel Nothing) cs) $1)]) }---------------------------------------------------------------------------------- Implicit Parameter Bindings--dbinds  :: { Located [LIPBind GhcPs] } -- reversed-        : dbinds ';' dbind-                      {% case unLoc $1 of-                           (h:t) -> do-                             h' <- addTrailingSemiA h (gl $2)-                             return (let { this = $3; rest = h':t }-                                in rest `seq` this `seq` sLL $1 (reLoc $>) (this : rest)) }-        | dbinds ';'  {% case unLoc $1 of-                           (h:t) -> do-                             h' <- addTrailingSemiA h (gl $2)-                             return (sLL $1 $> (h':t)) }-        | dbind                        { let this = $1 in this `seq` (sL1 (reLoc $1) [this]) }---      | {- empty -}                  { [] }--dbind   :: { LIPBind GhcPs }-dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->-                                          acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocA $1) $3)) }--ipvar   :: { Located HsIPName }-        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }---------------------------------------------------------------------------------- Overloaded labels--overloaded_label :: { Located (SourceText, FastString) }-        : LABELVARID          { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) }---------------------------------------------------------------------------------- Warnings and deprecations--name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula          { $1 }-        | {- empty -}               { noLocA mkTrue }--name_boolformula :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and                      { $1 }-        | name_boolformula_and '|' name_boolformula-                           {% do { h <- addTrailingVbarL $1 (gl $2)-                                 ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } }--name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and_list-                  { reLocA $ sLLAA (head $1) (last $1) (And ($1)) }--name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }-        : name_boolformula_atom                               { [$1] }-        | name_boolformula_atom ',' name_boolformula_and_list-            {% do { h <- addTrailingCommaL $1 (gl $2)-                  ; return (h : $3) } }--name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }-        : '(' name_boolformula ')'  {% amsrl (sLL $1 $> (Parens $2))-                                      (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }-        | name_var                  { reLocA $ sL1N $1 (Var $1) }--namelist :: { Located [LocatedN RdrName] }-namelist : name_var              { sL1N $1 [$1] }-         | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)-                                       ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}--name_var :: { LocatedN RdrName }-name_var : var { $1 }-         | con { $1 }---------------------------------------------- Data constructors--- There are two different productions here as lifted list constructors--- are parsed differently.--qcon_nowiredlist :: { LocatedN RdrName }-        : gen_qcon                     { $1 }-        | sysdcon_nolist               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--qcon :: { LocatedN RdrName }-  : gen_qcon              { $1}-  | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--gen_qcon :: { LocatedN RdrName }-  : qconid                { $1 }-  | '(' qconsym ')'       {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--con     :: { LocatedN RdrName }-        : conid                 { $1 }-        | '(' consym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }-        | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--con_list :: { Located (NonEmpty (LocatedN RdrName)) }-con_list : con                  { sL1N $1 (pure $1) }-         | con ',' con_list     {% sLL (reLocN $1) $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) }--qcon_list :: { Located [LocatedN RdrName] }-qcon_list : qcon                  { sL1N $1 [$1] }-          | qcon ',' qcon_list    {% do { h <- addTrailingCommaN $1 (gl $2)-                                        ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}---- See Note [ExplicitTuple] in GHC.Hs.Expr-sysdcon_nolist :: { LocatedN DataCon }  -- Wired in data constructors-        : '(' ')'               {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }-        | '(' commas ')'        {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))-                                       (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(#' '#)'             {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }-        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))-                                       (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }---- See Note [Empty lists] in GHC.Hs.Expr-sysdcon :: { LocatedN DataCon }-        : sysdcon_nolist                 { $1 }-        | '[' ']'               {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }--conop :: { LocatedN RdrName }-        : consym                { $1 }-        | '`' conid '`'         {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qconop :: { LocatedN RdrName }-        : qconsym               { $1 }-        | '`' qconid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--------------------------------------------------------------------------------- Type constructors----- See Note [Unit tuples] in GHC.Hs.Type for the distinction--- between gtycon and ntgtycon-gtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, including unit tuples-        : ntgtycon                     { $1 }-        | '(' ')'                      {% amsrn (sLL $1 $> $ getRdrName unitTyCon)-                                                 (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }-        | '(#' '#)'                    {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon)-                                                 (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }--ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit tuples-        : oqtycon               { $1 }-        | '(' commas ')'        {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed-                                                        (snd $2 + 1)))-                                       (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed-                                                        (snd $2 + 1)))-                                       (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(#' bars '#)'        {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))-                                       (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(' '->' ')'          {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                       (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '[' ']'               {% amsrn (sLL $1 $> $ listTyCon_RDR)-                                       (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }--oqtycon :: { LocatedN RdrName }  -- An "ordinary" qualified tycon;-                                -- These can appear in export lists-        : qtycon                        { $1 }-        | '(' qtyconsym ')'             {% amsrn (sLL $1 $> (unLoc $2))-                                                  (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--oqtycon_no_varcon :: { LocatedN RdrName }  -- Type constructor which cannot be mistaken-                                          -- for variable constructor in export lists-                                          -- see Note [Type constructors in export list]-        :  qtycon            { $1 }-        | '(' QCONSYM ')'    {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '(' CONSYM ')'     {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '(' ':' ')'        {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! consDataCon_RDR }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }--{- Note [Type constructors in export list]-~~~~~~~~~~~~~~~~~~~~~-Mixing type constructors and data constructors in export lists introduces-ambiguity in grammar: e.g. (*) may be both a type constructor and a function.---XExplicitNamespaces allows to disambiguate by explicitly prefixing type-constructors with 'type' keyword.--This ambiguity causes reduce/reduce conflicts in parser, which are always-resolved in favour of data constructors. To get rid of conflicts we demand-that ambiguous type constructors (those, which are formed by the same-productions as variable constructors) are always prefixed with 'type' keyword.-Unambiguous type constructors may occur both with or without 'type' keyword.--Note that in the parser we still parse data constructors as type-constructors. As such, they still end up in the type constructor namespace-until after renaming when we resolve the proper namespace for each exported-child.--}--qtyconop :: { LocatedN RdrName } -- Qualified or unqualified-        -- See Note [%shift: qtyconop -> qtyconsym]-        : qtyconsym %shift              { $1 }-        | '`' qtycon '`'                {% amsrn (sLL $1 $> (unLoc $2))-                                                 (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qtycon :: { LocatedN RdrName }   -- Qualified or unqualified-        : QCONID            { sL1n $1 $! mkQual tcClsName (getQCONID $1) }-        | tycon             { $1 }--tycon   :: { LocatedN RdrName }  -- Unqualified-        : CONID                   { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }--qtyconsym :: { LocatedN RdrName }-        : QCONSYM            { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }-        | QVARSYM            { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }-        | tyconsym           { $1 }--tyconsym :: { LocatedN RdrName }-        : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }-        | VARSYM                { sL1n $1 $! mkUnqual tcClsName (getVARSYM $1) }-        | ':'                   { sL1n $1 $! consDataCon_RDR }-        | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }-        | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }---- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.--- These can appear in `ANN type` declarations (#19374).-otycon :: { LocatedN RdrName }-        : tycon                 { $1 }-        | '(' tyconsym ')'      {% amsrn (sLL $1 $> (unLoc $2))-                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }---------------------------------------------------------------------------------- Operators--op      :: { LocatedN RdrName }   -- used in infix decls-        : varop                 { $1 }-        | conop                 { $1 }-        | '->'                  { sL1n $1 $ getRdrName unrestrictedFunTyCon }--varop   :: { LocatedN RdrName }-        : varsym                { $1 }-        | '`' varid '`'         {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qop     :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections-        : qvarop                { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { pvN $1 }--qopm    :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections-        : qvaropm               { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { pvN $1 }--hole_op :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections-hole_op : '`' '_' '`'           { mkHsInfixHolePV (comb2 $1 $>)-                                         (\cs -> EpAnn (glR $1) (EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }--qvarop :: { LocatedN RdrName }-        : qvarsym               { $1 }-        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qvaropm :: { LocatedN RdrName }-        : qvarsym_no_minus      { $1 }-        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }---------------------------------------------------------------------------------- Type variables--tyvar   :: { LocatedN RdrName }-tyvar   : tyvarid               { $1 }--tyvarop :: { LocatedN RdrName }-tyvarop : '`' tyvarid '`'       {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--tyvarid :: { LocatedN RdrName }-        : VARID            { sL1n $1 $! mkUnqual tvName (getVARID $1) }-        | special_id       { sL1n $1 $! mkUnqual tvName (unLoc $1) }-        | 'unsafe'         { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }-        | 'safe'           { sL1n $1 $! mkUnqual tvName (fsLit "safe") }-        | 'interruptible'  { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }-        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]---------------------------------------------------------------------------------- Variables--var     :: { LocatedN RdrName }-        : varid                 { $1 }-        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--qvar    :: { LocatedN RdrName }-        : qvarid                { $1 }-        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }-        | '(' qvarsym1 ')'      {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--- We've inlined qvarsym here so that the decision about--- whether it's a qvar or a var can be postponed until--- *after* we see the close paren.--field :: { LocatedN FieldLabelString  }-      : varid { fmap (FieldLabelString . occNameFS . rdrNameOcc) $1 }--qvarid :: { LocatedN RdrName }-        : varid               { $1 }-        | QVARID              { sL1n $1 $! mkQual varName (getQVARID $1) }---- Note that 'role' and 'family' get lexed separately regardless of--- the use of extensions. However, because they are listed here,--- this is OK and they can be used as normal varids.--- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer-varid :: { LocatedN RdrName }-        : VARID            { sL1n $1 $! mkUnqual varName (getVARID $1) }-        | special_id       { sL1n $1 $! mkUnqual varName (unLoc $1) }-        | 'unsafe'         { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }-        | 'safe'           { sL1n $1 $! mkUnqual varName (fsLit "safe") }-        | 'interruptible'  { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}-        | 'forall'         { sL1n $1 $! mkUnqual varName (fsLit "forall") }-        | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }-        | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }-        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]--qvarsym :: { LocatedN RdrName }-        : varsym                { $1 }-        | qvarsym1              { $1 }--qvarsym_no_minus :: { LocatedN RdrName }-        : varsym_no_minus       { $1 }-        | qvarsym1              { $1 }--qvarsym1 :: { LocatedN RdrName }-qvarsym1 : QVARSYM              { sL1n $1 $ mkQual varName (getQVARSYM $1) }--varsym :: { LocatedN RdrName }-        : varsym_no_minus       { $1 }-        | '-'                   { sL1n $1 $ mkUnqual varName (fsLit "-") }--varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'-        : VARSYM               { sL1n $1 $ mkUnqual varName (getVARSYM $1) }-        | special_sym          { sL1n $1 $ mkUnqual varName (unLoc $1) }----- These special_ids are treated as keywords in various places,--- but as ordinary ids elsewhere.   'special_id' collects all these--- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and--- 'anyclass', whose treatment differs depending on context-special_id :: { Located FastString }-special_id-        : 'as'                  { sL1 $1 (fsLit "as") }-        | 'qualified'           { sL1 $1 (fsLit "qualified") }-        | 'hiding'              { sL1 $1 (fsLit "hiding") }-        | 'export'              { sL1 $1 (fsLit "export") }-        | 'label'               { sL1 $1 (fsLit "label")  }-        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }-        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }-        | 'ccall'               { sL1 $1 (fsLit "ccall") }-        | 'capi'                { sL1 $1 (fsLit "capi") }-        | 'prim'                { sL1 $1 (fsLit "prim") }-        | 'javascript'          { sL1 $1 (fsLit "javascript") }-        -- See Note [%shift: special_id -> 'group']-        | 'group' %shift        { sL1 $1 (fsLit "group") }-        | 'stock'               { sL1 $1 (fsLit "stock") }-        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }-        | 'via'                 { sL1 $1 (fsLit "via") }-        | 'unit'                { sL1 $1 (fsLit "unit") }-        | 'dependency'          { sL1 $1 (fsLit "dependency") }-        | 'signature'           { sL1 $1 (fsLit "signature") }--special_sym :: { Located FastString }-special_sym : '.'       { sL1 $1 (fsLit ".") }-            | '*'       { sL1 $1 (starSym (isUnicode $1)) }---------------------------------------------------------------------------------- Data constructors--qconid :: { LocatedN RdrName }   -- Qualified or unqualified-        : conid              { $1 }-        | QCONID             { sL1n $1 $! mkQual dataName (getQCONID $1) }--conid   :: { LocatedN RdrName }-        : CONID                { sL1n $1 $ mkUnqual dataName (getCONID $1) }--qconsym :: { LocatedN RdrName }  -- Qualified or unqualified-        : consym               { $1 }-        | QCONSYM              { sL1n $1 $ mkQual dataName (getQCONSYM $1) }--consym :: { LocatedN RdrName }-        : CONSYM              { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }--        -- ':' means only list cons-        | ':'                { sL1n $1 $ consDataCon_RDR }----------------------------------------------------------------------------------- Literals--literal :: { Located (HsLit GhcPs) }-        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }-        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)-                                                    $ getSTRING $1 }-        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)-                                                    $ getPRIMINTEGER $1 }-        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)-                                                    $ getPRIMWORD $1 }-        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)-                                                    $ getPRIMCHAR $1 }-        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)-                                                    $ getPRIMSTRING $1 }-        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }-        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }---------------------------------------------------------------------------------- Layout--close :: { () }-        : vccurly               { () } -- context popped in lexer.-        | error                 {% popContext }---------------------------------------------------------------------------------- Miscellaneous (mostly renamings)--modid   :: { LocatedA ModuleName }-        : CONID                 { sL1a $1 $ mkModuleNameFS (getCONID $1) }-        | QCONID                { sL1a $1 $ let (mod,c) = getQCONID $1 in-                                  mkModuleNameFS-                                   (concatFS [mod, fsLit ".", c])-                                }--commas :: { ([SrcSpan],Int) }   -- One or more commas-        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }-        | ','                    { ([gl $1],1) }--bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars-        : bars                   { $1 }-        |                        { ([], 0) }--bars :: { ([SrcSpan],Int) }     -- One or more bars-        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }-        | '|'                    { ([gl $1],1) }--{-happyError :: P a-happyError = srcParseFail--getVARID        (L _ (ITvarid    x)) = x-getCONID        (L _ (ITconid    x)) = x-getVARSYM       (L _ (ITvarsym   x)) = x-getCONSYM       (L _ (ITconsym   x)) = x-getDO           (L _ (ITdo      x)) = x-getMDO          (L _ (ITmdo     x)) = x-getQVARID       (L _ (ITqvarid   x)) = x-getQCONID       (L _ (ITqconid   x)) = x-getQVARSYM      (L _ (ITqvarsym  x)) = x-getQCONSYM      (L _ (ITqconsym  x)) = x-getIPDUPVARID   (L _ (ITdupipvarid   x)) = x-getLABELVARID   (L _ (ITlabelvarid _ x)) = x-getCHAR         (L _ (ITchar   _ x)) = x-getSTRING       (L _ (ITstring _ x)) = x-getINTEGER      (L _ (ITinteger x))  = x-getRATIONAL     (L _ (ITrational x)) = x-getPRIMCHAR     (L _ (ITprimchar _ x)) = x-getPRIMSTRING   (L _ (ITprimstring _ x)) = x-getPRIMINTEGER  (L _ (ITprimint  _ x)) = x-getPRIMWORD     (L _ (ITprimword _ x)) = x-getPRIMFLOAT    (L _ (ITprimfloat x)) = x-getPRIMDOUBLE   (L _ (ITprimdouble x)) = x-getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)-getSPEC_INLINE  (L _ (ITspec_inline_prag src True))  = (Inline src,FunLike)-getSPEC_INLINE  (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike)-getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x-getVOCURLY      (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l--getINTEGERs     (L _ (ITinteger (IL src _ _))) = src-getCHARs        (L _ (ITchar       src _)) = src-getSTRINGs      (L _ (ITstring     src _)) = src-getPRIMCHARs    (L _ (ITprimchar   src _)) = src-getPRIMSTRINGs  (L _ (ITprimstring src _)) = src-getPRIMINTEGERs (L _ (ITprimint    src _)) = src-getPRIMWORDs    (L _ (ITprimword   src _)) = src--getLABELVARIDs   (L _ (ITlabelvarid src _)) = src---- See Note [Pragma source text] in "GHC.Types.Basic" for the following-getINLINE_PRAGs       (L _ (ITinline_prag       _ inl _)) = inlineSpecSource inl-getOPAQUE_PRAGs       (L _ (ITopaque_prag       src))     = src-getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src-getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src-getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src-getRULES_PRAGs        (L _ (ITrules_prag        src)) = src-getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src-getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src-getSCC_PRAGs          (L _ (ITscc_prag          src)) = src-getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src-getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src-getANN_PRAGs          (L _ (ITann_prag          src)) = src-getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src-getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src-getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src-getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src-getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src-getCTYPEs             (L _ (ITctype             src)) = src--getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing--isUnicode :: Located Token -> Bool-isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax-isUnicode (L _ ITlolly)               = True-isUnicode _                           = False--hasE :: Located Token -> Bool-hasE (L _ (ITopenExpQuote HasE _)) = True-hasE (L _ (ITopenTExpQuote HasE))  = True-hasE _                             = False--getSCC :: Located Token -> P FastString-getSCC lt = do let s = getSTRING lt-               -- We probably actually want to be more restrictive than this-               if ' ' `elem` unpackFS s-                   then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC-                   else return s--stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs)-stringLiteralToHsDocWst  = lexStringLiteral parseIdentifier---- Utilities for combining source spans-comb2 :: Located a -> Located b -> SrcSpan-comb2 a b = a `seq` b `seq` combineLocs a b---- Utilities for combining source spans-comb2A :: Located a -> LocatedAn t b -> SrcSpan-comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)--comb2N :: Located a -> LocatedN b -> SrcSpan-comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)--comb2Al :: LocatedAn t a -> Located b -> SrcSpan-comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b--comb3 :: Located a -> Located b -> Located c -> SrcSpan-comb3 a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))--comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan-comb3A a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))--comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan-comb3N a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))--comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan-comb4 a b c d = a `seq` b `seq` c `seq` d `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-                combineSrcSpans (getLoc c) (getLoc d))--comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan-comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))---- strict constructor version:-{-# INLINE sL #-}-sL :: l -> a -> GenLocated l a-sL loc a = loc `seq` a `seq` L loc a---- See Note [Adding location info] for how these utility functions are used---- replaced last 3 CPP macros in this file-{-# INLINE sL0 #-}-sL0 :: a -> Located a-sL0 = L noSrcSpan       -- #define L0   L noSrcSpan--{-# INLINE sL1 #-}-sL1 :: GenLocated l a -> b -> GenLocated l b-sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1A #-}-sL1A :: LocatedAn t a -> b -> Located b-sL1A x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1N #-}-sL1N :: LocatedN a -> b -> Located b-sL1N x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1a #-}-sL1a :: Located a -> b -> LocatedAn t b-sL1a x = sL (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1l #-}-sL1l :: LocatedAn t a -> b -> LocatedAn u b-sL1l x = sL (l2l $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1n #-}-sL1n :: Located a -> b -> LocatedN b-sL1n x = L (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sLL #-}-sLL :: Located a -> Located b -> c -> Located c-sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLa #-}-sLLa :: Located a -> Located b -> c -> LocatedAn t c-sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLlA #-}-sLLlA :: Located a -> LocatedAn t b -> c -> Located c-sLLlA x y = sL (comb2A x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLAl #-}-sLLAl :: LocatedAn t a -> Located b -> c -> Located c-sLLAl x y = sL (comb2A y x) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLAsl #-}-sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c-sLLAsl [] = sL1-sLLAsl (x:_) = sLLAl x--{-# INLINE sLLAA #-}-sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c-sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL   sL (comb2 $1 $>)---{- Note [Adding location info]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~--This is done using the three functions below, sL0, sL1-and sLL.  Note that these functions were mechanically-converted from the three macros that used to exist before,-namely L0, L1 and LL.--They each add a SrcSpan to their argument.--   sL0  adds 'noSrcSpan', used for empty productions-     -- This doesn't seem to work anymore -=chak--   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan-        from that token.--   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from-        the first and last tokens.--These suffice for the majority of cases.  However, we must be-especially careful with empty productions: sLL won't work if the first-or last token on the lhs can represent an empty span.  In these cases,-we have to calculate the span using more of the tokens from the lhs, eg.--        | 'newtype' tycl_hdr '=' newconstr deriving-                { L (comb3 $1 $4 $5)-                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }--We provide comb3 and comb4 functions which are useful in such cases.--Be careful: there's no checking that you actually got this right, the-only symptom will be that the SrcSpans of your syntax will be-incorrect.---}---- Make a source location for the file.  We're a bit lazy here and just--- make a point SrcSpan at line 1, column 0.  Strictly speaking we should--- try to find the span of the whole file (ToDo).-fileSrcSpan :: P SrcSpan-fileSrcSpan = do-  l <- getRealSrcLoc;-  let loc = mkSrcLoc (srcLocFile l) 1 1;-  return (mkSrcSpan loc loc)---- Hint about linear types-hintLinear :: MonadP m => SrcSpan -> m ()-hintLinear span = do-  linearEnabled <- getBit LinearTypesBit-  unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction---- Does this look like (a %m)?-looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool-looksLikeMult ty1 l_op ty2-  | Unqual op_name <- unLoc l_op-  , occNameFS op_name == fsLit "%"-  , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)-  , Strict.Just pct_pos <- getBufSpan (getLocA l_op)-  , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)-  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos-  , bufSpanEnd pct_pos == bufSpanStart ty2_pos-  = True-  | otherwise = False---- Hint about the MultiWayIf extension-hintMultiWayIf :: SrcSpan -> P ()-hintMultiWayIf span = do-  mwiEnabled <- getBit MultiWayIfBit-  unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf---- Hint about explicit-forall-hintExplicitForall :: Located Token -> P ()-hintExplicitForall tok = do-    forall   <- getBit ExplicitForallBit-    rulePrag <- getBit InRulePragBit-    unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $-      (PsErrExplicitForall (isUnicode tok))---- Hint about qualified-do-hintQualifiedDo :: Located Token -> P ()-hintQualifiedDo tok = do-    qualifiedDo   <- getBit QualifiedDoBit-    case maybeQDoDoc of-      Just qdoDoc | not qualifiedDo ->-        addError $ mkPlainErrorMsgEnvelope (getLoc tok) $-          (PsErrIllegalQualifiedDo qdoDoc)-      _ -> return ()-  where-    maybeQDoDoc = case unLoc tok of-      ITdo (Just m) -> Just $ ftext m <> text ".do"-      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"-      t -> Nothing---- When two single quotes don't followed by tyvar or gtycon, we report the--- error as empty character literal, or TH quote that missing proper type--- variable or constructor. See #13450.-reportEmptyDoubleQuotes :: SrcSpan -> P a-reportEmptyDoubleQuotes span = do-    thQuotes <- getBit ThQuotesBit-    addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes--{--%************************************************************************-%*                                                                      *-        Helper functions for generating annotations in the parser-%*                                                                      *-%************************************************************************--For the general principles of the following routines, see Note [exact print annotations]-in GHC.Parser.Annotation---}---- |Construct an AddEpAnn from the annotation keyword and the location--- of the keyword itself-mj :: AnnKeywordId -> Located e -> AddEpAnn-mj a l = AddEpAnn a (srcSpan2e $ gl l)--mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn-mjN a l = AddEpAnn a (srcSpan2e $ glN l)---- |Construct an AddEpAnn from the annotation keyword and the location--- of the keyword itself, provided the span is not zero width-mz :: AnnKeywordId -> Located e -> [AddEpAnn]-mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]--msemi :: Located e -> [TrailingAnn]-msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]--msemim :: Located e -> Maybe EpaLocation-msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)---- |Construct an AddEpAnn from the annotation keyword and the Located Token. If--- the token has a unicode equivalent and this has been used, provide the--- unicode variant of the annotation.-mu :: AnnKeywordId -> Located Token -> AddEpAnn-mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)---- | If the 'Token' is using its unicode variant return the unicode variant of---   the annotation-toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId-toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a--toUnicode :: Located Token -> IsUnicodeSyntax-toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax--gl :: GenLocated l a -> l-gl = getLoc--glA :: LocatedAn t a -> SrcSpan-glA = getLocA--glN :: LocatedN a -> SrcSpan-glN = getLocA--glR :: Located a -> Anchor-glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor--glAA :: Located a -> EpaLocation-glAA = srcSpan2e . getLoc--glRR :: Located a -> RealSrcSpan-glRR = realSrcSpan . getLoc--glAR :: LocatedAn t a -> Anchor-glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor--glNR :: LocatedN a -> Anchor-glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor--glNRR :: LocatedN a -> EpaLocation-glNRR = srcSpan2e . getLocA--anc :: RealSrcSpan -> Anchor-anc r = Anchor r UnchangedAnchor--acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)-acs a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor l-  return (a cs)---- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.-acsFinal :: (EpAnnComments -> Located a) -> P (Located a)-acsFinal a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor l-  csf <- getFinalCommentsFor l-  meof <- getEofPos-  let ce = case meof of-             Strict.Nothing  -> EpaComments []-             Strict.Just (pos `Strict.And` gap) ->-               EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]-  return (a (cs Semi.<> csf Semi.<> ce))--acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)-acsa a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor (locA l)-  return (a cs)--acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)-acsA a = reLocA <$> acs a--acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP-acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a-               ; return (ecpFromExp $ expr) }--amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)-amsA (L l a) bs = do-  cs <- getCommentsFor (locA l)-  return (L (addAnnsA l bs cs) a)--amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)-amsAl (L l a) loc bs = do-  cs <- getCommentsFor loc-  return (L (addAnnsA l bs cs) a)--amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a)-amsrc a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnC bs cs a)--amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a)-amsrl a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnL bs cs a)--amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a)-amsrp a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnL bs cs a)--amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)-amsrn (L l a) an = do-  cs <- getCommentsFor l-  let ann = (EpAnn (spanAsAnchor l) an cs)-  return (L (SrcSpanAnn ann l) a)---- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose-mo,mc :: Located Token -> AddEpAnn-mo ll = mj AnnOpen ll-mc ll = mj AnnClose ll--moc,mcc :: Located Token -> AddEpAnn-moc ll = mj AnnOpenC ll-mcc ll = mj AnnCloseC ll--mop,mcp :: Located Token -> AddEpAnn-mop ll = mj AnnOpenP ll-mcp ll = mj AnnCloseP ll--moh,mch :: Located Token -> AddEpAnn-moh ll = mj AnnOpenPH ll-mch ll = mj AnnClosePH ll--mos,mcs :: Located Token -> AddEpAnn-mos ll = mj AnnOpenS ll-mcs ll = mj AnnCloseS ll--pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)-pvA a = do { av <- a-           ; return (reLocA av) }--pvN :: MonadP m => m (Located a) -> m (LocatedN a)-pvN a = do { (L l av) <- a-           ; return (L (noAnnSrcSpan l) av) }--pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)-pvL a = do { av <- a-           ; return (reLoc av) }---- | Parse a Haskell module with Haddock comments.--- This is done in two steps:------ * 'parseModuleNoHaddock' to build the AST--- * 'addHaddockToModule' to insert Haddock comments into it------ This is the only parser entry point that deals with Haddock comments.--- The other entry points ('parseDeclaration', 'parseExpression', etc) do--- not insert them into the AST.-parseModule :: P (Located (HsModule GhcPs))-parseModule = parseModuleNoHaddock >>= addHaddockToModule--commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)-commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc---- | Instead of getting the *enclosed* comments, this includes the--- *preceding* ones.  It is used at the top level to get comments--- between top level declarations.-commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)-commentsPA la@(L l a) = do-  cs <- getPriorCommentsFor (getLocA la)-  return (L (addCommentsToSrcAnn l cs) a)--rs :: SrcSpan -> RealSrcSpan-rs (RealSrcSpan l _) = l-rs _ = panic "Parser should only have RealSrcSpan"--hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList-hsDoAnn (L l _) (L ll _) kw-  = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []--listAsAnchor :: [LocatedAn t a] -> Anchor-listAsAnchor [] = spanAsAnchor noSrcSpan-listAsAnchor (L l _:_) = spanAsAnchor (locA l)--hsTok :: Located Token -> LHsToken tok GhcPs-hsTok (L l _) = L (mkTokenLocation l) HsTok--hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs-hsUniTok t@(L l _) =-  L (mkTokenLocation l)-    (if isUnicode t then HsUnicodeTok else HsNormalTok)--explicitBraces :: Located Token -> Located Token -> LayoutInfo GhcPs-explicitBraces t1 t2 = ExplicitBraces (hsTok t1) (hsTok t2)---- ---------------------------------------addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)-addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)-addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)--addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn--addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn--addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingCommaA  la span = addTrailingAnnA la span AddCommaAnn--addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)-addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do-  -- cs <- getCommentsFor l-  let cs = emptyComments-  -- AZ:TODO: generalise updating comments into an annotation-  let-    anns' = if isZeroWidthSpan ss-              then anns-              else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns-  return (L (SrcSpanAnn anns' l) a)---- ---------------------------------------addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)-addTrailingVbarL  la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span))--addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)-addTrailingCommaL  la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span))--addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)-addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do-  cs <- getCommentsFor l-  let anns' = addTrailingAnnToL l ta cs anns-  return (L (SrcSpanAnn anns' l) a)---- ----------------------------------------- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation-addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)-addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do-  -- cs <- getCommentsFor l-  let cs = emptyComments-  -- AZ:TODO: generalise updating comments into an annotation-  let anns' = if isZeroWidthSpan span-                then anns-                else addTrailingCommaToN l anns (srcSpan2e span)-  return (L (SrcSpanAnn anns' l) a)--addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral-addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) })---- ---------------------------------------addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a-addTrailingDarrowC (L (SrcSpanAnn EpAnnNotUsed l) a) lt cs =-  let-    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax-  in L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a-addTrailingDarrowC (L (SrcSpanAnn (EpAnn lr (AnnContext _ o c) csc) l) a) lt cs =-  let-    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax-  in L (SrcSpanAnn (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a---- ----------------------------------------- We need a location for the where binds, when computing the SrcSpan--- for the AST element using them.  Where there is a span, we return--- it, else noLoc, which is ignored in the comb2 call.-adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))-                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)-adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)-adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)-+{-# 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.+-- A common usage pattern is to initialize the parser state with a given string+-- and then parse that string:+--+-- @+--     runParser :: ParserOpts -> String -> P a -> ParseResult a+--     runParser opts str parser = unP parser parseState+--     where+--       filename = "\<interactive\>"+--       location = mkRealSrcLoc (mkFastString filename) 1 1+--       buffer = stringToStringBuffer str+--       parseState = initParserState opts buffer location+-- @+module GHC.Parser+   ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack+   , parseDeclaration, parseExpression, parsePattern+   , parseTypeSignature+   , parseStmt, parseIdentifier+   , parseType, parseHeader+   , parseModuleNoHaddock+   )+where++-- base+import Control.Monad      ( unless, liftM, when, (<=<) )+import GHC.Exts+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++import GHC.Hs++import GHC.Driver.Backpack.Syntax++import GHC.Unit.Info+import GHC.Unit.Module+import GHC.Unit.Module.Warnings++import GHC.Data.OrdList+import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue )+import GHC.Data.FastString+import GHC.Data.Maybe          ( orElse )++import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )+import GHC.Utils.Panic+import GHC.Prelude hiding ( head, init, last, tail )+import qualified GHC.Data.Strict as Strict++import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS)+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Error ( GhcHint(..) )+import GHC.Types.Fixity+import GHC.Types.ForeignCall+import GHC.Types.SourceFile+import GHC.Types.SourceText+import GHC.Types.PkgQual++import GHC.Core.Type    ( Specificity(..) )+import GHC.Core.Class   ( FunDep )+import GHC.Core.DataCon ( DataCon, dataConName )++import GHC.Parser.PostProcess+import GHC.Parser.PostProcess.Haddock+import GHC.Parser.Lexer+import GHC.Parser.HaddockLex+import GHC.Parser.Annotation+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()++import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,+                           tupleTyCon, tupleDataCon, nilDataCon,+                           unboxedUnitTyCon, unboxedUnitDataCon,+                           listTyCon_RDR, consDataCon_RDR,+                           unrestrictedFunTyCon )++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import qualified Data.Semigroup as Semi+}++%expect 0 -- shift/reduce conflicts++{- Note [shift/reduce conflicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'happy' tool turns this grammar into an efficient parser that follows the+shift-reduce parsing model. There's a parse stack that contains items parsed so+far (both terminals and non-terminals). Every next token produced by the lexer+results in one of two actions:++  SHIFT:    push the token onto the parse stack++  REDUCE:   pop a few items off the parse stack and combine them+            with a function (reduction rule)++However, sometimes it's unclear which of the two actions to take.+Consider this code example:++    if x then y else f z++There are two ways to parse it:++    (if x then y else f) z+    if x then y else (f z)++How is this determined? At some point, the parser gets to the following state:++  parse stack:  'if' exp 'then' exp 'else' "f"+  next token:   "z"++Scenario A (simplified):++  1. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp+             next token:  "z"+        (Note that "f" reduced to exp here)++  2. REDUCE, parse stack: exp+             next token:  "z"++  3. SHIFT,  parse stack: exp "z"+             next token:  ...++  4. REDUCE, parse stack: exp+             next token:  ...++  This way we get:  (if x then y else f) z++Scenario B (simplified):++  1. SHIFT,  parse stack: 'if' exp 'then' exp 'else' "f" "z"+             next token:  ...++  2. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp+             next token:  ...++  3. REDUCE, parse stack: exp+             next token:  ...++  This way we get:  if x then y else (f z)++The end result is determined by the chosen action. When Happy detects this, it+reports a shift/reduce conflict. At the top of the file, we have the following+directive:++  %expect 0++It means that we expect no unresolved shift/reduce conflicts in this grammar.+If you modify the grammar and get shift/reduce conflicts, follow the steps+below to resolve them.++STEP ONE+  is to figure out what causes the conflict.+  That's where the -i flag comes in handy:++      happy -agc --strict compiler/GHC/Parser.y -idetailed-info++  By analysing the output of this command, in a new file `detailed-info`, you+  can figure out which reduction rule causes the issue. At the top of the+  generated report, you will see a line like this:++      state 147 contains 67 shift/reduce conflicts.++  Scroll down to section State 147 (in your case it could be a different+  state). The start of the section lists the reduction rules that can fire+  and shows their context:++        exp10 -> fexp .                 (rule 492)+        fexp -> fexp . aexp             (rule 498)+        fexp -> fexp . PREFIX_AT atype  (rule 499)++  And then, for every token, it tells you the parsing action:++        ']'            reduce using rule 492+        '::'           reduce using rule 492+        '('            shift, and enter state 178+        QVARID         shift, and enter state 44+        DO             shift, and enter state 182+        ...++  But if you look closer, some of these tokens also have another parsing action+  in parentheses:++        QVARID    shift, and enter state 44+                   (reduce using rule 492)++  That's how you know rule 492 is causing trouble.+  Scroll back to the top to see what this rule is:++        ----------------------------------+        Grammar+        ----------------------------------+        ...+        ...+        exp10 -> fexp                (492)+        optSemi -> ';'               (493)+        ...+        ...++  Hence the shift/reduce conflict is caused by this parser production:++        exp10 :: { ECP }+                : '-' fexp    { ... }+                | fexp        { ... }    -- problematic rule++STEP TWO+  is to mark the problematic rule with the %shift pragma. This signals to+  'happy' that any shift/reduce conflicts involving this rule must be resolved+  in favor of a shift. There's currently no dedicated pragma to resolve in+  favor of the reduce.++STEP THREE+  is to add a dedicated Note for this specific conflict, as is done for all+  other conflicts below.+-}++{- Note [%shift: rule_activation -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    rule -> STRING . rule_activation rule_foralls infixexp '=' exp++Example:+    {-# RULES "name" [0] f = rhs #-}++Ambiguity:+    If we reduced, then we'd get an empty activation rule, and [0] would be+    parsed as part of the left-hand side expression.++    We shift, so [0] is parsed as an activation rule.+-}++{- Note [%shift: rule_foralls -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    rule -> STRING rule_activation . rule_foralls infixexp '=' exp++Example:+    {-# RULES "name" forall a1. lhs = rhs #-}++Ambiguity:+    If we reduced, then we would get an empty rule_foralls; the 'forall', being+    a valid term-level identifier, would be parsed as part of the left-hand+    side expression.++    We shift, so the 'forall' is parsed as part of rule_foralls.+-}++{- Note [%shift: type -> btype]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    context -> btype .+    type -> btype .+    type -> btype . '->' ctype+    type -> btype . '->.' ctype++Example:+    a :: Maybe Integer -> Bool++Ambiguity:+    If we reduced, we would get:   (a :: Maybe Integer) -> Bool+    We shift to get this instead:  a :: (Maybe Integer -> Bool)+-}++{- Note [%shift: infixtype -> ftype]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    infixtype -> ftype .+    infixtype -> ftype . tyop infixtype+    ftype -> ftype . tyarg+    ftype -> ftype . PREFIX_AT tyarg++Example:+    a :: Maybe Integer++Ambiguity:+    If we reduced, we would get:    (a :: Maybe) Integer+    We shift to get this instead:   a :: (Maybe Integer)+-}++{- Note [%shift: atype -> tyvar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    atype -> tyvar .+    tv_bndr_no_braces -> '(' tyvar . '::' kind ')'++Example:+    class C a where type D a = (a :: Type ...++Ambiguity:+    If we reduced, we could specify a default for an associated type like this:++      class C a where type D a+                      type D a = (a :: Type)++    But we shift in order to allow injectivity signatures like this:++      class C a where type D a = (r :: Type) | r -> a+-}++{- Note [%shift: exp -> infixexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp -> infixexp . '::' sigtype+    exp -> infixexp . '-<' exp+    exp -> infixexp . '>-' exp+    exp -> infixexp . '-<<' exp+    exp -> infixexp . '>>-' exp+    exp -> infixexp .+    infixexp -> infixexp . qop exp10p++Examples:+    1) if x then y else z -< e+    2) if x then y else z :: T+    3) if x then y else z + 1   -- (NB: '+' is in VARSYM)++Ambiguity:+    If we reduced, we would get:++      1) (if x then y else z) -< e+      2) (if x then y else z) :: T+      3) (if x then y else z) + 1++    We shift to get this instead:++      1) if x then y else (z -< e)+      2) if x then y else (z :: T)+      3) if x then y else (z + 1)+-}++{- Note [%shift: exp10 -> '-' fexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp10 -> '-' fexp .+    fexp -> fexp . aexp+    fexp -> fexp . PREFIX_AT atype++Examples & Ambiguity:+    Same as in Note [%shift: exp10 -> fexp],+    but with a '-' in front.+-}++{- Note [%shift: exp10 -> fexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp10 -> fexp .+    fexp -> fexp . aexp+    fexp -> fexp . PREFIX_AT atype++Examples:+    1) if x then y else f z+    2) if x then y else f @z++Ambiguity:+    If we reduced, we would get:++      1) (if x then y else f) z+      2) (if x then y else f) @z++    We shift to get this instead:++      1) if x then y else (f z)+      2) if x then y else (f @z)+-}++{- Note [%shift: aexp2 -> ipvar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    aexp2 -> ipvar .+    dbind -> ipvar . '=' exp++Example:+    let ?x = ...++Ambiguity:+    If we reduced, ?x would be parsed as the LHS of a normal binding,+    eventually producing an error.++    We shift, so it is parsed as the LHS of an implicit binding.+-}++{- Note [%shift: aexp2 -> TH_TY_QUOTE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    aexp2 -> TH_TY_QUOTE . tyvar+    aexp2 -> TH_TY_QUOTE . gtycon+    aexp2 -> TH_TY_QUOTE .++Examples:+    1) x = ''+    2) x = ''a+    3) x = ''T++Ambiguity:+    If we reduced, the '' would result in reportEmptyDoubleQuotes even when+    followed by a type variable or a type constructor. But the only reason+    this reduction rule exists is to improve error messages.++    Naturally, we shift instead, so that ''a and ''T work as expected.+-}++{- Note [%shift: tup_tail -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    tup_exprs -> commas . tup_tail+    sysdcon_nolist -> '(' commas . ')'+    sysdcon_nolist -> '(#' commas . '#)'+    commas -> commas . ','++Example:+    (,,)++Ambiguity:+    A tuple section with no components is indistinguishable from the Haskell98+    data constructor for a tuple.++    If we reduced, (,,) would be parsed as a tuple section.+    We shift, so (,,) is parsed as a data constructor.++    This is preferable because we want to accept (,,) without -XTupleSections.+    See also Note [ExplicitTuple] in GHC.Hs.Expr.+-}++{- Note [%shift: qtyconop -> qtyconsym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    oqtycon -> '(' qtyconsym . ')'+    qtyconop -> qtyconsym .++Example:+    foo :: (:%)++Ambiguity:+    If we reduced, (:%) would be parsed as a parenthesized infix type+    expression without arguments, resulting in the 'failOpFewArgs' error.++    We shift, so it is parsed as a type constructor.+-}++{- Note [%shift: special_id -> 'group']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    transformqual -> 'then' 'group' . 'using' exp+    transformqual -> 'then' 'group' . 'by' exp 'using' exp+    special_id -> 'group' .++Example:+    [ ... | then group by dept using groupWith+          , then take 5 ]++Ambiguity:+    If we reduced, 'group' would be parsed as a term-level identifier, just as+    'take' in the other clause.++    We shift, so it is parsed as part of the 'group by' clause introduced by+    the -XTransformListComp extension.+-}++{- Note [%shift: activation -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'+    activation -> {- empty -}+    activation -> explicit_activation++Example:++    {-# INLINE [0] Something #-}++Ambiguity:+    We don't know whether the '[' is the start of the activation or the beginning+    of the [] data constructor.+    We parse this as having '[0]' activation for inlining 'Something', rather than+    empty activation and inlining '[0] Something'.+-}++{- Note [%shift: orpats -> exp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:++    texp -> exp .+    orpats -> exp .+    texp -> exp . '->' texp+    orpats -> exp . ';' orpats++    in Lookahead ')': reduce/reduce conflict between the two first productions++Example:++    f (True) = 3+       ----^++Ambiguity:+    We don't know whether the ')' encloses a parenthesized pat (reduce with+    first production) or a unary Or pattern (reduce with second production).+    We want to parse it as a parenthesized pat, because+      * That is the status quo+      * Parsing it as a unary Or patterns prompts the user to activate -XOrPatterns.+    Thus, we add a %shift pragma to `orpats -> exp` to lower its precedence,+    which has the effect of letting `texp -> exp` win (!).++An alternative to resolve this ambiguity would be to accept only OrPatterns+with at least two patterns in `orpats`, just as in `tup_exprs`.+But the present code seems simpler, because it just needs one non-terminal,+at the expense of using a small pragma.+-}++{- Note [Parser API Annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A lot of the productions are now cluttered with calls to+aa,am,acs,acsA etc.++These are helper functions to make sure that the locations of the+various keywords such as do / let / in are captured for use by tools+that want to do source to source conversions, such as refactorers or+structured editors.++The helper functions are defined at the bottom of this file.++See+  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and+  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations+for some background.++-}++{- Note [Parsing lists]+~~~~~~~~~~~~~~~~~~~~~~~+You might be wondering why we spend so much effort encoding our lists this+way:++importdecls+        : importdecls ';' importdecl+        | importdecls ';'+        | importdecl+        | {- empty -}++This might seem like an awfully roundabout way to declare a list; plus, to add+insult to injury you have to reverse the results at the end.  The answer is that+left recursion prevents us from running out of stack space when parsing long+sequences. See:+https://haskell-happy.readthedocs.io/en/latest/using.html#parsing-sequences+for more guidance.++By adding/removing branches, you can affect what lists are accepted.  Here+are the most common patterns, rewritten as regular expressions for clarity:++    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)+    xs : xs ';' x+       | xs ';'+       | x+       | {- empty -}++    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)+    xs : xs ';' x+       | xs ';'+       | x++    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)+    alts : alts1+         | ';' alts+    alts1 : alts1 ';' alt+          | alts1 ';'+          | alt++    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)+    xs : x+       | x ',' xs+-}++%token+ '_'            { L _ ITunderscore }            -- Haskell keywords+ 'as'           { L _ ITas }+ 'case'         { L _ ITcase }+ 'class'        { L _ ITclass }+ 'data'         { L _ ITdata }+ 'default'      { L _ ITdefault }+ 'deriving'     { L _ ITderiving }+ 'else'         { L _ ITelse }+ 'hiding'       { L _ IThiding }+ 'if'           { L _ ITif }+ 'import'       { L _ ITimport }+ 'in'           { L _ ITin }+ 'infix'        { L _ ITinfix }+ 'infixl'       { L _ ITinfixl }+ 'infixr'       { L _ ITinfixr }+ 'instance'     { L _ ITinstance }+ 'let'          { L _ ITlet }+ 'module'       { L _ ITmodule }+ 'newtype'      { L _ ITnewtype }+ 'of'           { L _ ITof }+ 'qualified'    { L _ ITqualified }+ 'then'         { L _ ITthen }+ 'type'         { L _ ITtype }+ 'where'        { L _ ITwhere }++ 'forall'       { L _ (ITforall _) }                -- GHC extension keywords+ 'foreign'      { L _ ITforeign }+ 'export'       { L _ ITexport }+ 'label'        { L _ ITlabel }+ 'dynamic'      { L _ ITdynamic }+ 'safe'         { L _ ITsafe }+ 'interruptible' { L _ ITinterruptible }+ 'unsafe'       { L _ ITunsafe }+ 'family'       { L _ ITfamily }+ 'role'         { L _ ITrole }+ 'stdcall'      { L _ ITstdcallconv }+ 'ccall'        { L _ ITccallconv }+ 'capi'         { L _ ITcapiconv }+ 'prim'         { L _ ITprimcallconv }+ 'javascript'   { L _ ITjavascriptcallconv }+ 'proc'         { L _ ITproc }          -- for arrow notation extension+ 'rec'          { L _ ITrec }           -- for arrow notation extension+ 'group'    { L _ ITgroup }     -- for list transform extension+ 'by'       { L _ ITby }        -- for list transform extension+ 'using'    { L _ ITusing }     -- for list transform extension+ 'pattern'      { L _ ITpattern } -- for pattern synonyms+ 'static'       { L _ ITstatic }  -- for static pointers extension+ '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 }+ 'dependency'   { L _ ITdependency }++ '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE+ '{-# OPAQUE'             { L _ (ITopaque_prag _) }+ '{-# SPECIALISE'         { L _ (ITspec_prag _) }+ '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }+ '{-# SOURCE'             { L _ (ITsource_prag _) }+ '{-# RULES'              { L _ (ITrules_prag _) }+ '{-# SCC'                { L _ (ITscc_prag _)}+ '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }+ '{-# WARNING'            { L _ (ITwarning_prag _) }+ '{-# UNPACK'             { L _ (ITunpack_prag _) }+ '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }+ '{-# ANN'                { L _ (ITann_prag _) }+ '{-# MINIMAL'            { L _ (ITminimal_prag _) }+ '{-# CTYPE'              { L _ (ITctype _) }+ '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }+ '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }+ '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }+ '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }+ '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }+ '#-}'                    { L _ ITclose_prag }++ '..'           { L _ ITdotdot }                        -- reserved symbols+ ':'            { L _ ITcolon }+ '::'           { L _ (ITdcolon _) }+ '='            { L _ ITequal }+ '\\'           { L _ ITlam }+ 'lcase'        { L _ ITlcase }+ 'lcases'       { L _ ITlcases }+ '|'            { L _ ITvbar }+ '<-'           { L _ (ITlarrow _) }+ '->'           { L _ (ITrarrow _) }+ '->.'          { L _ ITlolly }+ TIGHT_INFIX_AT { L _ ITat }+ '=>'           { L _ (ITdarrow _) }+ '-'            { L _ ITminus }+ PREFIX_TILDE   { L _ ITtilde }+ PREFIX_BANG    { L _ ITbang }+ PREFIX_MINUS   { L _ ITprefixminus }+ '*'            { L _ (ITstar _) }+ '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation+ '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation+ '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation+ '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation+ '.'            { L _ ITdot }+ PREFIX_PROJ    { L _ (ITproj True) }               -- RecordDotSyntax+ TIGHT_INFIX_PROJ { L _ (ITproj False) }            -- RecordDotSyntax+ PREFIX_AT      { L _ ITtypeApp }+ PREFIX_PERCENT { L _ ITpercent }                   -- for linear types++ '{'            { L _ ITocurly }                        -- special symbols+ '}'            { L _ ITccurly }+ vocurly        { L _ ITvocurly } -- virtual open curly (from layout)+ vccurly        { L _ ITvccurly } -- virtual close curly (from layout)+ '['            { L _ ITobrack }+ ']'            { L _ ITcbrack }+ '('            { L _ IToparen }+ ')'            { L _ ITcparen }+ '(#'           { L _ IToubxparen }+ '#)'           { L _ ITcubxparen }+ '(|'           { L _ (IToparenbar _) }+ '|)'           { L _ (ITcparenbar _) }+ ';'            { L _ ITsemi }+ ','            { L _ ITcomma }+ '`'            { L _ ITbackquote }+ SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x++ VARID          { L _ (ITvarid    _) }          -- identifiers+ CONID          { L _ (ITconid    _) }+ VARSYM         { L _ (ITvarsym   _) }+ CONSYM         { L _ (ITconsym   _) }+ QVARID         { L _ (ITqvarid   _) }+ QCONID         { L _ (ITqconid   _) }+ QVARSYM        { L _ (ITqvarsym  _) }+ QCONSYM        { L _ (ITqconsym  _) }+++ -- QualifiedDo+ DO             { L _ (ITdo  _) }+ MDO            { L _ (ITmdo _) }++ IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension+ LABELVARID     { L _ (ITlabelvarid _ _) }++ CHAR           { L _ (ITchar   _ _) }+ STRING         { L _ (ITstring _ _) }+ STRING_MULTI   { L _ (ITstringMulti _ _) }+ INTEGER        { L _ (ITinteger _) }+ RATIONAL       { L _ (ITrational _) }++ PRIMCHAR       { L _ (ITprimchar   _ _) }+ PRIMSTRING     { L _ (ITprimstring _ _) }+ PRIMINTEGER    { L _ (ITprimint    _ _) }+ PRIMWORD       { L _ (ITprimword   _ _) }+ PRIMINTEGER8   { L _ (ITprimint8   _ _) }+ PRIMINTEGER16  { L _ (ITprimint16  _ _) }+ PRIMINTEGER32  { L _ (ITprimint32  _ _) }+ PRIMINTEGER64  { L _ (ITprimint64  _ _) }+ PRIMWORD8      { L _ (ITprimword8  _ _) }+ PRIMWORD16     { L _ (ITprimword16 _ _) }+ PRIMWORD32     { L _ (ITprimword32 _ _) }+ PRIMWORD64     { L _ (ITprimword64 _ _) }+ PRIMFLOAT      { L _ (ITprimfloat  _) }+ PRIMDOUBLE     { L _ (ITprimdouble _) }++-- Template Haskell+'[|'            { L _ (ITopenExpQuote _ _) }+'[p|'           { L _ ITopenPatQuote  }+'[t|'           { L _ ITopenTypQuote  }+'[d|'           { L _ ITopenDecQuote  }+'|]'            { L _ (ITcloseQuote _) }+'[||'           { L _ (ITopenTExpQuote _) }+'||]'           { L _ ITcloseTExpQuote  }+PREFIX_DOLLAR   { L _ ITdollar }+PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }+TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T+TH_QUASIQUOTE   { L _ (ITquasiQuote _) }+TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }++%monad { P } { >>= } { return }+%lexer { (lexer True) } { L _ ITeof }+  -- Replace 'lexer' above with 'lexerDbg'+  -- to dump the tokens fed to the parser.+%tokentype { (Located Token) }++-- Exported parsers+%name parseModuleNoHaddock module+%name parseSignatureNoHaddock signature+%name parseImport importdecl+%name parseStatement e_stmt+%name parseDeclaration topdecl+%name parseExpression exp+%name parsePattern pat+%name parseTypeSignature sigdecl+%name parseStmt   maybe_stmt+%name parseIdentifier  identifier+%name parseType ktype+%name parseBackpack backpack+%partial parseHeader header+%%++-----------------------------------------------------------------------------+-- Identifiers; one of the entry points+identifier :: { LocatedN RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }+        | qvarop                        { $1 }+        | qconop                        { $1 }+    | '->'              {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                (NameAnnRArrow  Nothing (epUniTok $1) Nothing []) }++-----------------------------------------------------------------------------+-- Backpack stuff++backpack :: { [LHsUnit PackageName] }+         : implicit_top units close { fromOL $2 }+         | '{' units '}'            { fromOL $2 }++units :: { OrdList (LHsUnit PackageName) }+         : units ';' unit { $1 `appOL` unitOL $3 }+         | units ';'      { $1 }+         | unit           { unitOL $1 }++unit :: { LHsUnit PackageName }+        : 'unit' pkgname 'where' unitbody+            { sL1 $1 $ HsUnit { hsunitName = $2+                              , hsunitBody = fromOL $4 } }++unitid :: { LHsUnitId PackageName }+        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }+        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }++msubsts :: { OrdList (LHsModuleSubst PackageName) }+        : msubsts ',' msubst { $1 `appOL` unitOL $3 }+        | msubsts ','        { $1 }+        | msubst             { unitOL $1 }++msubst :: { LHsModuleSubst PackageName }+        : modid '=' moduleid { sLL $1 $> $ (reLoc $1, $3) }+        | modid VARSYM modid VARSYM { sLL $1 $> $ (reLoc $1, sLL $2 $> $ HsModuleVar (reLoc $3)) }++moduleid :: { LHsModuleId PackageName }+          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar (reLoc $2) }+          | unitid ':' modid    { sLL $1 $> $ HsModuleId $1 (reLoc $3) }++pkgname :: { Located PackageName }+        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }+        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }++litpkgname_segment :: { Located FastString }+        : VARID  { sL1 $1 $ getVARID $1 }+        | CONID  { sL1 $1 $ getCONID $1 }+        | special_id { $1 }++-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.+-- See Note [Minus tokens] in GHC.Parser.Lexer+HYPHEN :: { () }+      : '-'          { () }+      | PREFIX_MINUS { () }+      | VARSYM       { () }++litpkgname :: { Located FastString }+        : litpkgname_segment { $1 }+        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.+        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] }++mayberns :: { Maybe [LRenaming] }+        : {- empty -} { Nothing }+        | '(' rns ')' { Just (fromOL $2) }++rns :: { OrdList LRenaming }+        : rns ',' rn { $1 `appOL` unitOL $3 }+        | rns ','    { $1 }+        | rn         { unitOL $1 }++rn :: { LRenaming }+        : modid 'as' modid { sLL $1 $> $ Renaming (reLoc $1) (Just (reLoc $3)) }+        | modid            { sL1 $1    $ Renaming (reLoc $1) Nothing }++unitbody :: { OrdList (LHsUnitDecl PackageName) }+        : '{'     unitdecls '}'   { $2 }+        | vocurly unitdecls close { $2 }++unitdecls :: { OrdList (LHsUnitDecl PackageName) }+        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }+        | unitdecls ';'         { $1 }+        | unitdecl              { unitOL $1 }++unitdecl :: { LHsUnitDecl PackageName }+        : 'module' maybe_src modid maybe_warning_pragma maybeexports 'where' body+             -- XXX not accurate+             { sL1 $1 $ DeclD+                 (case snd $2 of+                   NotBoot -> HsSrcFile+                   IsBoot  -> HsBootFile)+                 (reLoc $3)+                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) }+        | 'signature' modid maybe_warning_pragma maybeexports 'where' body+             { sL1 $1 $ DeclD+                 HsigFile+                 (reLoc $2)+                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) }+        | 'dependency' unitid mayberns+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2+                                              , idModRenaming = $3+                                              , idSignatureInclude = False }) }+        | 'dependency' 'signature' unitid+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3+                                              , idModRenaming = Nothing+                                              , idSignatureInclude = True }) }++-----------------------------------------------------------------------------+-- Module Header++-- The place for module deprecation is really too restrictive, but if it+-- was allowed at its natural place just before 'module', we get an ugly+-- s/r conflict with the second alternative. Another solution would be the+-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,+-- either, and DEPRECATED is only expected to be used by people who really+-- know what they are doing. :-)++signature :: { Located (HsModule GhcPs) }+       : 'signature' modid maybe_warning_pragma maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                acs loc (\loc cs-> (L loc (HsModule (XModulePs+                                               (EpAnn (spanAsAnchor loc) (AnnsModule (epTok $1) NoEpTok (epTok $5) (fstOf3 $6) [] Nothing) cs)+                                               (thdOf3 $6) $3 Nothing)+                                            (Just $2) $4 (fst $ sndOf3 $6)+                                            (snd $ sndOf3 $6)))+                    ) }++module :: { Located (HsModule GhcPs) }+       : 'module' modid maybe_warning_pragma maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                acsFinal (\cs eof -> (L loc (HsModule (XModulePs+                                                     (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) (fstOf3 $6) [] eof) cs)+                                                     (thdOf3 $6) $3 Nothing)+                                                  (Just $2) $4 (fst $ sndOf3 $6)+                                                  (snd $ sndOf3 $6))+                    )) }+        | body2+                {% fileSrcSpan >>= \ loc ->+                   acsFinal (\cs eof -> (L loc (HsModule (XModulePs+                                                        (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok NoEpTok NoEpTok (fstOf3 $1) [] eof) cs)+                                                        (thdOf3 $1) Nothing Nothing)+                                                     Nothing Nothing+                                                     (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }++missing_module_keyword :: { () }+        : {- empty -}                           {% pushModuleContext }++implicit_top :: { () }+        : {- empty -}                           {% pushModuleContext }++body    :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,EpLayout) }+        :  '{'            top '}'      { (fst $2, snd $2, epExplicitBraces $1 $3) }+        |      vocurly    top close    { (fst $2, snd $2, EpVirtualBraces (getVOCURLY $1)) }++body2   :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,EpLayout) }+        :  '{' top '}'                          { (fst $2, snd $2, epExplicitBraces $1 $3) }+        |  missing_module_keyword top close     { ([], snd $2, EpVirtualBraces leftmostColumn) }+++top     :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }+        : semis top1                            { (reverse $1, $2) }++top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }+        : importdecls_semi topdecls_cs_semi        { (reverse $1, cvTopDecls $2) }+        | importdecls_semi topdecls_cs             { (reverse $1, cvTopDecls $2) }+        | importdecls                              { (reverse $1, []) }++-----------------------------------------------------------------------------+-- Module declaration & imports only++header  :: { Located (HsModule GhcPs) }+        : 'module' modid maybe_warning_pragma maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   acs loc (\loc cs -> (L loc (HsModule (XModulePs+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok  $1) (epTok $5) [] [] Nothing) cs)+                                                   EpNoLayout $3 Nothing)+                                                (Just $2) $4 $6 []+                          ))) }+        | 'signature' modid maybe_warning_pragma maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   acs loc (\loc cs -> (L loc (HsModule (XModulePs+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) [] [] Nothing) cs)+                                                   EpNoLayout $3 Nothing)+                                                (Just $2) $4 $6 []+                          ))) }+        | header_body2+                {% fileSrcSpan >>= \ loc ->+                   return (L loc (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing $1 [])) }++header_body :: { [LImportDecl GhcPs] }+        :  '{'            header_top            { $2 }+        |      vocurly    header_top            { $2 }++header_body2 :: { [LImportDecl GhcPs] }+        :  '{' header_top                       { $2 }+        |  missing_module_keyword header_top    { $2 }++header_top :: { [LImportDecl GhcPs] }+        :  semis header_top_importdecls         { $2 }++header_top_importdecls :: { [LImportDecl GhcPs] }+        :  importdecls_semi                     { $1 }+        |  importdecls                          { $1 }++-----------------------------------------------------------------------------+-- The Export List++maybeexports :: { (Maybe (LocatedLI [LIE GhcPs])) }+        :  '(' exportlist ')'       {% fmap Just $ amsr (sLL $1 $> (fromOL $ snd $2))+                                        (AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] (noAnn,fst $2) []) }+        |  {- empty -}              { Nothing }++exportlist :: { ([EpToken ","], OrdList (LIE GhcPs)) }+        : exportlist1     { ([], $1) }+        | {- empty -}     { ([], nilOL) }++        -- trailing comma:+        | exportlist1 ',' {% case $1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (epTok $2)+                                 return ([], snocOL hs t')}+        | ','             { ([epTok $1], nilOL) }++exportlist1 :: { OrdList (LIE GhcPs) }+        : exportlist1 ',' export_cs+                          {% let ls = $1+                             in if isNilOL ls+                                  then return (ls `appOL` $3)+                                  else case ls of+                                         SnocOL hs t -> do+                                           t' <- addTrailingCommaA t (epTok $2)+                                           return (snocOL hs t' `appOL` $3)}+        | export_cs       { $1 }+++export_cs :: { OrdList (LIE GhcPs) }+export_cs : export {% return (unitOL $1) }++   -- No longer allow things like [] and (,,,) to be exported+   -- They are built in syntax, always available+export  :: { LIE GhcPs }+        : maybe_warning_pragma qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }+                                                          ; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)+                                                          ; return $ reLoc $ sL span $ impExp } }+        | maybe_warning_pragma 'module' modid            {% do { let { span = (maybe comb2 comb3 $1) $2 $>+                                                                     ; 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            {% 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 } }+++export_subspec :: { Located ((EpToken "(", EpToken ")"), ImpExpSubSpec) }+        : {- empty -}             { sL0 (noAnn,ImpExpAbs) }+        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse $2)+                                      >>= \ie -> return $ sLL $1 $>+                                            ((epTok $1, epTok $3), ie) }++qcnames :: { [LocatedA ImpExpQcSpec] }+  : {- empty -}                   { [] }+  | qcnames1                      { $1 }++qcnames1 :: { [LocatedA ImpExpQcSpec] }     -- A reversed list+        :  qcnames1 ',' qcname_ext_w_wildcard  {% case $1 of+                                                    ((L la (ImpExpQcWildcard tok _)):t) ->+                                                       do { return ($3 : L la (ImpExpQcWildcard tok (epTok $2)) : t) }+                                                    (l:t) ->+                                                       do { l' <- addTrailingCommaA l (epTok $2)+                                                          ; return ($3 : l' : t)} }++        -- Annotations re-added in mkImpExpSubSpec+        |  qcname_ext_w_wildcard                   { [$1] }++-- Variable, data constructor or wildcard+-- or tagged type constructor+qcname_ext_w_wildcard :: { LocatedA ImpExpQcSpec }+        :  qcname_ext               { $1 }+        |  '..'                     { sL1a $1 (ImpExpQcWildcard (epTok $1) NoEpTok)  }++qcname_ext :: { LocatedA ImpExpQcSpec }+        :  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+                                       -- Note: This includes record selectors but+                                       -- also (-.->), see #11432+        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]++-----------------------------------------------------------------------------+-- Import Declarations++-- importdecls and topdecls must contain at least one declaration;+-- top handles the fact that these may be optional.++-- One or more semicolons+semis1  :: { Located [TrailingAnn] }+semis1  : semis1 ';'  { if isZeroWidthSpan (gl $2) then (sL1 $1 $ unLoc $1) else (sLL $1 $> $ AddSemiAnn (epTok $2) : (unLoc $1)) }+        | ';'         { case msemi $1 of+                          [] -> noLoc []+                          ms -> sL1 $1 $ ms }++-- Zero or more semicolons+semis   :: { [TrailingAnn] }+semis   : semis ';'   { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (epTok $2) : $1) }+        | {- empty -} { [] }++-- No trailing semicolons, non-empty+importdecls :: { [LImportDecl GhcPs] }+importdecls+        : importdecls_semi importdecl+                                { $2 : $1 }++-- May have trailing semicolons, can be empty+importdecls_semi :: { [LImportDecl GhcPs] }+importdecls_semi+        : importdecls_semi importdecl semis1+                                {% do { i <- amsAl $2 (comb2 $2 $3) (reverse $ unLoc $3)+                                      ; return (i : $1)} }+        | {- empty -}           { [] }++importdecl :: { LImportDecl GhcPs }+        : 'import' maybe_src maybe_splice maybe_safe optqualified maybe_pkg modid maybe_splice optqualified maybeas maybeimpspec+                {% do {+                  ; 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+                             , importDeclAnnLevel     = fst $ levelSpec+                             , importDeclAnnSafe      = fst $4+                             , importDeclAnnQualified = fst $ qualSpec+                             , importDeclAnnPackage   = fst $6+                             , importDeclAnnAs        = fst $10+                             }+                  ; 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 = $7, ideclPkgQual = snd $6+                                  , ideclSource = snd $2+                                  , ideclLevelSpec = snd $ levelSpec+                                  , ideclSafe = snd $4+                                  , ideclQualified = snd $ qualSpec+                                  , ideclAs = unLoc (snd $10)+                                  , ideclImportList = unLoc $11 })+                  }+                }+++maybe_src :: { ((Maybe (EpaLocation,EpToken "#-}"),SourceText),IsBootInterface) }+        : '{-# SOURCE' '#-}'        { ((Just (glR $1,epTok $2),getSOURCE_PRAGs $1)+                                      , IsBoot) }+        | {- empty -}               { ((Nothing,NoSourceText),NotBoot) }++maybe_safe :: { (Maybe (EpToken "safe"),Bool) }+        : '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)) $+                             addError $ mkPlainErrorMsgEnvelope (getLoc $1) $+                               (PsErrInvalidPackageName pkgFS)+                        ; return (Just (glR $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }+        | {- empty -}                           { (Nothing,NoRawPkgQual) }++optqualified :: { Maybe (EpToken "qualified") }+        : 'qualified'                           { Just (epTok $1) }+        | {- empty -}                           { Nothing }++maybeas :: { (Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName))) }+        : 'as' modid                           { (Just (epTok $1)+                                                 ,sLL $1 $> (Just $2)) }+        | {- empty -}                          { (Nothing,noLoc Nothing) }++maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs])) }+        : impspec                  {% let (b, ie) = unLoc $1 in+                                       checkImportSpec ie+                                        >>= \checkedIe ->+                                          return (L (gl $1) (Just (b, checkedIe)))  }+        | {- empty -}              { noLoc Nothing }++impspec :: { Located (ImportListInterpretation, LocatedLI [LIE GhcPs]) }+        :  '(' importlist ')'               {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $2)+                                                               (AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] (noAnn,fst $2) [])+                                                  ; return $ sLL $1 $> (Exactly, es)} }+        |  'hiding' '(' importlist ')'      {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $3)+                                                               (AnnList Nothing (ListParens (epTok $2) (epTok $4)) [] (epTok $1,fst $3) [])+                                                  ; return $ sLL $1 $> (EverythingBut, es)} }++importlist :: { ([EpToken ","], OrdList (LIE GhcPs)) }+        : importlist1     { ([], $1) }+        | {- empty -}     { ([], nilOL) }++        -- trailing comma:+        | importlist1 ',' {% case $1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (epTok $2)+                                 return ([], snocOL hs t')}+        | ','             { ([epTok $1], nilOL) }++importlist1 :: { OrdList (LIE GhcPs) }+        : importlist1 ',' import+                          {% let ls = $1+                             in if isNilOL ls+                                  then return (ls `appOL` $3)+                                  else case ls of+                                         SnocOL hs t -> do+                                           t' <- addTrailingCommaA t (epTok $2)+                                           return (snocOL hs t' `appOL` $3)}+        | import          { $1 }++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            {% do { warnPatternNamespaceSpecifier (getLoc $1)+                                          ; return $ unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (epTok $1) $2)) Nothing } }++-----------------------------------------------------------------------------+-- Fixity Declarations++prec    :: { Maybe (Located (SourceText,Int)) }+        : {- empty -}           { Nothing }+        | INTEGER+                 { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }++infix   :: { Located FixityDirection }+        : 'infix'                               { sL1 $1 InfixN  }+        | 'infixl'                              { sL1 $1 InfixL  }+        | 'infixr'                              { sL1 $1 InfixR }++ops     :: { Located (OrdList (LocatedN RdrName)) }+        : ops ',' op       {% case (unLoc $1) of+                                SnocOL hs t -> do+                                  t' <- addTrailingCommaN t (gl $2)+                                  return (sLL $1 $> (snocOL hs t' `appOL` unitOL $3)) }+        | op               { sL1 $1 (unitOL $1) }++-----------------------------------------------------------------------------+-- Top-Level Declarations++-- No trailing semicolons, non-empty+topdecls :: { OrdList (LHsDecl GhcPs) }+        : topdecls_semi topdecl        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_semi :: { OrdList (LHsDecl GhcPs) }+        : topdecls_semi topdecl semis1 {% do { t <- amsAl $2 (comb2 $2 $3) (reverse $ unLoc $3)+                                             ; return ($1 `snocOL` t) }}+        | {- empty -}                  { nilOL }+++-----------------------------------------------------------------------------+-- Each topdecl accumulates prior comments+-- No trailing semicolons, non-empty+topdecls_cs :: { OrdList (LHsDecl GhcPs) }+        : topdecls_cs_semi topdecl_cs        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }+        : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsAl $2 (comb2 $2 $3) (reverse $ unLoc $3)+                                                   ; return ($1 `snocOL` t) }}+        | {- empty -}                  { nilOL }++-- Each topdecl accumulates prior comments+topdecl_cs :: { LHsDecl GhcPs }+topdecl_cs : topdecl {% commentsPA $1 }++-----------------------------------------------------------------------------+topdecl :: { LHsDecl GhcPs }+        : cl_decl                               { L (getLoc $1) (TyClD noExtField (unLoc $1)) }+        | ty_decl                               { L (getLoc $1) (TyClD noExtField (unLoc $1)) }+        | standalone_kind_sig                   { L (getLoc $1) (KindSigD noExtField (unLoc $1)) }+        | inst_decl                             { L (getLoc $1) (InstD noExtField (unLoc $1)) }+        | stand_alone_deriving                  { L (getLoc $1) (DerivD noExtField (unLoc $1)) }+        | role_annot                            { L (getLoc $1) (RoleAnnotD noExtField (unLoc $1)) }+        | default_decl                          { L (getLoc $1) (DefD noExtField (unLoc $1)) }+        | 'foreign' fdecl                       {% amsA' (sLL $1 $> ((unLoc $2) (epTok $1))) }+        | '{-# DEPRECATED' deprecations '#-}'   {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ((glR $1,epTok $3), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }+        | '{-# WARNING' warnings '#-}'          {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ((glR $1,epTok $3), (getWARNING_PRAGs $1)) (fromOL $2))) }+        | '{-# RULES' rules '#-}'               {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ((glR $1,epTok $3), (getRULES_PRAGs $1)) (reverse $2))) }+        | annotation { $1 }+        | decl_no_th                            { $1 }++        -- Template Haskell Extension+        -- The $(..) form is one possible form of infixexp+        -- but we treat an arbitrary expression just as if+        -- it had a $(..) wrapped around it+        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->+                                                       commentsPA $ mkSpliceDecl $1 }++-- Type classes+--+cl_decl :: { LTyClDecl GhcPs }+        : 'class' tycl_hdr fds where_cls+                {% do { let {(wtok, (oc,semis,cc)) = fstOf3 $ unLoc $4}+                      ; mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4)+                        (AnnClassDecl (epTok $1) [] [] (fst $ unLoc $3) wtok oc cc semis) }}++-- Default declarations (toplevel)+--+default_decl :: { LDefaultDecl GhcPs }+             : 'default' opt_class '(' comma_types0 ')'+               {% amsA' (sLL $1 $> (DefaultDecl (epTok $1,epTok $3,epTok $5) $2 $4)) }+++-- Type declarations (toplevel)+--+ty_decl :: { LTyClDecl GhcPs }+           -- ordinary type synonyms+        : 'type' type '=' ktype+                -- Note ktype, not sigtype, on the right of '='+                -- We allow an explicit for-all but we don't insert one+                -- in   type Foo a = (b,b)+                -- Instead we just say b is out of scope+                --+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% mkTySynonym (comb2 $1 $4) $2 $4 (epTok $1) (epTok $3) }++           -- type family declarations+        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info+                          where_type_family+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+             {% do { let { (tdcolon, tequal) = fst $ unLoc $4 }+                   ; let { tvbar = fst $ unLoc $5 }+                   ; let { (twhere, (toc, tdd, tcc)) = fst $ unLoc $6  }+                   ; mkFamDecl (comb5 $1 $3 $4 $5 $6) (snd $ unLoc $6) TopLevel $3+                                   (snd $ unLoc $4) (snd $ unLoc $5)+                           (AnnFamilyDecl [] [] (epTok $1) noAnn (epTok $2) tdcolon tequal tvbar twhere toc tdd tcc) }}++          -- ordinary data type or newtype declaration+        | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings+            {% do { let { (tdata, tnewtype, ttype) = fstOf3 $ unLoc $1}+                  ; let { tequal = fst $ unLoc $4 }+                  ; mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3+                           Nothing (reverse (snd $ unLoc $4))+                                   (fmap reverse $5)+                           (AnnDataDefn [] [] ttype tnewtype tdata NoEpTok NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)+                             }}+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty++          -- ordinary GADT declaration+        | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% do { let { (tdata, tnewtype, ttype) = fstOf3 $ unLoc $1}+                  ; let { tdcolon = fst $ unLoc $4 }+                  ; let { (twhere, oc, cc) = fst $ unLoc $5 }+                  ; mkTyData (comb5 $1 $3 $4 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3+                            (snd $ unLoc $4) (snd $ unLoc $5)+                            (fmap reverse $6)+                            (AnnDataDefn [] [] ttype tnewtype tdata NoEpTok tdcolon twhere oc cc NoEpTok)}}+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty++          -- data/newtype family+        | 'data' 'family' type opt_datafam_kind_sig+             {% do { let { tdcolon = fst $ unLoc $4 }+                   ; mkFamDecl (comb4 $1 $2 $3 $4) DataFamily TopLevel $3+                                   (snd $ unLoc $4) Nothing+                           (AnnFamilyDecl [] [] noAnn (epTok $1) (epTok $2) tdcolon noAnn noAnn noAnn noAnn noAnn noAnn) }}++-- standalone kind signature+standalone_kind_sig :: { LStandaloneKindSig GhcPs }+  : 'type' sks_vars '::' sigktype+      {% mkStandaloneKindSig (comb2 $1 $4) (L (gl $2) $ unLoc $2) $4+               (epTok $1,epUniTok $3)}++-- See also: sig_vars+sks_vars :: { Located [LocatedN RdrName] }  -- Returned in reverse order+  : sks_vars ',' oqtycon+      {% case unLoc $1 of+           (h:t) -> do+             h' <- addTrailingCommaN h (gl $2)+             return (sLL $1 $> ($3 : h' : t)) }+  | oqtycon { sL1 $1 [$1] }++inst_decl :: { LInstDecl GhcPs }+        : 'instance' maybe_warning_pragma overlap_pragma inst_type where_inst+       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $5)+             ; let (twhere, (openc, closec, semis)) = fst $ unLoc $5+             ; let anns = AnnClsInstDecl (epTok $1) twhere openc semis closec+             ; let cid = ClsInstDecl+                                  { cid_ext = ($2, anns, NoAnnSortKey)+                                  , cid_poly_ty = $4, cid_binds = binds+                                  , cid_sigs = mkClassOpSigs sigs+                                  , cid_tyfam_insts = ats+                                  , cid_overlap_mode = $3+                                  , cid_datafam_insts = adts }+             ; amsA' (L (comb3 $1 $4 $5)+                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))+                   } }++           -- type instance declarations+        | 'type' 'instance' ty_fam_inst_eqn+                {% mkTyFamInst (comb2 $1 $3) (unLoc $3)+                        (epTok $1) (epTok $2) }++          -- data/newtype instance declaration+        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs+                          maybe_derivings+            {% do { let { (tdata, tnewtype) = fst $ unLoc $1 }+                  ; let { tequal = fst $ unLoc $5 }+                  ; mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)+                                      Nothing (reverse (snd  $ unLoc $5))+                                              (fmap reverse $6)+                            (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)}}++          -- GADT instance declaration+        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% do { let { (tdata, tnewtype) = fst $ unLoc $1 }+                  ; let { dcolon = fst $ unLoc $5 }+                  ; let { (twhere, oc, cc) = fst $ unLoc $6 }+                  ; mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)+                                   (snd $ unLoc $5) (snd $ unLoc $6)+                                   (fmap reverse $7)+                            (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) dcolon twhere oc cc NoEpTok)}}++overlap_pragma :: { Maybe (LocatedP OverlapMode) }+  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))+                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }+  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))+                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }+  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))+                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }+  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))+                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }+  | {- empty -}                 { Nothing }++deriv_strategy_no_via :: { LDerivStrategy GhcPs }+  : 'stock'                     {% amsA' (sL1 $1 (StockStrategy (epTok $1))) }+  | 'anyclass'                  {% amsA' (sL1 $1 (AnyclassStrategy (epTok $1))) }+  | 'newtype'                   {% amsA' (sL1 $1 (NewtypeStrategy (epTok $1))) }++deriv_strategy_via :: { LDerivStrategy GhcPs }+  : 'via' sigktype          {% amsA' (sLL $1 $> (ViaStrategy (XViaStrategyPs (epTok $1) $2))) }++deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }+  : 'stock'                     {% fmap Just $ amsA' (sL1 $1 (StockStrategy (epTok $1))) }+  | 'anyclass'                  {% fmap Just $ amsA' (sL1 $1 (AnyclassStrategy (epTok $1))) }+  | 'newtype'                   {% fmap Just $ amsA' (sL1 $1 (NewtypeStrategy (epTok $1))) }+  | deriv_strategy_via          { Just $1 }+  | {- empty -}                 { Nothing }++-- Optional class reference for default declarations+opt_class :: { Maybe (LIdP GhcPs) }+          : {- empty -}         { Nothing }+          | qtycon              {% fmap Just $ amsA' (reLoc $1) }++-- Injective type families++opt_injective_info :: { Located (EpToken "|", Maybe (LInjectivityAnn GhcPs)) }+        : {- empty -}               { noLoc (noAnn, Nothing) }+        | '|' injectivity_cond      { sLL $1 $> ((epTok $1)+                                                , Just ($2)) }++injectivity_cond :: { LInjectivityAnn GhcPs }+        : tyvarid '->' inj_varids+           {% amsA' (sLL $1 $> (InjectivityAnn (epUniTok $2) $1 (reverse (unLoc $3)))) }++inj_varids :: { Located [LocatedN RdrName] }+        : inj_varids tyvarid  { sLL $1 $> ($2 : unLoc $1) }+        | tyvarid             { sL1  $1 [$1]               }++-- Closed type families++where_type_family :: { Located ((EpToken "where", (EpToken "{", EpToken "..", EpToken "}")),FamilyInfo GhcPs) }+        : {- empty -}                      { noLoc (noAnn,OpenTypeFamily) }+        | 'where' ty_fam_inst_eqn_list+               { sLL $1 $> ((epTok $1,(fst $ unLoc $2))+                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }++ty_fam_inst_eqn_list :: { Located ((EpToken "{", EpToken "..", EpToken "}"),Maybe [LTyFamInstEqn GhcPs]) }+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ((epTok $1,noAnn, epTok $3)+                                                ,Just (unLoc $2)) }+        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in+                                             L loc (noAnn,Just (unLoc $2)) }+        |     '{' '..' '}'                 { sLL $1 $> ((epTok $1,epTok $2 ,epTok $3),Nothing) }+        | vocurly '..' close               { let (L loc _) = $2 in+                                             L loc ((noAnn,epTok $2, noAnn),Nothing) }++ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }+        : ty_fam_inst_eqns ';' ty_fam_inst_eqn+                                      {% let (L loc eqn) = $3 in+                                         case unLoc $1 of+                                           [] -> return (sLL $1 $> (L loc eqn : unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (epTok $2)+                                             return (sLL $1 $> ($3 : h' : t)) }+        | ty_fam_inst_eqns ';'        {% case unLoc $1 of+                                           [] -> return (sLZ $1 $> (unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (epTok $2)+                                             return (sLZ $1 $>  (h':t)) }+        | ty_fam_inst_eqn             { sLL $1 $> [$1] }+        | {- empty -}                 { noLoc [] }++ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }+        : 'forall' tv_bndrs '.' type '=' ktype+              {% do { hintExplicitForall $1+                    ; tvbs <- fromSpecTyVarBndrs $2+                    ; let loc = comb2 $1 $>+                    ; !cs <- getCommentsFor loc+                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE $1 $3) (epUniTok $1, epTok $3) cs) tvbs) $4 $6 (epTok $5) }}+        | type '=' ktype+              {% mkTyFamInstEqn (comb2 $1 $>) mkHsOuterImplicit $1 $3 (epTok $2) }+              -- Note the use of type for the head; this allows+              -- infix type constructors and type patterns++-- Associated type family declarations+--+-- * They have a different syntax than on the toplevel (no family special+--   identifier).+--+-- * They also need to be separate from instances; otherwise, data family+--   declarations without a kind signature cause parsing conflicts with empty+--   data declarations.+--+at_decl_cls :: { LHsDecl GhcPs }+        :  -- data family declarations, with optional 'family' keyword+          'data' opt_family type opt_datafam_kind_sig+             {% do { let { tdcolon = fst $ unLoc $4 }+                   ; liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily NotTopLevel $3+                                                  (snd $ unLoc $4) Nothing+                           (AnnFamilyDecl [] [] noAnn (epTok $1) $2 tdcolon noAnn noAnn noAnn noAnn noAnn noAnn)) }}++           -- type family declarations, with optional 'family' keyword+           -- (can't use opt_instance because you get shift/reduce errors+        | 'type' type opt_at_kind_inj_sig+            {% do { let { (tdcolon, tequal, tvbar) = fst $ unLoc $3 }+                  ; liftM mkTyClD+                        (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily NotTopLevel $2+                                   (fst . snd $ unLoc $3)+                                   (snd . snd $ unLoc $3)+                         (AnnFamilyDecl [] [] (epTok $1) noAnn noAnn tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) }}+        | 'type' 'family' type opt_at_kind_inj_sig+            {% do { let { (tdcolon, tequal, tvbar) = fst $ unLoc $4 }+                  ; liftM mkTyClD+                        (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily NotTopLevel $3+                                   (fst . snd $ unLoc $4)+                                   (snd . snd $ unLoc $4)+                           (AnnFamilyDecl [] [] (epTok $1) noAnn (epTok $2) tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) }}+           -- default type instances, with optional 'instance' keyword+        | 'type' ty_fam_inst_eqn+                {% liftM mkInstD (mkTyFamInst (comb2 $1 $2) (unLoc $2)+                          (epTok $1) NoEpTok) }+        | 'type' 'instance' ty_fam_inst_eqn+                {% liftM mkInstD (mkTyFamInst (comb2 $1 $3) (unLoc $3)+                              (epTok $1) (epTok $2) )}++opt_family   :: { EpToken "family" }+              : {- empty -}   { noAnn }+              | 'family'      { (epTok $1) }++opt_instance :: { EpToken "instance" }+              : {- empty -} { NoEpTok }+              | 'instance'  { epTok $1 }++-- Associated type instances+--+at_decl_inst :: { LInstDecl GhcPs }+           -- type instance declarations, with optional 'instance' keyword+        : 'type' opt_instance ty_fam_inst_eqn+                -- Note the use of type for the head; this allows+                -- infix type constructors and type patterns+                {% mkTyFamInst (comb2 $1 $3) (unLoc $3)+                          (epTok $1) $2 }++        -- data/newtype instance declaration, with optional 'instance' keyword+        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings+            {% do { let { (tdata, tnewtype) = fst $ unLoc $1 }+                  ; let { tequal = fst $ unLoc $5 }+                  ; mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)+                                    Nothing (reverse (snd $ unLoc $5))+                                             (fmap reverse $6)+                            (AnnDataDefn [] [] NoEpTok tnewtype tdata $2 NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)}}++        -- GADT instance declaration, with optional 'instance' keyword+        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+             {% do { let { (tdata, tnewtype) = fst $ unLoc $1 }+                   ; let { dcolon = fst $ unLoc $5 }+                   ; let { (twhere, oc, cc) = fst $ unLoc $6 }+                   ; mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3+                                (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)+                                (fmap reverse $7)+                            (AnnDataDefn [] [] NoEpTok tnewtype tdata $2 dcolon twhere oc cc NoEpTok)}}++type_data_or_newtype :: { Located ((EpToken "data", EpToken "newtype", EpToken "type")+                                   , Bool, NewOrData) }+        : 'data'        { sL1 $1 ((epTok $1, NoEpTok,  NoEpTok),  False,DataType) }+        | 'newtype'     { sL1 $1 ((NoEpTok,  epTok $1, NoEpTok),  False,NewType) }+        | 'type' 'data' { sL1 $1 ((epTok $2, NoEpTok,  epTok $1), True ,DataType) }++data_or_newtype :: { Located ((EpToken "data", EpToken "newtype"), NewOrData) }+        : 'data'        { sL1 $1 ((epTok $1, NoEpTok), DataType) }+        | 'newtype'     { sL1 $1 ((NoEpTok,  epTok $1),NewType) }++-- Family result/return kind signatures++opt_kind_sig :: { Located (TokDcolon, Maybe (LHsKind GhcPs)) }+        :               { noLoc     (NoEpUniTok , Nothing) }+        | '::' kind     { sLL $1 $> (epUniTok $1, Just $2) }++opt_datafam_kind_sig :: { Located (TokDcolon, LFamilyResultSig GhcPs) }+        :               { noLoc     (noAnn,       noLocA (NoSig noExtField)         )}+        | '::' kind     { sLL $1 $> (epUniTok $1, sLLa $1 $> (KindSig noExtField $2))}++opt_tyfam_kind_sig :: { Located ((TokDcolon, EpToken "="), LFamilyResultSig GhcPs) }+        :              { noLoc     (noAnn               , noLocA     (NoSig    noExtField)   )}+        | '::' kind    { sLL $1 $> ((epUniTok $1, noAnn), sLLa $1 $> (KindSig  noExtField $2))}+        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2+                             ; return $ sLL $1 $> ((noAnn, epTok $1), sLLa $1 $> (TyVarSig noExtField tvb))} }++opt_at_kind_inj_sig :: { Located ((TokDcolon, EpToken "=", EpToken "|"), ( LFamilyResultSig GhcPs+                                            , Maybe (LInjectivityAnn GhcPs)))}+        :            { noLoc (noAnn, (noLocA (NoSig noExtField), Nothing)) }+        | '::' kind  { sLL $1 $> ( (epUniTok $1, noAnn, noAnn)+                                 , (sL1a $> (KindSig noExtField $2), Nothing)) }+        | '='  tv_bndr_no_braces '|' injectivity_cond+                {% do { tvb <- fromSpecTyVarBndr $2+                      ; return $ sLL $1 $> ((noAnn, epTok $1, epTok $3)+                                           , (sLLa $1 $2 (TyVarSig noExtField tvb), Just $4))} }++-- tycl_hdr parses the header of a class or data type decl,+-- which takes the form+--      T a b+--      Eq a => T a+--      (Eq a, Ord b) => T a b+--      T Int [a]                       -- for associated types+-- Rather a lot of inlining here, else we get reduce/reduce errors+tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }+        : context '=>' type         {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), $3))) }+        | type                      { sL1 $1 (Nothing, $1) }++datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }+        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1+                                                       >> fromSpecTyVarBndrs $2+                                                         >>= \tvbs ->+                                                             (acs (comb2 $1 $>) (\loc cs -> (L loc+                                                                                  (Just ( addTrailingDarrowC $4 $5 cs)+                                                                                        , mkHsOuterExplicit (EpAnn (glEE $1 $3) (epUniTok $1, epTok $3) emptyComments) tvbs, $6))))+                                                    }+        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1+                                             ; tvbs <- fromSpecTyVarBndrs $2+                                             ; let loc = comb2 $1 $>+                                             ; !cs <- getCommentsFor loc+                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE $1 $3) (epUniTok $1, epTok $3) cs) tvbs, $4))+                                       } }+        | context '=>' type         {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }+        | type                      { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }+++capi_ctype :: { Maybe (LocatedP CType) }+capi_ctype : '{-# CTYPE' STRING STRING '#-}'+                       {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))+                                        (getSTRINGs $3,getSTRING $3)))+                              (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) }++           | '{-# CTYPE'        STRING '#-}'+                       {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))+                              (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) }++           |           { Nothing }++-----------------------------------------------------------------------------+-- Stand-alone deriving++-- Glasgow extension: stand-alone deriving declarations+stand_alone_deriving :: { LDerivDecl GhcPs }+  : 'deriving' deriv_standalone_strategy 'instance' maybe_warning_pragma overlap_pragma inst_type+                {% do { let { err = text "in the stand-alone deriving instance"+                                    <> colon <+> quotes (ppr $6) }+                      ; amsA' (sLL $1 $>+                                 (DerivDecl ($4, (epTok $1, epTok $3)) (mkHsWildCardBndrs $6) $2 $5)) }}++-----------------------------------------------------------------------------+-- Role annotations++role_annot :: { LRoleAnnotDecl GhcPs }+role_annot : 'type' 'role' oqtycon maybe_roles+          {% mkRoleAnnotDecl (comb3 $1 $4 $3) $3 (reverse (unLoc $4))+                   (epTok $1,epTok $2) }++-- Reversed!+maybe_roles :: { Located [Located (Maybe FastString)] }+maybe_roles : {- empty -}    { noLoc [] }+            | roles          { $1 }++roles :: { Located [Located (Maybe FastString)] }+roles : role             { sLL $1 $> [$1] }+      | roles role       { sLL $1 $> $ $2 : unLoc $1 }++-- read it in as a varid for better error messages+role :: { Located (Maybe FastString) }+role : VARID             { sL1 $1 $ Just $ getVARID $1 }+     | '_'               { sL1 $1 Nothing }++-- Pattern synonyms++-- Glasgow extension: pattern synonyms+pattern_synonym_decl :: { LHsDecl GhcPs }+        : 'pattern' pattern_synonym_lhs '=' pat_syn_pat+         {%      let (name, args, (mo, mc) ) = $2 in+                 amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4+                                                    ImplicitBidirectional+                      (AnnPSB (epTok $1) mo mc Nothing (Just (epTok $3)))) }++        | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat+         {%    let (name, args, (mo,mc)) = $2 in+               amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional+                       (AnnPSB (epTok $1) mo mc (Just (epUniTok $3)) Nothing)) }++        | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat where_decls+            {% do { let (name, args, (mo,mc)) = $2+                  ; mg <- mkPatSynMatchGroup name $5+                  ; amsA' (sLL $1 $> . ValD noExtField $+                           mkPatSynBind name args $4 (ExplicitBidirectional mg)+                            (AnnPSB (epTok $1) mo mc (Just (epUniTok $3)) Nothing))+                   }}++pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, (Maybe (EpToken "{"), Maybe (EpToken "}"))) }+        : 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))) }++vars0 :: { [LocatedN RdrName] }+        : {- empty -}                 { [] }+        | varid vars0                 { $1 : $2 }++cvars1 :: { [RecordPatSynField GhcPs] }+       : var                          { [RecordPatSynField (mkFieldOcc $1) $1] }+       | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)+                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}++where_decls :: { LocatedLW (OrdList (LHsDecl GhcPs)) }+        : 'where' '{' decls '}'       {% amsr (sLL $1 $> (thdOf3 $ unLoc $3))+                                              (AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) (epTok $1) []) }+        | 'where' vocurly decls close {% amsr (sLL $1 $3 (thdOf3 $ unLoc $3))+                                              (AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) (epTok $1) []) }++pattern_synonym_sig :: { LSig GhcPs }+        : 'pattern' con_list '::' sigtype+                   {% amsA' (sLL $1 $>+                                $ PatSynSig (AnnSig (epUniTok $3) (Just (epTok $1)) Nothing)+                                  (toList $ unLoc $2) $4) }++qvarcon :: { LocatedN RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }++-----------------------------------------------------------------------------+-- Nested declarations++-- Declaration in class bodies+--+decl_cls  :: { LHsDecl GhcPs }+decl_cls  : at_decl_cls                 { $1 }+          | decl                        { $1 }++          -- A 'default' signature used with the generic-programming extension+          | 'default' infixexp '::' sigtype+                    {% runPV (unECP $2) >>= \ $2 ->+                       do { v <- checkValSigLhs $2+                          ; let err = text "in default signature" <> colon <+>+                                      quotes (ppr $2)+                          ; amsA' (sLL $1 $> $ SigD noExtField $ ClassOpSig (AnnSig (epUniTok $3) Nothing (Just (epTok $1))) True [v] $4) }}++decls_cls :: { Located ([EpToken ";"],OrdList (LHsDecl GhcPs)) }  -- Reversed+          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]+                                                                    , unitOL $3))+                                            else case (snd $ unLoc $1) of+                                              SnocOL hs t -> do+                                                 t' <- addTrailingSemiA t (epTok $2)+                                                 return (sLL $1 $> (fst $ unLoc $1+                                                                , snocOL hs t' `appOL` unitOL $3)) }+          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)+                                             then return (sLZ $1 $> ( (fst $ unLoc $1) ++ [mzEpTok $2]+                                                                                   ,snd $ unLoc $1))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (epTok $2)+                                                  return (sLZ $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t')) }+          | decl_cls                    { sL1 $1 ([], unitOL $1) }+          | {- empty -}                 { noLoc ([],nilOL) }++decllist_cls+        :: { Located ((EpToken "{", [EpToken ";"], EpToken "}")+                     , OrdList (LHsDecl GhcPs)+                     , EpLayout) }      -- Reversed+        : '{'         decls_cls '}'     { sLL $1 $> ((epTok $1, fst $ unLoc $2, epTok $3)+                                             ,snd $ unLoc $2, epExplicitBraces $1 $3) }+        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }+                                           in L l ((NoEpTok, anns, NoEpTok), decls, EpVirtualBraces (getVOCURLY $1)) }++-- Class body+--+where_cls :: { Located ((EpToken "where", (EpToken "{", [EpToken ";"], EpToken "}"))+                       ,(OrdList (LHsDecl GhcPs))    -- Reversed+                       ,EpLayout) }+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_cls          { sLL $1 $> ((epTok $1,fstOf3 $ unLoc $2)+                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }+        | {- empty -}                   { noLoc ((noAnn, noAnn),nilOL,EpNoLayout) }++-- Declarations in instance bodies+--+decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }+decl_inst  : at_decl_inst               { sL1 $1 (unitOL (sL1a $1 (InstD noExtField (unLoc $1)))) }+           | decl                       { sL1 $1 (unitOL $1) }++decls_inst :: { Located ([EpToken ";"],OrdList (LHsDecl GhcPs)) }   -- Reversed+           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]+                                                                    , unLoc $3))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (epTok $2)+                                                  return (sLL $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t' `appOL` unLoc $3)) }+           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)+                                             then return (sLZ $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]+                                                                                   ,snd $ unLoc $1))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (epTok $2)+                                                  return (sLZ $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t')) }+           | decl_inst                  { sL1 $1 ([],unLoc $1) }+           | {- empty -}                { noLoc ([],nilOL) }++decllist_inst+        :: { Located ((EpToken "{", EpToken "}", [EpToken ";"])+                     , OrdList (LHsDecl GhcPs)) }      -- Reversed+        : '{'         decls_inst '}'    { sLL $1 $> ((epTok $1,epTok $3,fst $ unLoc $2),snd $ unLoc $2) }+        |     vocurly decls_inst close  { L (gl $2) ((noAnn,noAnn,fst $ unLoc $2),snd $ unLoc $2) }++-- Instance body+--+where_inst :: { Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken ";"]))+                        , OrdList (LHsDecl GhcPs)) }   -- Reversed+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_inst         { sLL $1 $> ((epTok $1,(fst $ unLoc $2))+                                             ,snd $ unLoc $2) }+        | {- empty -}                   { noLoc (noAnn,nilOL) }++-- Declarations in binding groups other than classes and instances+--+decls   :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) }+        : decls ';' decl    {% if isNilOL (thdOf3 $ unLoc $1)+                                 then return (sLL $2 $> (glR $3, (sndOf3 $ unLoc $1) ++ (msemiA $2)+                                                        , unitOL $3))+                                 else case (thdOf3 $ unLoc $1) of+                                   SnocOL hs t -> do+                                      t' <- addTrailingSemiA t (epTok $2)+                                      let { this = unitOL $3;+                                            rest = snocOL hs t';+                                            these = rest `appOL` this }+                                      return (rest `seq` this `seq` these `seq`+                                                 (sLL $1 $> (glEE (fstOf3 $ unLoc $1) $3, sndOf3 $ unLoc $1, these))) }+        | decls ';'          {% if isNilOL (thdOf3 $ unLoc $1)+                                  then return (sLZ $1 $> (glR $2, (sndOf3 $ unLoc $1) ++ (msemiA $2)+                                                          ,thdOf3 $ unLoc $1))+                                  else case (thdOf3 $ unLoc $1) of+                                    SnocOL hs t -> do+                                       t' <- addTrailingSemiA t (epTok $2)+                                       return (sLZ $1 $> (glEEz $1 $2, sndOf3 $ unLoc $1, snocOL hs t')) }+        | decl                          { sL1 $1 (glR $1,  [], unitOL $1) }+        | {- empty -}                   { noLoc (noAnn, [],nilOL) }++decllist :: { Located (AnnList (),Located (OrdList (LHsDecl GhcPs))) }+        : '{'            decls '}'     { sLL $1 $> (AnnList (Just (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) noAnn []+                                                   ,sL1 $2 $ thdOf3 $ unLoc $2) }+        |     vocurly    decls close   { sL1 $2    (AnnList (Just (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) noAnn []+                                                   ,sL1 $2 $ thdOf3 $ unLoc $2) }++-- Binding groups other than those of class and instance declarations+--+binds   ::  { Located (HsLocalBinds GhcPs) }+                                         -- May have implicit parameters+                                                -- No type declarations+        : decllist          {% do { let { (AnnList anc p s _ t, decls) = unLoc $1 }+                                  ; val_binds <- cvBindGroup (unLoc $ decls)+                                  ; !cs <- getCommentsFor (gl $1)+                                  ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList anc p s noAnn t) cs) val_binds)} }++        | '{'            dbinds '}'     {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc+                                             $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }++        |     vocurly    dbinds close   {% acs (gl $2) (\loc cs -> (L loc+                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) ListNone [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }+++wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }+                                                -- May have implicit parameters+                                                -- No type declarations+        : 'where' binds                 {% do { r <- acs (comb2 $1 $>) (\loc cs ->+                                                (L loc (annBinds (epTok $1) cs (unLoc $2))))+                                              ; return $ Just r} }+        | {- empty -}                   { Nothing }++-----------------------------------------------------------------------------+-- Transformation Rules++rules   :: { [LRuleDecl GhcPs] } -- Reversed+        :  rules ';' rule              {% case $1 of+                                            [] -> return ($3:$1)+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (epTok $2)+                                              return ($3:h':t) }+        |  rules ';'                   {% case $1 of+                                            [] -> return $1+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (epTok $2)+                                              return (h':t) }+        |  rule                        { [$1] }+        |  {- empty -}                 { [] }++rule    :: { LRuleDecl GhcPs }+        : STRING rule_activation rule_foralls infixexp '=' exp+         {%runPV (unECP $4) >>= \ $4 ->+           runPV (unECP $6) >>= \ $6 ->+           amsA' (sLL $1 $> $ HsRule+                                   { rd_ext =((fst $2, epTok $5), getSTRINGs $1)+                                   , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)+                                   , 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+rule_activation :: { (ActivationAnn, Maybe Activation) }+        -- See Note [%shift: rule_activation -> {- empty -}]+        : {- empty -} %shift                    { (noAnn, Nothing) }+        | rule_explicit_activation              { (fst $1,Just (snd $1)) }++-- This production is used to parse the tilde syntax in pragmas such as+--   * {-# INLINE[~2] ... #-}+--   * {-# SPECIALISE [~ 001] ... #-}+--   * {-# RULES ... [~0] ... g #-}+-- Note that it can be written either+--   without a space [~1]  (the PREFIX_TILDE case), or+--   with    a space [~ 1] (the VARSYM case).+-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+rule_activation_marker :: { (Maybe (EpToken "~")) }+      : PREFIX_TILDE { (Just (epTok $1)) }+      | VARSYM  {% if (getVARSYM $1 == fsLit "~")+                   then return (Just (epTok $1))+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $+                               PsErrInvalidRuleActivationMarker+                           ; return Nothing } }++rule_explicit_activation :: { ( ActivationAnn+                              , Activation) }  -- In brackets+        : '[' INTEGER ']'       { ( ActivationAnn (epTok $1) (epTok $3) Nothing (Just (glR $2))+                                  , ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }+        | '[' rule_activation_marker INTEGER ']'+                                { ( ActivationAnn (epTok $1) (epTok $4) $2 (Just (glR $3))+                                  , ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }+        | '[' rule_activation_marker ']'+                                { ( ActivationAnn (epTok $1) (epTok $3) $2 Nothing+                                  , NeverActive) }++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+           { Nothing }++rule_vars :: { [LRuleTyTmVar] }+        : rule_var rule_vars                    { $1 : $2 }+        | {- empty -}                           { [] }++rule_var :: { LRuleTyTmVar }+        : varid                         { sL1a $1 (RuleTyTmVar noAnn $1 Nothing) }+        | '(' varid '::' ctype ')'      {% amsA' (sLL $1 $> (RuleTyTmVar (AnnTyVarBndr [glR $1] [glR $5] noAnn (epUniTok $3)) $2 (Just $4))) }++{- Note [Parsing explicit foralls in Rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We really want the above definition of rule_foralls to be:++  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'+               | 'forall' rule_vars '.'+               | {- empty -}++where rule_vars (term variables) can be named "family" or "role",+but tv_vars (type variables) cannot be. However, such a definition results+in a reduce/reduce conflict. For example, when parsing:+> {-# RULE "name" forall a ... #-}+before the '...' it is impossible to determine whether we should be in the+first or second case of the above.++This is resolved by using rule_vars (which is more general) for both, and+ensuring that type-level quantified variables do not have the names "forall",+"family", or "role" in the function 'checkRuleTyVarBndrNames' in+GHC.Parser.PostProcess.+Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative+to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.+-}++-----------------------------------------------------------------------------+-- Warnings and deprecations (c.f. rules)++maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }+        : '{-# DEPRECATED' strings '#-}'+                            {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))+                                (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }+        | '{-# WARNING' warning_category strings '#-}'+                            {% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))+                                (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}+        |  {- empty -}      { Nothing }++warning_category :: { Maybe (LocatedE InWarningCategory) }+        : 'in' STRING                  { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)+                                                                    (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) }+        | {- empty -}                  { Nothing }++warnings :: { OrdList (LWarnDecl GhcPs) }+        : warnings ';' warning         {% if isNilOL $1+                                           then return ($1 `appOL` $3)+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (epTok $2)+                                              return (snocOL hs t' `appOL` $3) }+        | warnings ';'                 {% if isNilOL $1+                                           then return $1+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (epTok $2)+                                              return (snocOL hs t') }+        | warning                      { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+warning :: { OrdList (LWarnDecl GhcPs) }+        : warning_category namespace_spec namelist strings+                {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)+                     (Warning (unLoc $2, fst $ unLoc $4) (unLoc $3)+                              (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $4))) }++namespace_spec :: { Located NamespaceSpecifier }+  : 'type'      { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }+  | 'data'      { sL1 $1 $ DataNamespaceSpecifier (epTok $1) }+  | {- empty -} { sL0    $ NoNamespaceSpecifier }++deprecations :: { OrdList (LWarnDecl GhcPs) }+        : deprecations ';' deprecation+                                       {% if isNilOL $1+                                           then return ($1 `appOL` $3)+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (epTok $2)+                                              return (snocOL hs t' `appOL` $3) }+        | deprecations ';'             {% if isNilOL $1+                                           then return $1+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (epTok $2)+                                              return (snocOL hs t') }+        | deprecation                  { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+deprecation :: { OrdList (LWarnDecl GhcPs) }+        : namespace_spec namelist strings+             {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (unLoc $1, fst $ unLoc $3) (unLoc $2)+                                          (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }++strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) }+    : STRING             { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) }+    | '[' stringlist ']' { sLL $1 $> $ ((epTok $1,epTok $3),fromOL (unLoc $2)) }++stringlist :: { Located (OrdList (Located StringLiteral)) }+    : stringlist ',' STRING {% if isNilOL (unLoc $1)+                                then return (sLL $1 $> (unLoc $1 `snocOL`+                                                  (L (gl $3) (getStringLiteral $3))))+                                else case (unLoc $1) of+                                   SnocOL hs t -> do+                                     let { t' = addTrailingCommaS t (glR $2) }+                                     return (sLL $1 $> (snocOL hs t' `snocOL`+                                                  (L (gl $3) (getStringLiteral $3))))++}+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }+    | {- empty -}           { noLoc nilOL }++-----------------------------------------------------------------------------+-- Annotations+annotation :: { LHsDecl GhcPs }+    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->+                                            amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation+                                            (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn noAnn,+                                            (getANN_PRAGs $1))+                                            (ValueAnnProvenance $2) $3)) }++    | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->+                                            amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation+                                            (AnnPragma (glR $1) (epTok $5) noAnn noAnn noAnn (epTok $2) noAnn,+                                            (getANN_PRAGs $1))+                                            (TypeAnnProvenance $3) $4)) }++    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->+                                            amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation+                                                (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn (epTok $2),+                                                (getANN_PRAGs $1))+                                                 ModuleAnnProvenance $3)) }++-----------------------------------------------------------------------------+-- Foreign import and export declarations++fdecl :: { Located (EpToken "foreign" -> HsDecl GhcPs) }+fdecl : 'import' callconv safety fspec+               {% mkImport $2 $3 (snd $ unLoc $4) (epTok $1, fst $ unLoc $4) >>= \i ->+                 return (sLL $1 $> i)  }+      | 'import' callconv        fspec+               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3) (epTok $1, fst $ unLoc $3);+                    return (sLL $1 $> d) }}+      | 'export' callconv fspec+               {% mkExport $2 (snd $ unLoc $3) (epTok $1, fst $ unLoc $3) >>= \i ->+                  return (sLL $1 $> i ) }++callconv :: { Located CCallConv }+          : 'stdcall'                   { sLL $1 $> StdCallConv }+          | 'ccall'                     { sLL $1 $> CCallConv   }+          | 'capi'                      { sLL $1 $> CApiConv    }+          | 'prim'                      { sLL $1 $> PrimCallConv}+          | 'javascript'                { sLL $1 $> JavaScriptCallConv }++safety :: { Located Safety }+        : 'unsafe'                      { sLL $1 $> PlayRisky }+        | 'safe'                        { sLL $1 $> PlaySafe }+        | 'interruptible'               { sLL $1 $> PlayInterruptible }++fspec :: { Located (TokDcolon+                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }+       : 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;+         -- the meaning of an empty entity string depends on the calling+         -- convention++-----------------------------------------------------------------------------+-- Type signatures++opt_sig :: { Maybe (EpUniToken "::" "\8759", LHsType GhcPs) }+        : {- empty -}                   { Nothing }+        | '::' ctype                    { Just (epUniTok $1, $2) }++opt_tyconsig :: { (Maybe (EpUniToken "::" "\8759"), Maybe (LocatedN RdrName)) }+             : {- empty -}              { (Nothing, Nothing) }+             | '::' gtycon              { (Just (epUniTok $1), Just $2) }++-- Like ktype, but for types that obey the forall-or-nothing rule.+-- See Note [forall-or-nothing rule] in GHC.Hs.Type.+sigktype :: { LHsSigType GhcPs }+        : sigtype              { $1 }+        | ctype '::' kind      {% amsA' (sLL $1 $> $ mkHsImplicitSigType $+                                         sLLa $1 $> $ HsKindSig (epUniTok $2) $1 $3) }++-- Like ctype, but for types that obey the forall-or-nothing rule.+-- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the+-- logic in ctype here, we simply reuse the ctype production and perform+-- surgery on the LHsType it returns to turn it into an LHsSigType.+sigtype :: { LHsSigType GhcPs }+        : ctype                            { hsTypeToHsSigType $1 }++sig_vars :: { Located [LocatedN RdrName] }    -- Returned in reversed order+         : sig_vars ',' var           {% case unLoc $1 of+                                           [] -> return (sLL $1 $> ($3 : unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingCommaN h (gl $2)+                                             return (sLL $1 $> ($3 : h' : t)) }+         | var                        { sL1 $1 [$1] }++sigtypes1 :: { Located (OrdList (LHsSigType GhcPs)) }+   : sigtype                 { sL1 $1 (unitOL $1) }+   | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (epTok $2)+                                   ; return $ sLL $1 $> (unitOL st `appOL` unLoc $3) } }+-----------------------------------------------------------------------------+-- Types++unpackedness :: { Located UnpackednessPragma }+        : '{-# UNPACK' '#-}'   { sLL $1 $> (UnpackednessPragma (glR $1, epTok $2) (getUNPACK_PRAGs $1) SrcUnpack) }+        | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma (glR $1, epTok $2) (getNOUNPACK_PRAGs $1) SrcNoUnpack) }++forall_telescope :: { Located (HsForAllTelescope GhcPs) }+        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1+                                       ; acs (comb2 $1 $>) (\loc cs -> (L loc $+                                           mkHsForAllInvisTele (EpAnn (glEE $1 $>) (epUniTok $1,epTok $3) cs) $2 )) }}+        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1+                                       ; req_tvbs <- fromSpecTyVarBndrs $2+                                       ; acs (comb2 $1 $>) (\loc cs -> (L loc $+                                           mkHsForAllVisTele (EpAnn (glEE $1 $>) (epUniTok $1,epUniTok $3) cs) req_tvbs )) }}++-- A ktype is a ctype, possibly with a kind annotation+ktype :: { LHsType GhcPs }+        : ctype                { $1 }+        | ctype '::' kind      {% amsA' (sLL $1 $> $ HsKindSig (epUniTok $2) $1 $3) }++-- A ctype is a for-all type+ctype   :: { LHsType GhcPs }+        : forall_telescope ctype      { sLLa $1 $> $+                                              HsForAllTy { hst_tele = unLoc $1+                                                         , hst_xforall = noExtField+                                                         , hst_body = $2 } }+        | context '=>' ctype          {% acsA (comb2 $1 $>) (\loc cs -> (L loc $+                                            HsQualTy { hst_ctxt = addTrailingDarrowC $1 $2 cs+                                                     , hst_xqual = NoExtField+                                                     , hst_body = $3 })) }++        | ipvar '::' ctype            {% amsA' (sLL $1 $> (HsIParamTy (epUniTok $2) (reLoc $1) $3)) }+        | type                        { $1 }++----------------------+-- Notes for 'context'+-- We parse a context as a btype so that we don't get reduce/reduce+-- errors in ctype.  The basic problem is that+--      (Eq a, Ord a)+-- looks so much like a tuple type.  We can't tell until we find the =>++context :: { LHsContext GhcPs }+        :  btype                        {% checkContext $1 }++expcontext :: {forall b. DisambECP b => PV (LocatedC [LocatedA b])}+        : infixexp                      { unECP $1 >>= \ $1 ->+                                          checkContextPV $1 }++{- Note [GADT decl discards annotations]+~~~~~~~~~~~~~~~~~~~~~+The type production for++    btype `->` ctype++add the AnnRarrow annotation twice, in different places.++This is because if the type is processed as usual, it belongs on the annotations+for the type as a whole.++But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and+the top-level annotation will be disconnected. Hence for this specific case it+is connected to the first type too.+-}++type :: { LHsType GhcPs }+        -- See Note [%shift: type -> btype]+        : btype %shift                 { $1 }+        | btype '->' ctype             {% amsA' (sLL $1 $>+                                            $ 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 (HsLinearAnn (EpLolly (epTok $2))) $1 $3) }++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" -> HsMultAnnOf (LocatedA b) GhcPs)) }+expmult : PREFIX_PERCENT aexp           { unECP $2 >>= \ $2 ->+                                          fmap (sLL $1 $>) (mkHsMultPV (epTok $1) $2) }++btype :: { LHsType GhcPs }+        : infixtype                     {% runPV $1 }++infixtype :: { forall b. DisambTD b => PV (LocatedA b) }+        -- See Note [%shift: infixtype -> ftype]+        : ftype %shift                  { $1 }+        | ftype tyop infixtype          { $1 >>= \ $1 ->+                                          $3 >>= \ $3 ->+                                          do { let (op, prom) = $2+                                             ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)+                                             ; mkHsOpTyPV prom $1 op $3 } }+        | unpackedness infixtype        { $2 >>= \ $2 ->+                                          mkUnpackednessPV $1 $2 }++ftype :: { forall b. DisambTD b => PV (LocatedA b) }+        : atype                         { mkHsAppTyHeadPV $1 }+        | tyop                          { failOpFewArgs (fst $1) }+        | ftype tyarg                   { $1 >>= \ $1 ->+                                          mkHsAppTyPV $1 $2 }+        | ftype PREFIX_AT atype         { $1 >>= \ $1 ->+                                          mkHsAppKindTyPV $1 (epTok $2) $3 }++tyarg :: { LHsType GhcPs }+        : atype                         { $1 }+        | unpackedness atype            {% addUnpackednessP $1 $2 }++tyop :: { (LocatedN RdrName, PromotionFlag) }+        : qtyconop                      { ($1, NotPromoted) }+        | tyvarop                       { ($1, NotPromoted) }+        | SIMPLEQUOTE qconop            {% do { op <- amsr (sLL $1 $> (unLoc $2))+                                                           (NameAnnQuote (epTok $1) (gl $2) [])+                                              ; return (op, IsPromoted) } }+        | SIMPLEQUOTE varop             {% do { op <- amsr (sLL $1 $> (unLoc $2))+                                                           (NameAnnQuote (epTok $1) (gl $2) [])+                                              ; return (op, IsPromoted) } }++atype :: { LHsType GhcPs }+        : ntgtycon                       {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) }      -- Not including unit tuples+        -- See Note [%shift: atype -> tyvar]+        | tyvar %shift                   {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) }      -- (See Note [Unit tuples])+        | '_'   %shift                   { sL1a $1 $ mkAnonWildCardTy (epTok $1) }+        | '*'                            {% do { warnStarIsType (getLoc $1)+                                               ; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | 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 $> $ XHsType $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)+                                               ; checkRecordSyntax decls }}+                                                        -- Constructor sigs only++        -- List and tuple syntax whose interpretation depends on the extension ListTuplePuns.+        | '(' ')'                        {% amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (epTok $1) [] (epTok $>)) }+        | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (epTok $3)+                                               ; amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (epTok $1) (h : $4) (epTok $>)) }}+        | '(#' '#)'                   {% do { requireLTPuns PEP_TupleSyntaxType $1 $>+                                            ; amsA' (sLL $1 $> $ HsTupleTy (AnnParensHash (epTok $1) (epTok $2)) HsUnboxedTuple []) } }+        | '(#' comma_types1 '#)'      {% do { requireLTPuns PEP_TupleSyntaxType $1 $>+                                            ; amsA' (sLL $1 $> $ HsTupleTy (AnnParensHash (epTok $1) (epTok $3)) HsUnboxedTuple $2) } }+        | '(#' bar_types2 '#)'        {% do { requireLTPuns PEP_SumSyntaxType $1 $>+                                      ; amsA' (sLL $1 $> $ HsSumTy (AnnParensHash (epTok $1) (epTok $3)) $2) } }+        | '[' ktype ']'               {% amsA' . sLL $1 $> =<< (mkListSyntaxTy1 (epTok $1) $2 (epTok $3)) }+        | '(' ktype ')'               {% amsA' (sLL $1 $> $ HsParTy (epTok $1, epTok $3) $2) }+                                      -- see Note [Promotion] for the followings+        | SIMPLEQUOTE '(' ')'         {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>+                                            ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $3) IsPromoted []) }}+        | SIMPLEQUOTE gen_qcon {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }+        | SIMPLEQUOTE sysdcon_nolist {% do { requireLTPuns PEP_QuoteDisambiguation $1 (reLoc $>)+                                           ; amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted (L (getLoc $2) $ nameRdrName (dataConName (unLoc $2)))) }}+        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'+                             {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>+                                   ; h <- addTrailingCommaA $3 (epTok $4)+                                   ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $6) IsPromoted (h : $5)) }}+        | '[' ']'               {% withCombinedComments $1 $> (mkListSyntaxTy0 (epTok $1) (epTok $2)) }+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>+                                                      ; amsA' (sLL $1 $> $ HsExplicitListTy (epTok $1, epTok $2, epTok $4) IsPromoted $3) }}+        | SIMPLEQUOTE var                       {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }++        | quasiquote                  { mapLocA (HsSpliceTy noExtField) $1 }+        | splice_untyped              { mapLocA (HsSpliceTy noExtField) $1 }++        -- Two or more [ty, ty, ty] must be a promoted list type, just as+        -- if you had written '[ty, ty, ty]+        -- (One means a list type, zero means the list type constructor,+        -- so you have to quote those.)+        | '[' ktype ',' comma_types1 ']'  {% do { h <- addTrailingCommaA $2 (epTok $3)+                                                ; amsA' (sLL $1 $> $ HsExplicitListTy (NoEpTok,epTok $1,epTok $5) NotPromoted (h:$4)) }}+        | INTEGER              { sLLa $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)+                                                           (il_value (getINTEGER $1)) }+        | CHAR                 { sLLa $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)+                                                                        (getCHAR $1) }+        | STRING               { sLLa $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)+                                                                     (getSTRING  $1) }+        | STRING_MULTI         { sLLa $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGMULTIs $1)+                                                                     (getSTRINGMULTI  $1) }+        -- Type variables are never exported, so `M.tyvar` will be rejected by the renamer.+        -- We let it pass the parser because the renamer can generate a better error message.+        | QVARID                      {% let qname = mkQual tvName (getQVARID $1)+                                         in  amsA' (sL1 $1 (HsTyVar noAnn NotPromoted (sL1n $1 $ qname)))}++-- An inst_type is what occurs in the head of an instance decl+--      e.g.  (Foo a, Gaz b) => Wibble a b+-- It's kept as a single type for convenience.+inst_type :: { LHsSigType GhcPs }+        : sigtype                       { $1 }++deriv_types :: { [LHsSigType GhcPs] }+        : sigktype                      { [$1] }++        | sigktype ',' deriv_types      {% do { h <- addTrailingCommaA $1 (epTok $2)+                                           ; return (h : $3) } }++comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty+        : comma_types1                  { $1 }+        | {- empty -}                   { [] }++comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty+        : ktype                        { [$1] }+        | ktype  ',' comma_types1      {% do { h <- addTrailingCommaA $1 (epTok $2)+                                             ; return (h : $3) }}++bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty+        : ktype  '|' ktype             {% do { h <- addTrailingVbarA $1 (epTok $2)+                                             ; return [h,$3] }}+        | ktype  '|' bar_types2        {% do { h <- addTrailingVbarA $1 (epTok $2)+                                             ; return (h : $3) }}++tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }+         : tv_bndr tv_bndrs             { $1 : $2 }+         | {- empty -}                  { [] }++tv_bndr :: { LHsTyVarBndr Specificity GhcPs }+        : tv_bndr_no_braces             { $1 }+        | '{' tyvar '}'                 {% amsA' (sLL $1 $>+                                                (HsTvb { tvb_ext  = AnnTyVarBndr [glR $1] [glR $3] noAnn noAnn+                                                       , tvb_flag = InferredSpec+                                                       , tvb_var  = HsBndrVar noExtField $2+                                                       , tvb_kind = HsBndrNoKind noExtField })) }+        | '{' tyvar '::' kind '}'       {% amsA' (sLL $1 $>+                                                (HsTvb { tvb_ext  = AnnTyVarBndr [glR $1] [glR $5] noAnn (epUniTok $3)+                                                       , tvb_flag = InferredSpec+                                                       , tvb_var  = HsBndrVar noExtField $2+                                                       , tvb_kind = HsBndrKind noExtField $4 })) }++tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }+        : tyvar_wc                      {% amsA' (sL1 $1+                                                (HsTvb { tvb_ext  = noAnn+                                                       , tvb_flag = SpecifiedSpec+                                                       , tvb_var  = unLoc $1+                                                       , tvb_kind = HsBndrNoKind noExtField })) }+        | '(' tyvar_wc '::' kind ')'    {% amsA' (sLL $1 $>+                                                (HsTvb { tvb_ext  = AnnTyVarBndr [glR $1] [glR $5] noAnn (epUniTok $3)+                                                       , tvb_flag = SpecifiedSpec+                                                       , tvb_var  = unLoc $2+                                                       , tvb_kind = HsBndrKind noExtField $4 })) }++tyvar_wc :: { Located (HsBndrVar GhcPs) }+        : tyvar                         { sL1 $1 (HsBndrVar noExtField $1) }+        | '_'                           { sL1 $1 (HsBndrWildCard (epTok $1)) }++fds :: { Located (EpToken "|",[LHsFunDep GhcPs]) }+        : {- empty -}                   { noLoc (NoEpTok,[]) }+        | '|' fds1                      { (sLL $1 $> (epTok $1 ,reverse (unLoc $2))) }++fds1 :: { Located [LHsFunDep GhcPs] }+        : fds1 ',' fd   {%+                           do { let (h:t) = unLoc $1 -- Safe from fds1 rules+                              ; h' <- addTrailingCommaA h (epTok $2)+                              ; return (sLL $1 $> ($3 : h' : t)) }}+        | fd            { sL1 $1 [$1] }++fd :: { LHsFunDep GhcPs }+        : varids0 '->' varids0  {% amsA' (L (comb3 $1 $2 $3)+                                       (FunDep (epUniTok $2)+                                               (reverse (unLoc $1))+                                               (reverse (unLoc $3)))) }++varids0 :: { Located [LocatedN RdrName] }+        : {- empty -}                   { noLoc [] }+        | varids0 tyvar                 { sLL $1 $> ($2 : (unLoc $1)) }++-----------------------------------------------------------------------------+-- Kinds++kind :: { LHsKind GhcPs }+        : ctype                  { $1 }++{- Note [Promotion]+   ~~~~~~~~~~~~~~~~++- Syntax of promoted qualified names+We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified+names. Moreover ticks are only allowed in types, not in kinds, for a+few reasons:+  1. we don't need quotes since we cannot define names in kinds+  2. if one day we merge types and kinds, tick would mean look in DataName+  3. we don't have a kind namespace anyway++- Name resolution+When the user write Zero instead of 'Zero in types, we parse it a+HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We+deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not+bounded in the type level, then we look for it in the term level (we+change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).+And both become a HsTyVar ("Zero", DataName) after the renamer.++- ListTuplePuns+When this extension is disabled, ticked constructors for lists and tuples are+not accepted, while the unticked variants are unconditionally parsed as data+constructors.++-}+++-----------------------------------------------------------------------------+-- Datatype declarations++gadt_constrlist :: { Located ((EpToken "where", EpToken "{", EpToken "}")+                          ,[LConDecl GhcPs]) } -- Returned in order++        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $+                                                      L (comb2 $1 $4)+                                                        ((epTok $1+                                                         ,epTok $2+                                                         ,epTok $4)+                                                        , unLoc $3) }+        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $+                                                      L (comb2 $1 $3)+                                                        ((epTok $1, NoEpTok, NoEpTok)+                                                        , unLoc $3) }+        | {- empty -}                            { noLoc (noAnn,[]) }++gadt_constrs :: { Located [LConDecl GhcPs] }+        : gadt_constr ';' gadt_constrs+                  {% do { h <- addTrailingSemiA $1 (epTok $2)+                        ; return (L (comb2 $1 $3) (h : unLoc $3)) }}+        | gadt_constr                   { L (glA $1) [$1] }+        | {- empty -}                   { noLoc [] }++-- We allow the following forms:+--      C :: Eq a => a -> T a+--      C :: forall a. Eq a => !a -> T a+--      D { x,y :: a } :: T a+--      forall a. Eq a => D { x,y :: a } :: T a++gadt_constr :: { LConDecl GhcPs }+    -- see Note [Difference in parsing GADT and data constructors]+    -- Returns a list because of:   C,D :: ty+    -- TODO:AZ capture the optSemi. Why leading?+        : optSemi con_list '::' sigtype+                {% mkGadtDecl (comb2 $2 $>) (unLoc $2) (epUniTok $3) $4 }++{- Note [Difference in parsing GADT and data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GADT constructors have simpler syntax than usual data constructors:+in GADTs, types cannot occur to the left of '::', so they cannot be mixed+with constructor names (see Note [Parsing data constructors is hard]).++Due to simplified syntax, GADT constructor names (left-hand side of '::')+use simpler grammar production than usual data constructor names. As a+consequence, GADT constructor names are restricted (names like '(*)' are+allowed in usual data constructors, but not in GADTs).+-}++constrs :: { Located (EpToken "=",[LConDecl GhcPs]) }+        : '=' constrs1    { sLL $1 $2 (epTok $1,unLoc $2)}++constrs1 :: { Located [LConDecl GhcPs] }+        : constrs1 '|' constr+            {% do { let (h:t) = unLoc $1+                  ; h' <- addTrailingVbarA h (epTok $2)+                  ; return (sLL $1 $> ($3 : h' : t)) }}+        | constr                         { sL1 $1 [$1] }++constr :: { LConDecl GhcPs }+        : forall context '=>' constr_stuff+                {% amsA' (let (con,details) = unLoc $4 in+                  (L (comb4 $1 $2 $3 $4) (mkConDeclH98+                                                       (epUniTok $3,(fst $ unLoc $1))+                                                       con+                                                       (snd $ unLoc $1)+                                                       (Just $2)+                                                       details))) }+        | forall constr_stuff+                {% amsA' (let (con,details) = unLoc $2 in+                  (L (comb2 $1 $2) (mkConDeclH98 (noAnn, fst $ unLoc $1)+                                                      con+                                                      (snd $ unLoc $1)+                                                      Nothing   -- No context+                                                      details))) }++forall :: { Located ((TokForall, EpToken "."), Maybe [LHsTyVarBndr Specificity GhcPs]) }+        : 'forall' tv_bndrs '.'       { sLL $1 $> ((epUniTok $1,epTok $3), Just $2) }+        | {- empty -}                 { noLoc (noAnn, Nothing) }++constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }+        : infixtype       {% do { b <- runPV $1+                                ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) }}+        | '(#' usum_constr '#)' {% let (t, tag, arity) = $2 in pure (sLL $1 $3 $ mkUnboxedSumCon t tag arity)}++usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls SumN#+         : ktype bars { ($1, 1, (snd $2 + 1)) }+         | bars ktype bars0 { ($2, snd $1 + 1, snd $1 + snd $3 + 1) }++fielddecls :: { [LHsConDeclRecField GhcPs] }+        : {- empty -}     { [] }+        | fielddecls1     { $1 }++fielddecls1 :: { [LHsConDeclRecField GhcPs] }+        : fielddecl ',' fielddecls1+            {% do { h <- addTrailingCommaA $1 (epTok $2)+                  ; return (h : $3) }}+        | fielddecl   { [$1] }++fielddecl :: { LHsConDeclRecField GhcPs }+                                              -- A list because of   f,g :: Int+        : sig_vars '::' ctype+            {% amsA' (L (comb2 $1 $3)+                      (HsConDeclRecField noExtField+                                    (reverse (map (\ln@(L l n)+                                               -> 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) }+        : {- empty -}             { noLoc [] }+        | derivings               { $1 }++-- A list of one or more deriving clauses at the end of a datatype+derivings :: { Located (HsDeriving GhcPs) }+        : derivings deriving      { sLL $1 $> ($2 : unLoc $1) } -- AZ: order?+        | deriving                { sL1 $> [$1] }++-- The outer Located is just to allow the caller to+-- know the rightmost extremity of the 'deriving' clause+deriving :: { LHsDerivingClause GhcPs }+        : 'deriving' deriv_clause_types+              {% let { full_loc = comb2 $1 $> }+                 in amsA' (L full_loc $ HsDerivingClause (epTok $1) Nothing $2) }++        | 'deriving' deriv_strategy_no_via deriv_clause_types+              {% let { full_loc = comb2 $1 $> }+                 in amsA' (L full_loc $ HsDerivingClause (epTok $1) (Just $2) $3) }++        | 'deriving' deriv_clause_types deriv_strategy_via+              {% let { full_loc = comb2 $1 $> }+                 in amsA' (L full_loc $ HsDerivingClause (epTok $1) (Just $3) $2) }++deriv_clause_types :: { LDerivClauseTys GhcPs }+        : qtycon              { let { tc = sL1a $1 $ mkHsImplicitSigType $+                                           sL1a $1 $ HsTyVar noAnn NotPromoted $1 } in+                                sL1a $1 (DctSingle noExtField tc) }+        | '(' ')'             {% amsr (sLL $1 $> (DctMulti noExtField []))+                                      (AnnContext Nothing [epTok $1] [epTok $2]) }+        | '(' deriv_types ')' {% amsr (sLL $1 $> (DctMulti noExtField $2))+                                      (AnnContext Nothing [epTok $1] [epTok $3])}++-----------------------------------------------------------------------------+-- Value definitions++{- Note [Declaration/signature overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's an awkward overlap with a type signature.  Consider+        f :: Int -> Int = ...rhs...+   Then we can't tell whether it's a type signature or a value+   definition with a result signature until we see the '='.+   So we have to inline enough to postpone reductions until we know.+-}++{-+  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+  instead of qvar, we get another shift/reduce-conflict. Consider the+  following programs:++     { (^^) :: Int->Int ; }          Type signature; only var allowed++     { (^^) :: Int->Int = ... ; }    Value defn with result signature;+                                     qvar allowed (because of instance decls)++  We can't tell whether to reduce var to qvar until after we've read the signatures.+-}++decl_no_th :: { LHsDecl GhcPs }+        : sigdecl               { $1 }++        | infixexp opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->+                                       do { let { l = comb2 $1 $> }+                                          ; 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 ->+                                       do { let { l = comb2 $1 $> }+                                          ; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2 EpPatBind, $4) $5;+                                        -- parses bindings of the form %p x or+                                        -- %p x :: sig+                                        --+                                        -- 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) } }+        | pattern_synonym_decl  { $1 }++decl    :: { LHsDecl GhcPs }+        : decl_no_th            { $1 }++        -- Why do we only allow naked declaration splices in top-level+        -- declarations and not here? Short answer: because readFail009+        -- fails terribly with a panic in cvBindsAndSigs otherwise.+        | splice_exp            { mkSpliceDecl $1 }++rhs     :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }+        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 ->+                                  do { let L l (bs, csw) = adaptWhereBinds $3+                                     ; let loc = (comb3 $1 $2 (L l bs))+                                     ; let locg = (comb2 $1 $2)+                                     ; acs loc (\loc cs ->+                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (spanAsAnchor locg) (GrhsAnn Nothing (Left $ epTok $1)) cs) locg $2)+                                                      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) (NE.reverse (unLoc $1)) bs)) }}++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 ->+                                     acsA (comb2 $1 $>) (\loc cs -> L loc $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ epTok $1) (Left $ epTok $3)) cs) (unLoc $2) $4) }++sigdecl :: { LHsDecl GhcPs }+        :+        -- See Note [Declaration/signature overlap] for why we need infixexp here+          infixexp     '::' sigtype+                        {% do { $1 <- runPV (unECP $1)+                              ; v <- checkValSigLhs $1+                              ; amsA' (sLL $1 $> $ SigD noExtField $+                                  TypeSig (AnnSig (epUniTok $2) Nothing Nothing) [v] (mkHsWildCardBndrs $3))} }++        | var ',' sig_vars '::' sigtype+           {% do { v <- addTrailingCommaN $1 (gl $2)+                 ; let sig = TypeSig (AnnSig (epUniTok $4) Nothing Nothing) (v : reverse (unLoc $3))+                                      (mkHsWildCardBndrs $5)+                 ; amsA' (sLL $1 $> $ SigD noExtField sig ) }}++        | infix prec namespace_spec ops+             {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $4+                                                      ; pure (glR l2) })+                                       $2+                   ; let (fixText, fixPrec) = case $2 of+                                                -- If an explicit precedence isn't supplied,+                                                -- it defaults to maxPrecedence+                                                Nothing -> (NoSourceText, maxPrecedence)+                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)+                   ; amsA' (sLL $1 $> $ SigD noExtField+                            (FixSig ((glR $1, mbPrecAnn), fixText) (FixitySig (unLoc $3) (fromOL $ unLoc $4)+                                    (Fixity fixPrec (unLoc $1)))))+                   }}++        | pattern_synonym_sig   { L (getLoc $1) . SigD noExtField . unLoc $ $1 }++        | '{-# COMPLETE' qcon_list opt_tyconsig  '#-}'+                {% let (dcolon, tc) = $3+                   in amsA' (sLL $1 $>+                         (SigD noExtField (CompleteMatchSig ((glR $1,dcolon,epTok $4), (getCOMPLETE_PRAGs $1)) $2 tc))) }++        -- This rule is for both INLINE and INLINABLE pragmas+        | '{-# INLINE' activation qvarcon '#-}'+                {% amsA' (sLL $1 $> $ SigD noExtField (InlineSig (glR $1, epTok $4, fst $2) $3+                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)+                                            (snd $2)))) }+        | '{-# OPAQUE' qvar '#-}'+                {% amsA' (sLL $1 $> $ SigD noExtField (InlineSig (glR $1, epTok $3, noAnn) $2+                            (mkOpaquePragma (getOPAQUE_PRAGs $1)))) }+        | '{-# SCC' qvar '#-}'+          {% amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ((glR $1, epTok $3), (getSCC_PRAGs $1)) $2 Nothing))) }++        | '{-# SCC' qvar STRING '#-}'+          {% do { scc <- getSCC $3+                ; 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 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 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)) }++        -- A minimal complete definition+        | '{-# 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) }+        | explicit_activation                   { (fst $1,Just (snd $1)) }++explicit_activation :: { (ActivationAnn, Activation) }  -- In brackets+        : '[' INTEGER ']'       { (ActivationAnn (epTok $1) (epTok  $3) Nothing (Just (glR $2))+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }+        | '[' rule_activation_marker INTEGER ']'+                                { (ActivationAnn (epTok $1) (epTok $4) $2 (Just (glR $3))+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }++-----------------------------------------------------------------------------+-- Expressions++quasiquote :: { Located (HsUntypedSplice GhcPs) }+        : TH_QUASIQUOTE   { let { loc = getLoc $1+                                ; 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, 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 }+exp2 :: { ECP } : exp_gen(infixexp2) { $1 }++exp_gen(IEXP) :: { ECP }+        : IEXP '::' ctype+                                { ECP $+                                   unECP $1 >>= \ $1 ->+                                   rejectPragmaPV $1 >>+                                   mkHsTySigPV (noAnnSrcSpan $ comb2 $1 $>) $1 $3+                                          (epUniTok $2) }+        | IEXP '-<' exp_gen(IEXP)+                                {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $1 $3+                                                        HsFirstOrderApp True) }+        | IEXP '>-' exp_gen(IEXP)+                                {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $3 $1+                                                      HsFirstOrderApp False) }+        | IEXP '-<<' exp_gen(IEXP)+                                {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $1 $3+                                                      HsHigherOrderApp True) }+        | IEXP '>>-' exp_gen(IEXP)+                                {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $3 $1+                                                      HsHigherOrderApp False) }+        -- See Note [%shift: exp -> infixexp]+        | IEXP %shift              { $1 }+        | exp_prag(exp_gen(IEXP))  { $1 } -- See Note [Pragmas and operator fixity]++        -- Embed types into expressions and patterns for required type arguments+        | 'type' atype             { ECP $ mkHsEmbTyPV (comb2 $1 $>) (epTok $1) $2 }++infixexp2 :: { ECP }+        : infixexp %shift       { $1 }++        -- View patterns and function arrows+        | infixexp '->' infixexp2+                                { ECP $+                                  withArrowParsingMode' $ \mode ->+                                  unECP $1 >>= \ $1 ->+                                  unECP $3 >>= \ $3 ->+                                  let arr = HsUnannotated (EpArrow (epUniTok $2))+                                  in mkHsArrowPV (comb2 $1 $>) mode $1 arr $3 }+        | infixexp expmult '->'  infixexp2+                                { ECP $+                                  unECP $1         >>= \ $1 ->+                                  $2               >>= \ $2 ->+                                  unECP $4         >>= \ $4 ->+                                  hintLinear (getLoc $2) >>+                                  let arr = (unLoc $2) (epUniTok $3)+                                  in mkHsArrowPV (comb2 $1 $>) ArrowIsFunType $1 arr $4 }+        | infixexp      '->.' infixexp2+                                { ECP $+                                  hintLinear (getLoc $2) >>+                                  unECP $1 >>= \ $1 ->+                                  unECP $3 >>= \ $3 ->+                                  let arr = HsLinearAnn (EpLolly (epTok $2))+                                  in mkHsArrowPV (comb2 $1 $>) ArrowIsFunType $1 arr $3 }+        | expcontext    '=>'  infixexp2+                                { ECP $+                                        $1 >>= \ $1 ->+                                  unECP $3 >>= \ $3 ->+                                  mkQualPV (comb2 $1 $>) (addTrailingDarrowC $1 $2 emptyComments) $3}++        | forall_telescope infixexp2+                                { ECP $+                                  unECP $2 >>= \ $2 ->+                                  mkHsForallPV (comb2 $1 $>) (unLoc $1) $2 }++infixexp :: { ECP }+        : exp10 { $1 }+        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]+                               { ECP $+                                 superInfixOp $+                                 $2 >>= \ $2 ->+                                 unECP $1 >>= \ $1 ->+                                 unECP $3 >>= \ $3 ->+                                 rejectPragmaPV $1 >>+                                 (mkHsOpAppPV (comb2 $1 $3) $1 $2 $3) }+                 -- AnnVal annotation for NPlusKPat, which discards the operator++exp10p :: { ECP }+  : exp10            { $1 }+  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]++exp_prag(e) :: { ECP }+  : prag_e e  -- See Note [Pragmas and operator fixity]+      {% runPV (unECP $2) >>= \ $2 ->+         fmap ecpFromExp $+         amsA' $ (sLL $1 $> $ HsPragE noExtField (unLoc $1) $2) }++exp10 :: { ECP }+        -- See Note [%shift: exp10 -> '-' fexp]+        : '-' fexp %shift               { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkHsNegAppPV (comb2 $1 $>) $2+                                                 (epTok $1) }+        -- See Note [%shift: exp10 -> fexp]+        | fexp %shift                  { $1 }++optSemi :: { (Maybe (EpToken ";"),Bool) }+        : ';'         { (msemim $1,True) }+        | {- empty -} { (Nothing,False) }++{- Note [Pragmas and operator fixity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'prag_e' is an expression pragma, such as {-# SCC ... #-}.++It must be used with care, or else #15730 happens. Consider this infix+expression:++         1 / 2 / 2++There are two ways to parse it:++    1.   (1 / 2) / 2   =  0.25+    2.   1 / (2 / 2)   =  1.0++Due to the fixity of the (/) operator (assuming it comes from Prelude),+option 1 is the correct parse. However, in the past GHC's parser used to get+confused by the SCC annotation when it occurred in the middle of an infix+expression:++         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2++There are several ways to address this issue, see GHC Proposal #176 for a+detailed exposition:++  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst++The accepted fix is to disallow pragmas that occur within infix expressions.+Infix expressions are assembled out of 'exp10', so 'exp10' must not accept+pragmas. Instead, we accept them in exactly two places:++* at the start of an expression or a parenthesized subexpression:++    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression+    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression++* immediately after the last operator:++    f = 1 / 2 / {-# SCC ann #-} 2++In both cases, the parse does not depend on operator fixity. The second case+may sound unnecessary, but it's actually needed to support a common idiom:++    f $ {-# SCC ann $-} ...++-}+prag_e :: { Located (HsPragE GhcPs) }+      : '{-# SCC' STRING '#-}'      {% do { scc <- getSCC $2+                                          ; return (sLL $1 $>+                                             (HsPragSCC+                                                (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn,+                                                (getSCC_PRAGs $1))+                                                (StringLiteral (getSTRINGs $2) scc Nothing)))} }+      | '{-# SCC' VARID  '#-}'      { sLL $1 $>+                                             (HsPragSCC+                                               (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn,+                                               (getSCC_PRAGs $1))+                                               (StringLiteral NoSourceText (getVARID $2) Nothing)) }++fexp    :: { ECP }+        : fexp aexp                  { ECP $+                                          superFunArg $+                                          unECP $1 >>= \ $1 ->+                                          unECP $2 >>= \ $2 ->+                                          spanWithComments (comb2 $1 $>) >>= \l ->+                                          mkHsAppPV l $1 $2 }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | fexp PREFIX_AT atype       { ECP $+                                        unECP $1 >>= \ $1 ->+                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 $1 $>) $1 (epTok $2) $3 }++        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->+                                        fmap ecpFromExp $+                                        amsA' (sLL $1 $> $ HsStatic (epTok $1) $2) }++        | aexp                       { $1 }++aexp    :: { ECP }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : qvar TIGHT_INFIX_AT aexp+                                { ECP $+                                   unECP $3 >>= \ $3 ->+                                     mkHsAsPatPV (comb2 $1 $>) $1 (epTok $2) $3 }+++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | PREFIX_TILDE aexp     { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsLazyPatPV (comb2 $1 $>) $2 (epTok $1) }+        | PREFIX_BANG aexp      { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsBangPatPV (comb2 $1 $>) $2 (epTok $1) }+        | PREFIX_MINUS aexp     { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsNegAppPV (comb2 $1 $>) $2 (epTok $1) }+        | 'let' binds 'in' exp          {  ECP $+                                           unECP $4 >>= \ $4 ->+                                           mkHsLetPV (comb2 $1 $>) (epTok $1) (unLoc $2) (epTok $3) $4 }+        | '\\' argpats '->' exp { ECP $+                      unECP $4 >>= \ $4 ->+                      mkHsLamPV (comb2 $1 $>) LamSingle+                            (sLLld $1 $>+                            [sLLa $1 $>+                                         $ Match { m_ext = noExtField+                                                 , m_ctxt = LamAlt LamSingle+                                                 , m_pats = L (listLocation $2) $2+                                                 , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (Right $ epUniTok $3)) emptyComments) }])+                            (EpAnnLam (epTok $1) Nothing) }+        | '\\' 'lcase' altslist(pats1)+            {  ECP $ $3 >>= \ $3 ->+                 mkHsLamPV (comb3 $1 $2 $>) LamCase $3 (EpAnnLam (epTok $1) (Just (glR $2))) }+        | '\\' 'lcases' altslist(argpats)+            {  ECP $ $3 >>= \ $3 ->+                 mkHsLamPV (comb3 $1 $2 $>) LamCases $3 (EpAnnLam (epTok $1) (Just (glR $2))) }+        | 'if' exp optSemi 'then' exp optSemi 'else' exp+                         {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->+                            return $ ECP $+                              unECP $5 >>= \ $5 ->+                              unECP $8 >>= \ $8 ->+                              mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8+                                    (AnnsIf+                                      { aiIf = epTok $1+                                      , aiThen = epTok $4+                                      , aiElse = epTok $7+                                      , aiThenSemi = fst $3+                                      , aiElseSemi = fst $6})}++        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->+                                           fmap ecpFromExp $+                                           do { let (L _ ((o,c),_)) = $2+                                              ; amsA' (sLL $1 $> $ HsMultiIf (epTok $1, o, c)+                                                     (NE.reverse $ snd $ unLoc $2)) }}+        | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->+                                             return $ ECP $+                                               $4 >>= \ $4 ->+                                               mkHsCasePV (comb3 $1 $3 $4) $2 $4+                                                    (EpAnnHsCase (epTok $1) (epTok $3)) }+        -- QualifiedDo.+        | DO  stmtlist               {% do+                                      hintQualifiedDo $1+                                      return $ ECP $+                                        $2 >>= \ $2 ->+                                        mkHsDoPV (comb2 $1 $2)+                                                 (fmap mkModuleNameFS (getDO $1))+                                                 $2+                                                 (glR $1)+                                                 (glR $2) }+        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->+                                       fmap ecpFromExp $+                                       amsA' (L (comb2 $1 $2)+                                              (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO $1))+                                                     $2+                                                     (glR $1)+                                                     (glR $2))) }+        | 'proc' aexp '->' exp+                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->+                           runPV (unECP $4) >>= \ $4@cmd ->+                           fmap ecpFromExp $+                           amsA' (sLL $1 $> $HsProc (epTok $1, epUniTok $3) p (sLLa $1 $> $ HsCmdTop noExtField cmd)) }++        | aexp1                 { $1 }++aexp1   :: { ECP }+        : aexp1 '{' fbinds '}' { ECP $+                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->+                                   unECP $1 >>= \ $1 ->+                                   $3 >>= \ $3 ->+                                   mkHsRecordPV overloaded (comb2 $1 $>) (comb2 $2 $4) $1 $3+                                        (Just (epTok $2), Just (epTok $4))+                               }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | aexp1 TIGHT_INFIX_PROJ field+            {% runPV (unECP $1) >>= \ $1 ->+               fmap ecpFromExp $ amsA' (+                 let fl = sLLa $2 $> (DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) $3) in+               sLL $1 $> $ mkRdrGetField $1 fl)  }++++        | aexp2                { $1 }++aexp2   :: { ECP }+        : qvar                          { ECP $ mkHsVarPV $! $1 }+        | qcon                          { ECP $ mkHsVarPV $! $1 }+        -- See Note [%shift: aexp2 -> ipvar]+        | ipvar %shift                  {% fmap ecpFromExp+                                           (ams1 $1 (HsIPVar NoExtField $! unLoc $1)) }+        | overloaded_label              {% fmap ecpFromExp+                                           (ams1 $1 (HsOverLabel (fst $! unLoc $1) (snd $! unLoc $1))) }+        | literal                       { ECP $ mkHsLitPV $! $1 }+-- This will enable overloaded strings permanently.  Normally the renamer turns HsString+-- into HsOverLit when -XOverloadedStrings is on.+--      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)+--                                       (getSTRING $1) noExtField) }+        | INTEGER   { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral   (getINTEGER  $1)) }+        | RATIONAL  { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsFractional (getRATIONAL $1)) }++        -- N.B.: sections get parsed by these next two productions.+        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't+        -- correct Haskell (you'd have to write '((+ 3), (4 -))')+        -- but the less cluttered version fell out of having texps.+        | '(' texp ')'                  { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkHsParPV (comb2 $1 $>) (epTok $1) $2 (epTok $3) }+        | '(' tup_exprs ')'             { ECP $+                                           $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2+                                                (glR $1,glR $3)}++        | '(' orpats(exp2) ')'          {% do+                                              { pat <- hintOrPats (sL1a $2 (OrPat NoExtField (unLoc $2)))+                                              ; fmap ecpFromPat+                                                (amsA' (sLL $1 $> (ParPat (epTok $1, epTok $>) pat))) }}++        -- This case is only possible when 'OverloadedRecordDotBit' is enabled.+        | '(' projection ')'            { ECP $+                                            amsA' (sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (AnnProjection (epTok $1) (epTok $3)) )+                                            >>= ecpFromExp'+                                        }++        | '(#' texp '#)'                { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])+                                                 (glR $1,glR $3) }+        | '(#' tup_exprs '#)'           { ECP $+                                           $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2+                                                (glR $1,glR $3) }++        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) (glR $1,glR $3) }+        | '_'               { ECP $ mkHsWildCardPV (getLoc $1) }++        -- Template Haskell Extension+        | splice_untyped { ECP $ mkHsSplicePV $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)) }+        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) False $2)) }+        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket noExtField (VarBr (glR $1) False $2)) }+        -- See Note [%shift: aexp2 -> TH_TY_QUOTE]+        | TH_TY_QUOTE %shift    {% reportEmptyDoubleQuotes (getLoc $1) }+        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->+                                 fmap ecpFromExp $+                                 amsA' (sLL $1 $> $ HsUntypedBracket noExtField (ExpBr (if (hasE $1) then (BracketHasE (epTok $1),   epUniTok $3)+                                                                                                     else (BracketNoE (epUniTok $1), epUniTok $3)) $2)) }+        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->+                                 fmap ecpFromExp $+                                 amsA' (sLL $1 $> $ HsTypedBracket (if (hasE $1) then (BracketHasE (epTok $1),epTok $3) else (BracketNoE (epTok $1),epTok $3)) $2) }+        | '[t|' ktype '|]'    {% fmap ecpFromExp $+                                 amsA' (sLL $1 $> $ HsUntypedBracket noExtField (TypBr (epTok $1,epUniTok $3) $2)) }+        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->+                                      fmap ecpFromExp $+                                      amsA' (sLL $1 $> $ HsUntypedBracket noExtField (PatBr (epTok $1,epUniTok $3) p)) }+        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $+                                  amsA' (sLL $1 $> $ HsUntypedBracket noExtField (DecBrL (epTok $1,epUniTok $3, fst $2) (snd $2))) }+        | quasiquote          { ECP $ mkHsSplicePV $1 }++        -- arrow notation extension+        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->+                                      fmap ecpFromCmd $+                                      amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) [] noAnn []) $2 Prefix+                                                           (reverse $3)) }++projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }+projection+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer+        : projection TIGHT_INFIX_PROJ field+                             { sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (AnnFieldLabel (Just $ epTok $2)) $3) `NE.cons` unLoc $1) }+        | PREFIX_PROJ field  { sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (AnnFieldLabel (Just $ epTok $1)) $2) :| [])}++splice_exp :: { LHsExpr GhcPs }+        : splice_untyped { fmap (HsUntypedSplice noExtField) (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 (HsTypedSplice GhcPs) }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : PREFIX_DOLLAR_DOLLAR aexp2+                                {% runPV (unECP $2) >>= \ $2 ->+                                   return (sLL $1 $> $ (HsTypedSpliceExpr (epTok $1) $2)) }++cmdargs :: { [LHsCmdTop GhcPs] }+        : cmdargs acmd                  { $2 : $1 }+        | {- empty -}                   { [] }++acmd    :: { LHsCmdTop GhcPs }+        : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->+                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->+                                   return (sL1a cmd $ HsCmdTop noExtField cmd) }++cvtopbody :: { ((EpToken "{", EpToken "}"),[LHsDecl GhcPs]) }+        :  '{'            cvtopdecls0 '}'      { ((epTok $1 ,epTok $3),$2) }+        |      vocurly    cvtopdecls0 close    { ((NoEpTok, NoEpTok),$2) }++cvtopdecls0 :: { [LHsDecl GhcPs] }+        : topdecls_semi         { cvTopDecls $1 }+        | topdecls              { cvTopDecls $1 }++-----------------------------------------------------------------------------+-- Tuple expressions++-- "texp" is short for tuple expressions:+-- things that can appear unparenthesized as long as they're+-- inside parens or delimited by commas+texp :: { ECP }+        : exp2               { $1 }++        -- Note [Parsing sections]+        -- ~~~~~~~~~~~~~~~~~~~~~~~+        -- We include left and right sections here, which isn't+        -- technically right according to the Haskell standard.+        -- For example (3 +, True) isn't legal.+        -- However, we want to parse bang patterns like+        --      (!x, !y)+        -- and it's convenient to do so here as a section+        -- Then when converting expr to pattern we unravel it again+        -- Meanwhile, the renamer checks that real sections appear+        -- inside parens.+        | infixexp qop+                             {% runPV (unECP $1) >>= \ $1 ->+                                runPV (rejectPragmaPV $1) >>+                                runPV $2 >>= \ $2 ->+                                return $ ecpFromExp $+                                sLLa $1 $> $ SectionL noExtField $1 (n2l $2) }+        | qopm infixexp      { ECP $+                                superInfixOp $+                                unECP $2 >>= \ $2 ->+                                $1 >>= \ $1 ->+                                mkHsSectionR_PV (comb2 $1 $>) (n2l $1) $2 }++orpats(EXP) :: { Located (NonEmpty (LPat GhcPs)) }+        -- See Note [%shift: orpats -> exp]+        : EXP %shift            {% do+                                    { pat <- (checkPattern <=< runPV) (unECP $1)+                                    ; return (sL1 pat (NE.singleton pat)) }}+        | EXP ';' orpats(EXP)   {% do+                                    { pat <- (checkPattern <=< runPV) (unECP $1)+                                    ; pat <- addTrailingSemiA pat (epTok $2)+                                    ; return (sLL pat $> (pat NE.<| unLoc $3)) }}++-- Always at least one comma or bar.+-- Though this can parse just commas (without any expressions), it won't+-- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]+-- in GHC.Hs.Expr.+tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }+           : texp commas_tup_tail+                           { unECP $1 >>= \ $1 ->+                             $2 >>= \ $2 ->+                             do { t <- amsA $1 [AddCommaAnn (EpTok $ srcSpan2e $ fst $2)]+                                ; return (Tuple (Right t : snd $2)) } }+           | commas tup_tail+                 { $2 >>= \ $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)) }++           | bars texp bars0+                { unECP $2 >>= \ $2 -> return $+                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) }++-- Always starts with commas; always follows an expr+commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)]) }+commas_tup_tail : commas tup_tail+        { $2 >>= \ $2 ->+          do { let {cos = map (\l -> (Left (EpAnn (spanAsAnchor l) True emptyComments))) (tail $ fst $1) }+             ; return ((head $ fst $1, cos ++ $2)) } }++-- Always follows a comma+tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] }+          : texp commas_tup_tail { unECP $1 >>= \ $1 ->+                                   $2 >>= \ $2 ->+                                   do { t <- amsA $1 [AddCommaAnn (EpTok $ srcSpan2e $ fst $2)]+                                      ; return (Right t : snd $2) } }+          | texp                 { unECP $1 >>= \ $1 ->+                                   return [Right $1] }+          -- See Note [%shift: tup_tail -> {- empty -}]+          | {- empty -} %shift   { return [Left noAnn] }++-----------------------------------------------------------------------------+-- List expressions++-- The rules below are little bit contorted to keep lexps left-recursive while+-- avoiding another shift/reduce-conflict.+-- Never empty.+list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) }+        : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->+                            mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []) }+        | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->+                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []) }+        | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->+                                  amsA' (L loc $ ArithSeq  (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1))+                                      >>= ecpFromExp' }+        | texp ',' exp2 '..' { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) (Just (epTok $2)) (epTok $4) (EpTok ac)) Nothing (FromThen $1 $3))+                                       >>= ecpFromExp' }+        | texp '..' exp2  { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (FromTo $1 $3))+                                       >>= ecpFromExp' }+        | texp ',' exp2 '..' exp2 { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   unECP $5 >>= \ $5 ->+                                   amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) (Just (epTok $2)) (epTok $4) (EpTok ac)) Nothing (FromThenTo $1 $3 $5))+                                       >>= ecpFromExp' }+        | texp '|' flattenedpquals+             { \loc (ao,ac) ->+                checkMonadComp >>= \ ctxt ->+                unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2)+                ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []))+                    >>= ecpFromExp' } }++lexps :: { forall b. DisambECP b => PV [LocatedA b] }+        : lexps ',' texp           { $1 >>= \ $1 ->+                                     unECP $3 >>= \ $3 ->+                                     case $1 of+                                       (h:t) -> do+                                         h' <- addTrailingCommaA h (epTok $2)+                                         return (((:) $! $3) $! (h':t)) }+        | texp ',' texp             { unECP $1 >>= \ $1 ->+                                      unECP $3 >>= \ $3 ->+                                      do { h <- addTrailingCommaA $1 (epTok $2)+                                         ; return [$3,h] }}++-----------------------------------------------------------------------------+-- List Comprehensions++flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : 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++                    qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |+                                            qs <- qss]+                                            noExpr noSyntaxExpr]+                    -- We actually found some actual parallel lists so+                    -- we wrap them into as a ParStmt+                }++pquals :: { Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)]) }+    : squals '|' pquals+                     {% case unLoc $1 of+                          h:|t -> do+                            h' <- addTrailingVbarA h (epTok $2)+                            return (sLL $1 $> (reverse (h':t) NE.<| unLoc $3)) }+    | squals         { L (getLoc $1) (NE.singleton (reverse (toList (unLoc $1)))) }++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' <- addTrailingCommaA h (epTok $2)+                    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' <- addTrailingCommaA h (epTok $2)+                    return (sLL $1 $> ($3 :| (h':t))) }+    | transformqual        { sLL $1 $> (NE.singleton (L (getLocAnn $1) ((unLoc $1) []))) }+    | qual                               {% runPV $1 >>= \ $1 ->+                                            return $ sL1 $1 (NE.singleton $1) }+--  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }+--  | '{|' pquals '|}'                       { sL1 $1 [$2] }++-- It is possible to enable bracketing (associating) qualifier lists+-- by uncommenting the lines with {| |} above. Due to a lack of+-- consensus on the syntax, this feature is not being used until we+-- get user demand.++transformqual :: { Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }+                        -- Function is applied to a list of stmts *in order*+    : 'then' exp              {% runPV (unECP $2) >>= \ $2 ->+                                 return (+                                 sLL $1 $> (\ss -> (mkTransformStmt (AnnTransStmt (epTok $1) noAnn noAnn noAnn) ss $2))) }+    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->+                                 runPV (unECP $4) >>= \ $4 ->+                                 return (sLL $1 $> (\ss -> (mkTransformByStmt (AnnTransStmt (epTok $1) noAnn (Just (epTok $3)) noAnn) ss $2 $4))) }+    | 'then' 'group' 'using' exp+            {% runPV (unECP $4) >>= \ $4 ->+               return (sLL $1 $> (\ss -> (mkGroupUsingStmt (AnnTransStmt (epTok $1) (Just (epTok $2)) noAnn (Just (epTok $3))) ss $4))) }++    | 'then' 'group' 'by' exp 'using' exp+            {% runPV (unECP $4) >>= \ $4 ->+               runPV (unECP $6) >>= \ $6 ->+               return (sLL $1 $> (\ss -> (mkGroupByUsingStmt (AnnTransStmt (epTok $1) (Just (epTok $2)) (Just (epTok $3)) (Just (epTok $5))) ss $4 $6))) }++-- Note that 'group' is a special_id, which means that you can enable+-- TransformListComp while still using Data.List.group. However, this+-- introduces a shift/reduce conflict. Happy chooses to resolve the conflict+-- in by choosing the "group by" variant, which is what we want.++-----------------------------------------------------------------------------+-- Guards++guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }++guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->+                               case unLoc $1 of+                                 (h:t) -> do+                                   h' <- addTrailingCommaA h (epTok $2)+                                   return (sLL $1 $> ($3 : (h':t))) }+    | qual                  {% runPV $1 >>= \ $1 ->+                               return $ sL1 $1 [$1] }++-----------------------------------------------------------------------------+-- Case alternatives++altslist(PATS) :: { forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)]) }+        : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsr+                                           (sLL $1 $> (reverse (snd $ unLoc $2)))+                                           (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2) noAnn []) }+        | vocurly    alts(PATS)  close { $2 >>= \ $2 -> amsr+                                           (L (getLoc $2) (reverse (snd $ unLoc $2)))+                                           (AnnList (Just $ glR $2) ListNone (fst $ unLoc $2) noAnn []) }+        | '{'              '}'   { amsr (sLL $1 $> []) (AnnList Nothing (ListBraces (epTok $1) (epTok $2)) [] noAnn []) }+        | vocurly          close { return $ noLocA [] }++alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) }+        : alts1(PATS)              { $1 >>= \ $1 -> return $+                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+        | ';' alts(PATS)           { $2 >>= \ $2 -> return $+                                     sLL $1 $> (((mzEpTok $1) : (fst $ unLoc $2) )+                                               ,snd $ unLoc $2) }++alts1(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) }+        : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 ->+                                        $3 >>= \ $3 ->+                                          case snd $ unLoc $1 of+                                            [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]+                                                                            ,[$3]))+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (epTok $2)+                                              return (sLL $1 $> (fst $ unLoc $1,$3 : h' : t)) }+        | alts1(PATS) ';'           {  $1 >>= \ $1 ->+                                         case snd $ unLoc $1 of+                                           [] -> return (sLZ $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2]+                                                                           ,[]))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (epTok $2)+                                             return (sLZ $1 $> (fst $ unLoc $1, h' : t)) }+        | alt(PATS)                 { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) }++alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }+        : PATS alt_rhs { $2 >>= \ $2 ->+                         amsA' (sLLAsl $1 $>+                                         (Match { m_ext = noExtField+                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing+                                                , m_pats = L (listLocation $1) $1+                                                , m_grhss = unLoc $2 }))}++alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }+        : ralt wherebinds           { $1 >>= \alt ->+                                      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 (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 (NE.reverse (unLoc gdpats)) }++gdpats :: { forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b)))) }+        : gdpats gdpat { $1 >>= \gdpats ->+                         $2 >>= \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 "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) }+         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->+                                             return $ sLL $1 $> ((epTok $1,epTok $3),unLoc $2)  }+         |     gdpats close               {% runPV $1 >>= \ $1 ->+                                             return $ sL1 $1 ((NoEpTok, NoEpTok),unLoc $1) }++gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }+        : '|' guardquals '->' exp+                                   { unECP $4 >>= \ $4 ->+                                     acsA (comb2 $1 $>) (\loc cs -> sL loc $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ epTok $1) (Right $ epUniTok $3)) cs) (unLoc $2) $4) }++-- 'pat' recognises a pattern, including one with a bang at the top+--      e.g.  "!x" or "!(x,y)" or "C a b" etc+-- Bangs inside are parsed as infix operator applications, so that+-- we parse them right when bang-patterns are off++pat_syn_pat :: { LPat GhcPs }+pat_syn_pat :  exp          {% (checkPattern <=< runPV) (unECP $1) }++pat     :: { LPat GhcPs }+pat     :  orpats(exp)      {% case unLoc $1 of+                                pat :| [] -> return pat+                                pats      -> hintOrPats (sL1a $1 (OrPat NoExtField pats)) }+++-- 'pats1' does the same thing as 'pat', but returns it as a singleton+-- list so that it can be used with a parameterized production rule+--+-- It is used only for parsing patterns in `\case` and `case of`+pats1   :: { [LPat GhcPs] }+pats1   : pat { [ $1 ] }++bindpat :: { LPat GhcPs }+bindpat :  exp            {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess+                             checkPattern_details incompleteDoBlock+                                              (unECP $1) }++argpat   :: { LPat GhcPs }+argpat    : apat                  { $1 }+          | PREFIX_AT atype       { sLLa $1 $> (InvisPat (epTok $1, SpecifiedSpec) (mkHsTyPat $2)) }++argpats :: { [LPat GhcPs] }+          : argpat argpats            { $1 : $2 }+          | {- empty -}               { [] }+++apat   :: { LPat GhcPs }+apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }++-----------------------------------------------------------------------------+-- Statement sequences++stmtlist :: { forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))]) }+        : '{'           stmts '}'       { $2 >>= \ $2 ->+                                          amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) noAnn []) }+        |     vocurly   stmts close     { $2 >>= \ $2 -> amsr+                                          (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) ListNone (fromOL $ fst $ unLoc $2) noAnn []) }++--      do { ;; s ; s ; ; s ;; }+-- The last Stmt should be an expression, but that's hard to enforce+-- here, because we need too much lookahead if we see do { e ; }+-- So we use BodyStmts throughout, and switch the last one over+-- in ParseUtils.checkDo instead++stmts :: { forall b. DisambECP b => PV (Located (OrdList (EpToken ";"),[LStmt GhcPs (LocatedA b)])) }+        : stmts ';' stmt  { $1 >>= \ $1 ->+                            $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->+                            case (snd $ unLoc $1) of+                              [] -> return (sLL $1 $> ( (fst $ unLoc $1) `snocOL` (epTok $2)+                                                      , $3 : (snd $ unLoc $1)))+                              (h:t) -> do+                               { h' <- addTrailingSemiA h (epTok $2)+                               ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(h':t)) }}++        | stmts ';'     {  $1 >>= \ $1 ->+                           case (snd $ unLoc $1) of+                             [] -> return (sLZ $1 $> ((fst $ unLoc $1) `snocOL` (epTok $2),snd $ unLoc $1))+                             (h:t) -> do+                               { h' <- addTrailingSemiA h (epTok $2)+                               ; return $ sLZ $1 $> (fst $ unLoc $1,h':t) }}+        | stmt                   { $1 >>= \ $1 ->+                                   return $ sL1 $1 (nilOL,[$1]) }+        | {- empty -}            { return $ noLoc (nilOL,[]) }+++-- For typing stmts at the GHCi prompt, where+-- the input may consist of just comments.+maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }+        : stmt                          {% fmap Just (runPV $1) }+        | {- nothing -}                 { Nothing }++-- For GHC API.+e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }+        : stmt                          {% runPV $1 }++stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }+        : qual                          { $1 }+        | 'rec' stmtlist                {  $2 >>= \ $2 ->+                                           amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) $2) $2) }++qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }+    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->+                                           amsA' (sLL $1 $> $ mkPsBindStmt (epUniTok $2) $1 $3) }+    | exp                                { unECP $1 >>= \ $1 ->+                                           return $ sL1a $1 $ mkBodyStmt $1 }+    | 'let' binds                        { amsA' (sLL $1 $> $ mkLetStmt (epTok $1) (unLoc $2)) }++-----------------------------------------------------------------------------+-- Record Field Update/Construction++fbinds  :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }+        : fbinds1                       { $1 }+        | {- empty -}                   { return ([], Nothing) }++fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }+        : fbind ',' fbinds1+                 { $1 >>= \ $1 ->+                   $3 >>= \ $3 -> do+                   h <- addTrailingCommaFBind $1 (epTok $2)+                   return (case $3 of (flds, dd) -> (h : flds, dd)) }+        | fbind                         { $1 >>= \ $1 ->+                                          return ([$1], Nothing) }+        | '..'                          { return ([],   Just (getLoc $1)) }++fbind   :: { forall b. DisambECP b => PV (Fbind b) }+        : qvar '=' texp  { unECP $3 >>= \ $3 ->+                           fmap Left $ amsA' (sLL $1 $> $ HsFieldBind (Just (epTok $2)) (sL1a $1 $ mkFieldOcc $1) $3 False) }+                        -- RHS is a 'texp', allowing view patterns (#6038)+                        -- and, incidentally, sections.  Eg+                        -- f (R { x = show -> s }) = ...++        | qvar          { placeHolderPunRhs >>= \rhs ->+                          fmap Left $ amsA' (sL1 $1 $ HsFieldBind Nothing (sL1a $1 $ mkFieldOcc $1) rhs True) }+                        -- In the punning case, use a place-holder+                        -- The renamer fills in the final value++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        -- AZ: need to pull out the let block into a helper+        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp+                        { do+                            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+                                final = last fields+                                l = comb2 $1 $3+                                isPun = False+                            $5 <- unECP $5+                            fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun+                                            (Just (epTok $4))+                        }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        -- AZ: need to pull out the let block into a helper+        | field TIGHT_INFIX_PROJ fieldToUpdate+                        { do+                            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+                                final = last fields+                                l = comb2 $1 $3+                                isPun = True+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))+                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun Nothing+                        }++fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }+fieldToUpdate+        -- See Note [Whitespace-sensitive operator parsing] in Lexer.x+        : fieldToUpdate TIGHT_INFIX_PROJ field   { sLL $1 $> ((sLLa $2 $> (DotFieldOcc (AnnFieldLabel $ Just $ epTok $2) $3)) : unLoc $1) }+        | field       { sL1 $1 [sL1a $1 (DotFieldOcc (AnnFieldLabel Nothing) $1)] }++-----------------------------------------------------------------------------+-- Implicit Parameter Bindings++dbinds  :: { Located [LIPBind GhcPs] } -- reversed+        : dbinds ';' dbind+                      {% case unLoc $1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (epTok $2)+                             return (let { this = $3; rest = h':t }+                                in rest `seq` this `seq` sLL $1 $> (this : rest)) }+        | dbinds ';'  {% case unLoc $1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (epTok $2)+                             return (sLZ $1 $> (h':t)) }+        | dbind                        { let this = $1 in this `seq` (sL1 $1 [this]) }+--      | {- empty -}                  { [] }++dbind   :: { LIPBind GhcPs }+dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->+                                          amsA' (sLL $1 $> (IPBind (epTok $2) (reLoc $1) $3)) }++ipvar   :: { Located HsIPName }+        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }++-----------------------------------------------------------------------------+-- Overloaded labels++overloaded_label :: { Located (SourceText, FastString) }+        : LABELVARID          { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) }++-----------------------------------------------------------------------------+-- Warnings and deprecations++name_boolformula_opt :: { LBooleanFormula GhcPs }+        : name_boolformula          { $1 }+        | {- empty -}               { noLocA mkTrue }++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 GhcPs }+        : name_boolformula_and_list+                  { sLLa (head $1) (last $1) (And (toList $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 NE.<| $3) } }++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) }++namelist :: { Located [LocatedN RdrName] }+namelist : name_var              { sL1 $1 [$1] }+         | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)+                                       ; return (sLL $1 $> (h : unLoc $3)) }}++name_var :: { LocatedN RdrName }+name_var : var { $1 }+         | con { $1 }++-----------------------------------------+-- Data constructors+-- There are two different productions here as lifted list constructors+-- are parsed differently.++qcon :: { LocatedN RdrName }+  : gen_qcon              { $1 }+  | syscon                { $1 }++gen_qcon :: { LocatedN RdrName }+  : qconid                { $1 }+  | '(' qconsym ')'       {% amsr (sLL $1 $> (unLoc $2))+                                  (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }++con     :: { LocatedN RdrName }+        : conid                 { $1 }+        | '(' consym ')'        {% amsr (sLL $1 $> (unLoc $2))+                                        (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }+        | syscon                { $1 }++con_list :: { Located (NonEmpty (LocatedN RdrName)) }+con_list : con                  { sL1 $1 (pure $1) }+         | con ',' con_list     {% sLL $1 $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) }++qcon_list :: { [LocatedN RdrName] }+qcon_list : qcon                  { [$1] }+          | qcon ',' qcon_list    {% do { h <- addTrailingCommaN $1 (gl $2)+                                        ; return (h : $3) }}++-- 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) (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) (toList $ fst $2)) []) }++syscon :: { LocatedN RdrName }+        : sysdcon               {  L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }+        | '(' '->' ')'          {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                        (NameAnnRArrow  (Just $ epTok $1) (epUniTok $2) (Just $ epTok $3) []) }++-- See Note [Empty lists] in GHC.Hs.Expr+sysdcon :: { LocatedN DataCon }+        : sysdcon_nolist                 { $1 }+        | '(' ')'               {% amsr (sLL $1 $> unitDataCon) (NameAnnOnly (NameParens (epTok $1) (epTok $2)) []) }+        | '[' ']'               {% amsr (sLL $1 $> nilDataCon)  (NameAnnOnly (NameSquare (epTok $1) (epTok $2)) []) }++conop :: { LocatedN RdrName }+        : consym                { $1 }+        | '`' conid '`'         {% amsr (sLL $1 $> (unLoc $2))+                                          (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++qconop :: { LocatedN RdrName }+        : qconsym               { $1 }+        | '`' qconid '`'        {% amsr (sLL $1 $> (unLoc $2))+                                          (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++----------------------------------------------------------------------------+-- Type constructors+++-- See Note [Unit tuples] in GHC.Hs.Type for the distinction+-- between gtycon and ntgtycon+gtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, including unit tuples+        : ntgtycon                     { $1 }+        | '(' ')'                      {% amsr (sLL $1 $> $ getRdrName unitTyCon)+                                                (NameAnnOnly (NameParens (epTok $1) (epTok $2)) []) }+        | '(#' '#)'                    {% amsr (sLL $1 $> $ getRdrName unboxedUnitTyCon)+                                                (NameAnnOnly (NameParensHash (epTok $1) (epTok $2)) []) }+        | '[' ']'               {% amsr (sLL $1 $> $ listTyCon_RDR)+                                      (NameAnnOnly (NameSquare (epTok $1) (epTok $2)) []) }++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) (toList $ fst $2)) []) }}+        | '(#' commas '#)'      {% do { n <- mkTupleSyntaxTycon Unboxed (snd $2 + 1)+                                      ; 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) (toList $ fst $2) []) } }+        | '(' '->' ')'          {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                       (NameAnnRArrow  (Just $ epTok $1) (epUniTok $2) (Just $ epTok $3) []) }++oqtycon :: { LocatedN RdrName }  -- An "ordinary" qualified tycon;+                                -- These can appear in export lists+        : qtycon                        { $1 }+        | '(' qtyconsym ')'             {% amsr (sLL $1 $> (unLoc $2))+                                                  (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }++oqtycon_no_varcon :: { LocatedN RdrName }  -- Type constructor which cannot be mistaken+                                          -- for variable constructor in export lists+                                          -- see Note [Type constructors in export list]+        :  qtycon            { $1 }+        | '(' QCONSYM ')'    {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }+                                in amsr (sLL $1 $> (unLoc name)) (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }+        | '(' CONSYM ')'     {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }+                                in amsr (sLL $1 $> (unLoc name)) (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }+        | '(' ':' ')'        {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! consDataCon_RDR }+                                in amsr (sLL $1 $> (unLoc name)) (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }++{- Note [Type constructors in export list]+~~~~~~~~~~~~~~~~~~~~~+Mixing type constructors and data constructors in export lists introduces+ambiguity in grammar: e.g. (*) may be both a type constructor and a function.++-XExplicitNamespaces allows to disambiguate by explicitly prefixing type+constructors with 'type' keyword.++This ambiguity causes reduce/reduce conflicts in parser, which are always+resolved in favour of data constructors. To get rid of conflicts we demand+that ambiguous type constructors (those, which are formed by the same+productions as variable constructors) are always prefixed with 'type' keyword.+Unambiguous type constructors may occur both with or without 'type' keyword.++Note that in the parser we still parse data constructors as type+constructors. As such, they still end up in the type constructor namespace+until after renaming when we resolve the proper namespace for each exported+child.+-}++qtyconop :: { LocatedN RdrName } -- Qualified or unqualified+        -- See Note [%shift: qtyconop -> qtyconsym]+        : qtyconsym %shift              { $1 }+        | '`' qtycon '`'                {% amsr (sLL $1 $> (unLoc $2))+                                                (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++qtycon :: { LocatedN RdrName }   -- Qualified or unqualified+        : QCONID            { sL1n $1 $! mkQual tcClsName (getQCONID $1) }+        | tycon             { $1 }++tycon   :: { LocatedN RdrName }  -- Unqualified+        : CONID                   { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }++qtyconsym :: { LocatedN RdrName }+        : QCONSYM            { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }+        | QVARSYM            { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }+        | tyconsym           { $1 }++tyconsym :: { LocatedN RdrName }+        : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }+        | VARSYM                { sL1n $1 $! mkUnqual tcClsName (getVARSYM $1) }+        | ':'                   { sL1n $1 $! consDataCon_RDR }+        | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }+        | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }++-- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.+-- These can appear in `ANN type` declarations (#19374).+otycon :: { LocatedN RdrName }+        : tycon                 { $1 }+        | '(' tyconsym ')'      {% amsr (sLL $1 $> (unLoc $2))+                                        (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }++-----------------------------------------------------------------------------+-- Operators++op      :: { LocatedN RdrName }   -- used in infix decls+        : varop                 { $1 }+        | conop                 { $1 }+        | '->'                  {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                     (NameAnnRArrow  Nothing (epUniTok $1) Nothing []) }++varop   :: { LocatedN RdrName }+        : varsym                { $1 }+        | '`' varid '`'         {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++qop     :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections+        : qvarop                { mkHsVarOpPV $1 }+        | qconop                { mkHsConOpPV $1 }+        | hole_op               { mkHsInfixHolePV $1 }++qopm    :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections+        : qvaropm               { mkHsVarOpPV $1 }+        | qconop                { mkHsConOpPV $1 }+        | hole_op               { mkHsInfixHolePV $1 }++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 }+        | '`' qvarid '`'        {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++qvaropm :: { LocatedN RdrName }+        : qvarsym_no_minus      { $1 }+        | '`' qvarid '`'        {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++-----------------------------------------------------------------------------+-- Type variables++tyvar   :: { LocatedN RdrName }+tyvar   : tyvarid               { $1 }++tyvarop :: { LocatedN RdrName }+tyvarop : '`' tyvarid '`'       {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn (NameBackquotes (epTok $1) (epTok $3)) (glR $2) []) }++tyvarid :: { LocatedN RdrName }+        : VARID            { sL1n $1 $! mkUnqual tvName (getVARID $1) }+        | special_id       { sL1n $1 $! mkUnqual tvName (unLoc $1) }+        | 'unsafe'         { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }+        | 'safe'           { sL1n $1 $! mkUnqual tvName (fsLit "safe") }+        | 'interruptible'  { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }+        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'+        -- in GHC.Parser.PostProcess+        -- See Note [Parsing explicit foralls in Rules]++-----------------------------------------------------------------------------+-- Variables++var     :: { LocatedN RdrName }+        : varid                 { $1 }+        | '(' varsym ')'        {% amsr (sLL $1 $> (unLoc $2))+                                   (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }++qvar    :: { LocatedN RdrName }+        : qvarid                { $1 }+        | '(' varsym ')'        {% amsr (sLL $1 $> (unLoc $2))+                                   (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }+        | '(' qvarsym1 ')'      {% amsr (sLL $1 $> (unLoc $2))+                                   (NameAnn (NameParens (epTok $1) (epTok $3)) (glR $2) []) }+-- We've inlined qvarsym here so that the decision about+-- whether it's a qvar or a var can be postponed until+-- *after* we see the close paren.++field :: { LocatedN FieldLabelString  }+      : varid { fmap (FieldLabelString . occNameFS . rdrNameOcc) $1 }++qvarid :: { LocatedN RdrName }+        : varid               { $1 }+        | QVARID              { sL1n $1 $! mkQual varName (getQVARID $1) }++-- Note that 'role' and 'family' get lexed separately regardless of+-- the use of extensions. However, because they are listed here,+-- this is OK and they can be used as normal varids.+-- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer+varid :: { LocatedN RdrName }+        : VARID            { sL1n $1 $! mkUnqual varName (getVARID $1) }+        | special_id       { sL1n $1 $! mkUnqual varName (unLoc $1) }+        | 'unsafe'         { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }+        | 'safe'           { sL1n $1 $! mkUnqual varName (fsLit "safe") }+        | 'interruptible'  { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}+        | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }+        | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }+        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'+        -- in GHC.Parser.PostProcess+        -- See Note [Parsing explicit foralls in Rules]++qvarsym :: { LocatedN RdrName }+        : varsym                { $1 }+        | qvarsym1              { $1 }++qvarsym_no_minus :: { LocatedN RdrName }+        : varsym_no_minus       { $1 }+        | qvarsym1              { $1 }++qvarsym1 :: { LocatedN RdrName }+qvarsym1 : QVARSYM              { sL1n $1 $ mkQual varName (getQVARSYM $1) }++varsym :: { LocatedN RdrName }+        : varsym_no_minus       { $1 }+        | '-'                   { sL1n $1 $ mkUnqual varName (fsLit "-") }++varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'+        : VARSYM               { sL1n $1 $ mkUnqual varName (getVARSYM $1) }+        | special_sym          { sL1n $1 $ mkUnqual varName (unLoc $1) }+++-- These special_ids are treated as keywords in various places,+-- but as ordinary ids elsewhere.   'special_id' collects all these+-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and+-- 'anyclass', whose treatment differs depending on context+special_id :: { Located FastString }+special_id+        : 'as'                  { sL1 $1 (fsLit "as") }+        | 'qualified'           { sL1 $1 (fsLit "qualified") }+        | 'hiding'              { sL1 $1 (fsLit "hiding") }+        | 'export'              { sL1 $1 (fsLit "export") }+        | 'label'               { sL1 $1 (fsLit "label")  }+        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }+        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }+        | 'ccall'               { sL1 $1 (fsLit "ccall") }+        | 'capi'                { sL1 $1 (fsLit "capi") }+        | 'prim'                { sL1 $1 (fsLit "prim") }+        | 'javascript'          { sL1 $1 (fsLit "javascript") }+        -- See Note [%shift: special_id -> 'group']+        | 'group' %shift        { sL1 $1 (fsLit "group") }+        | 'stock'               { sL1 $1 (fsLit "stock") }+        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }+        | 'via'                 { sL1 $1 (fsLit "via") }+        | '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)) }++-----------------------------------------------------------------------------+-- Data constructors++qconid :: { LocatedN RdrName }   -- Qualified or unqualified+        : conid              { $1 }+        | QCONID             { sL1n $1 $! mkQual dataName (getQCONID $1) }++conid   :: { LocatedN RdrName }+        : CONID                { sL1n $1 $ mkUnqual dataName (getCONID $1) }++qconsym :: { LocatedN RdrName }  -- Qualified or unqualified+        : consym               { $1 }+        | QCONSYM              { sL1n $1 $ mkQual dataName (getQCONSYM $1) }++consym :: { LocatedN RdrName }+        : CONSYM              { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }++        -- ':' means only list cons+        | ':'                { sL1n $1 $ consDataCon_RDR }+++-----------------------------------------------------------------------------+-- Literals++literal :: { Located (HsLit GhcPs) }+        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }+        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)+                                                    $ getSTRING $1 }+        | STRING_MULTI      { sL1 $1 $ HsMultilineString (getSTRINGMULTIs $1)+                                                    $ getSTRINGMULTI $1 }+        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)+                                                    $ getPRIMINTEGER $1 }+        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)+                                                    $ getPRIMWORD $1 }+        | PRIMINTEGER8      { sL1 $1 $ HsInt8Prim   (getPRIMINTEGER8s $1)+                                                    $ getPRIMINTEGER8 $1 }+        | PRIMINTEGER16     { sL1 $1 $ HsInt16Prim  (getPRIMINTEGER16s $1)+                                                    $ getPRIMINTEGER16 $1 }+        | PRIMINTEGER32     { sL1 $1 $ HsInt32Prim  (getPRIMINTEGER32s $1)+                                                    $ getPRIMINTEGER32 $1 }+        | PRIMINTEGER64     { sL1 $1 $ HsInt64Prim  (getPRIMINTEGER64s $1)+                                                    $ getPRIMINTEGER64 $1 }+        | PRIMWORD8         { sL1 $1 $ HsWord8Prim  (getPRIMWORD8s $1)+                                                    $ getPRIMWORD8 $1 }+        | PRIMWORD16        { sL1 $1 $ HsWord16Prim (getPRIMWORD16s $1)+                                                    $ getPRIMWORD16 $1 }+        | PRIMWORD32        { sL1 $1 $ HsWord32Prim (getPRIMWORD32s $1)+                                                    $ getPRIMWORD32 $1 }+        | PRIMWORD64        { sL1 $1 $ HsWord64Prim (getPRIMWORD64s $1)+                                                    $ getPRIMWORD64 $1 }+        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)+                                                    $ getPRIMCHAR $1 }+        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)+                                                    $ getPRIMSTRING $1 }+        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }+        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }++-----------------------------------------------------------------------------+-- Layout++{- Note [Layout and error]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The Haskell 2010 report (Section 10.3, Note 5) dictates the use of the error+token in `close`. To recall why that is necessary, consider++  f x = case x of+    True -> False+    where y = x+1++The virtual pass L inserts vocurly, semi, vccurly to return a laid-out+token stream. It must insert a vccurly before `where` to close the layout+block introduced by `of`.+But there is no good way to do so other than L becoming aware of the grammar!+Thus, L is specified to detect the ensuing parse error (implemented via+happy's `error` token) and then insert the vccurly.+Thus in effect, L is distributed between Lexer.x and Parser.y.++There are a bunch of other, less "tricky" examples:++  let x = x {- vccurly -} in x   -- could just track bracketing of+                                 -- let..in on layout stack to fix+  (case x of+   True -> False {- vccurly -})  -- ditto for surrounding delimiters such as ()++  data T = T;{- vccurly -}       -- Need insert vccurly at EOF++Many of these are not that hard to fix, but still tedious and prone to break+when the grammar changes; but the `of`/`where` example is especially gnarly,+because it demonstrates a grammatical interaction between two lexically+unrelated tokens.+-}+close :: { () }+        : vccurly               { () } -- context popped in lexer.+        | error                 {% popContext } -- See Note [Layout and error]++-----------------------------------------------------------------------------+-- Miscellaneous (mostly renamings)++modid   :: { LocatedA ModuleName }+        : CONID                 { sL1a $1 $ mkModuleNameFS (getCONID $1) }+        | QCONID                { sL1a $1 $ let (mod,c) = getQCONID $1 in+                                  mkModuleNameFS+                                   (concatFS [mod, fsLit ".", c])+                                }++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 }+        |                        { ([], 0) }++bars :: { ([EpToken "|"],Int) }     -- One or more bars+        : bars '|'               { ((fst $1)++[epTok $2],snd $1 + 1) }+        | '|'                    { ([epTok $1],1) }++{+happyError :: P a+happyError = srcParseFail++getVARID          (L _ (ITvarid    x)) = x+getCONID          (L _ (ITconid    x)) = x+getVARSYM         (L _ (ITvarsym   x)) = x+getCONSYM         (L _ (ITconsym   x)) = x+getDO             (L _ (ITdo      x)) = x+getMDO            (L _ (ITmdo     x)) = x+getQVARID         (L _ (ITqvarid   x)) = x+getQCONID         (L _ (ITqconid   x)) = x+getQVARSYM        (L _ (ITqvarsym  x)) = x+getQCONSYM        (L _ (ITqconsym  x)) = x+getIPDUPVARID     (L _ (ITdupipvarid   x)) = x+getLABELVARID     (L _ (ITlabelvarid _ x)) = x+getCHAR           (L _ (ITchar   _ x)) = x+getSTRING         (L _ (ITstring _ x)) = x+getSTRINGMULTI    (L _ (ITstringMulti _ x)) = x+getINTEGER        (L _ (ITinteger x))  = x+getRATIONAL       (L _ (ITrational x)) = x+getPRIMCHAR       (L _ (ITprimchar _ x)) = x+getPRIMSTRING     (L _ (ITprimstring _ x)) = x+getPRIMINTEGER    (L _ (ITprimint  _ x)) = x+getPRIMWORD       (L _ (ITprimword _ x)) = x+getPRIMINTEGER8   (L _ (ITprimint8 _ x)) = x+getPRIMINTEGER16  (L _ (ITprimint16 _ x)) = x+getPRIMINTEGER32  (L _ (ITprimint32 _ x)) = x+getPRIMINTEGER64  (L _ (ITprimint64 _ x)) = x+getPRIMWORD8      (L _ (ITprimword8 _ x)) = x+getPRIMWORD16     (L _ (ITprimword16 _ x)) = x+getPRIMWORD32     (L _ (ITprimword32 _ x)) = x+getPRIMWORD64     (L _ (ITprimword64 _ x)) = x+getPRIMFLOAT      (L _ (ITprimfloat x)) = x+getPRIMDOUBLE     (L _ (ITprimdouble x)) = x+getINLINE         (L _ (ITinline_prag _ inl conl)) = (inl,conl)+getSPEC_INLINE    (L _ (ITspec_inline_prag src True))  = (Inline src,FunLike)+getSPEC_INLINE    (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike)+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x+getVOCURLY        (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l++getINTEGERs       (L _ (ITinteger (IL src _ _))) = src+getCHARs          (L _ (ITchar       src _)) = src+getSTRINGs        (L _ (ITstring     src _)) = src+getSTRINGMULTIs   (L _ (ITstringMulti src _)) = src+getPRIMCHARs      (L _ (ITprimchar   src _)) = src+getPRIMSTRINGs    (L _ (ITprimstring src _)) = src+getPRIMINTEGERs   (L _ (ITprimint    src _)) = src+getPRIMWORDs      (L _ (ITprimword   src _)) = src+getPRIMINTEGER8s  (L _ (ITprimint8   src _)) = src+getPRIMINTEGER16s (L _ (ITprimint16  src _)) = src+getPRIMINTEGER32s (L _ (ITprimint32  src _)) = src+getPRIMINTEGER64s (L _ (ITprimint64  src _)) = src+getPRIMWORD8s     (L _ (ITprimword8  src _)) = src+getPRIMWORD16s    (L _ (ITprimword16 src _)) = src+getPRIMWORD32s    (L _ (ITprimword32 src _)) = src+getPRIMWORD64s    (L _ (ITprimword64 src _)) = src++getLABELVARIDs    (L _ (ITlabelvarid src _)) = src++-- See Note [Pragma source text] in "GHC.Types.SourceText" for the following+getINLINE_PRAGs       (L _ (ITinline_prag       _ inl _)) = inlineSpecSource inl+getOPAQUE_PRAGs       (L _ (ITopaque_prag       src))     = src+getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src+getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src+getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src+getRULES_PRAGs        (L _ (ITrules_prag        src)) = src+getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src+getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src+getSCC_PRAGs          (L _ (ITscc_prag          src)) = src+getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src+getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src+getANN_PRAGs          (L _ (ITann_prag          src)) = src+getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src+getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src+getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src+getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src+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+isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax+isUnicode (L _ ITlolly)               = True+isUnicode _                           = False++hasE :: Located Token -> Bool+hasE (L _ (ITopenExpQuote HasE _)) = True+hasE (L _ (ITopenTExpQuote HasE))  = True+hasE _                             = False++getSCC :: Located Token -> P FastString+getSCC lt = do let s = getSTRING lt+               -- We probably actually want to be more restrictive than this+               if ' ' `elem` unpackFS s+                   then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC+                   else return s++stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs)+stringLiteralToHsDocWst  sl = reLoc $ lexStringLiteral parseIdentifier sl++-- Utilities for combining source spans+comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan+comb2 !a !b = combineHasLocs a b++comb3 :: (HasLoc a, HasLoc b, HasLoc c) => a -> b -> c -> SrcSpan+comb3 !a !b !c = combineSrcSpans (getHasLoc a) (combineHasLocs b c)++comb4 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d) => a -> b -> c -> d -> SrcSpan+comb4 !a !b !c !d =+    combineSrcSpans (getHasLoc a) $+    combineSrcSpans (getHasLoc b) $+    combineSrcSpans (getHasLoc c) (getHasLoc d)++comb5 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e) => a -> b -> c -> d -> e -> SrcSpan+comb5 !a !b !c !d !e =+    combineSrcSpans (getHasLoc a) $+    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 #-}+sL :: l -> a -> GenLocated l a+sL !loc !a = L loc a++-- See Note [Adding location info] for how these utility functions are used++-- replaced last 3 CPP macros in this file+{-# INLINE sL0 #-}+sL0 :: a -> Located a+sL0 = L noSrcSpan       -- #define L0   L noSrcSpan++{-# INLINE sL1 #-}+sL1 :: HasLoc a => a -> b -> Located b+sL1 !x = sL (getHasLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1a #-}+sL1a :: (HasLoc a, HasAnnotation t) =>  a -> b -> GenLocated t b+sL1a !x = sL (noAnnSrcSpan $ getHasLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1n #-}+sL1n :: HasLoc a => a -> b -> LocatedN b+sL1n !x = L (noAnnSrcSpan $ getHasLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sLL #-}+sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c+sLL !x !y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLa #-}+sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c+sLLa !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLl #-}+sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c+sLLl !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLld #-}+sLLld :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedLW c+sLLld !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLAsl #-}+sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c+sLLAsl [] = sL1+sLLAsl (!x:_) = sLL x++{-# INLINE sLZ #-}+sLZ :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c+sLZ !x !y = if isZeroWidthSpan (getHasLoc y)+                 then sL (getHasLoc x)+                 else sL (comb2 x y)++{- Note [Adding location info]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~++This is done using the three functions below, sL0, sL1+and sLL.  Note that these functions were mechanically+converted from the three macros that used to exist before,+namely L0, L1 and LL.++They each add a SrcSpan to their argument.++   sL0  adds 'noSrcSpan', used for empty productions+     -- This doesn't seem to work anymore -=chak++   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan+        from that token.++   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from+        the first and last tokens.++These suffice for the majority of cases.  However, we must be+especially careful with empty productions: sLL won't work if the first+or last token on the lhs can represent an empty span.  In these cases,+we have to calculate the span using more of the tokens from the lhs, eg.++        | 'newtype' tycl_hdr '=' newconstr deriving+                { L (comb3 $1 $4 $5)+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }++We provide comb3 and comb4 functions which are useful in such cases.++Be careful: there's no checking that you actually got this right, the+only symptom will be that the SrcSpans of your syntax will be+incorrect.++-}++-- Make a source location for the file.  We're a bit lazy here and just+-- make a point SrcSpan at line 1, column 0.  Strictly speaking we should+-- try to find the span of the whole file (ToDo).+fileSrcSpan :: P SrcSpan+fileSrcSpan = do+  l <- getRealSrcLoc;+  let loc = mkSrcLoc (srcLocFile l) 1 1;+  return (mkSrcSpan loc loc)++-- Hint about linear types+hintLinear :: MonadP m => SrcSpan -> m ()+hintLinear span = do+  linearEnabled <- getBit LinearTypesBit+  unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction++-- Does this look like (a %m)?+looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool+looksLikeMult ty1 l_op ty2+  | Unqual op_name <- unLoc l_op+  , occNameFS op_name == fsLit "%"+  , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)+  , Strict.Just pct_pos <- getBufSpan (getLocA l_op)+  , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)+  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos+  , bufSpanEnd pct_pos == bufSpanStart ty2_pos+  = True+  | otherwise = False++-- Hint about or-patterns+hintOrPats :: MonadP m => LPat GhcPs -> m (LPat GhcPs)+hintOrPats pat = do+  orPatsEnabled <- getBit OrPatternsBit+  unless orPatsEnabled $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) $ PsErrIllegalOrPat pat+  return pat++-- Hint about the MultiWayIf extension+hintMultiWayIf :: SrcSpan -> P ()+hintMultiWayIf span = do+  mwiEnabled <- getBit MultiWayIfBit+  unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf++-- Hint about explicit-forall+hintExplicitForall :: Located Token -> P ()+hintExplicitForall tok = do+    explicit_forall_enabled <- getBit ExplicitForallBit+    in_rule_prag <- getBit InRulePragBit+    unless (explicit_forall_enabled || in_rule_prag) $+      addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+        PsErrExplicitForall (isUnicode tok)++-- Hint about qualified-do+hintQualifiedDo :: Located Token -> P ()+hintQualifiedDo tok = do+    qualifiedDo   <- getBit QualifiedDoBit+    case maybeQDoDoc of+      Just qdoDoc | not qualifiedDo ->+        addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+          (PsErrIllegalQualifiedDo qdoDoc)+      _ -> return ()+  where+    maybeQDoDoc = case unLoc tok of+      ITdo (Just m) -> Just $ ftext m <> text ".do"+      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"+      t -> Nothing++-- When two single quotes don't followed by tyvar or gtycon, we report the+-- error as empty character literal, or TH quote that missing proper type+-- variable or constructor. See #13450.+reportEmptyDoubleQuotes :: SrcSpan -> P a+reportEmptyDoubleQuotes span = do+    thQuotes <- getBit ThQuotesBit+    addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************++For the general principles of the following routines, see Note [exact print annotations]+in GHC.Parser.Annotation++-}++msemi :: Located Token -> [TrailingAnn]+msemi !l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (epTok l)]++msemiA :: Located Token -> [EpToken ";"]+msemiA !l = if isZeroWidthSpan (gl l) then [] else [epTok l]++msemim :: Located Token -> Maybe (EpToken ";")+msemim !l = if isZeroWidthSpan (gl l) then Nothing else Just (epTok l)++toUnicode :: Located Token -> IsUnicodeSyntax+toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax++-- -------------------------------------++gl :: GenLocated l a -> l+gl = getLoc++glA :: HasLoc a => a -> SrcSpan+glA = getHasLoc++glR :: HasLoc a => a -> EpaLocation+glR !la = EpaSpan (getHasLoc la)++glEE :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation+glEE !x !y = spanAsAnchor $ comb2 x y++glEEz :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation+glEEz !x !y = if isZeroWidthSpan (getHasLoc y)+                then spanAsAnchor (getHasLoc x)+                else spanAsAnchor $ comb2 x y++glRM :: Located a -> Maybe EpaLocation+glRM (L !l _) = Just $ spanAsAnchor l++n2l :: LocatedN a -> LocatedA a+n2l (L !la !a) = L (l2l la) a++-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.+acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)+acsFinal a = do+  let (L l _) = a emptyComments Nothing+  !cs <- getCommentsFor l+  csf <- getFinalCommentsFor l+  meof <- getEofPos+  let ce = case meof of+             Strict.Nothing  -> Nothing+             Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)+  return (a (cs Semi.<> csf) ce)++acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a)+acs !l a = do+  !cs <- getCommentsFor (locA l)+  return (a l cs)++acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a)+acsA !l a = do+  !cs <- getCommentsFor (locA l)+  return $ reLoc (a l cs)++ams1 :: MonadP m => Located a -> b -> m (LocatedA b)+ams1 (L l a) b = do+  !cs <- getCommentsFor l+  return (L (EpAnn (spanAsAnchor l) noAnn cs) b)++amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a)+amsA' (L l a) = do+  !cs <- getCommentsFor l+  return (L (EpAnn (spanAsAnchor l) noAnn cs) a)++amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)+amsA (L !l a) bs = do+  !cs <- getCommentsFor (locA l)+  return (L (addAnnsA l bs cs) a)++amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)+amsAl (L l a) loc bs = do+  !cs <- getCommentsFor loc+  return (L (addAnnsA l bs cs) a)++amsr :: MonadP m => Located a -> an -> m (LocatedAn an a)+amsr (L l a) an = do+  !cs <- getCommentsFor l+  return (L (EpAnn (spanAsAnchor l) an cs) a)++-- | Parse a Haskell module with Haddock comments. This is done in two steps:+--+-- * 'parseModuleNoHaddock' to build the AST+-- * 'addHaddockToModule' to insert Haddock comments into it+--+-- This and the signature module parser are the only parser entry points that+-- deal with Haddock comments. The other entry points ('parseDeclaration',+-- 'parseExpression', etc) do not insert them into the AST.+parseModule :: P (Located (HsModule GhcPs))+parseModule = parseModuleNoHaddock >>= addHaddockToModule++-- | Parse a Haskell signature module with Haddock comments. This is done in two+-- steps:+--+-- * 'parseSignatureNoHaddock' to build the AST+-- * 'addHaddockToModule' to insert Haddock comments into it+--+-- This and the module parser are the only parser entry points that deal with+-- Haddock comments. The other entry points ('parseDeclaration',+-- 'parseExpression', etc) do not insert them into the AST.+parseSignature :: P (Located (HsModule GhcPs))+parseSignature = parseSignatureNoHaddock >>= addHaddockToModule++commentsA :: (NoAnn ann) => SrcSpan -> EpAnnComments -> EpAnn ann+commentsA loc cs = EpAnn (EpaSpan loc) noAnn cs++spanWithComments :: (NoAnn ann, MonadP m) => SrcSpan -> m (EpAnn ann)+spanWithComments l = do+  !cs <- getCommentsFor l+  return (commentsA l cs)++-- | Instead of getting the *enclosed* comments, this includes the+-- *preceding* ones.  It is used at the top level to get comments+-- between top level declarations.+commentsPA :: (NoAnn ann) => LocatedAn ann a -> P (LocatedAn ann a)+commentsPA la@(L l a) = do+  !cs <- getPriorCommentsFor (getLocA la)+  return (L (addCommentsToEpAnn l cs) a)++hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec")+hsDoAnn tok (L ll _)+  = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok []++listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation+listAsAnchorM [] = Nothing+listAsAnchorM (L l _:_) =+  case locA l of+    RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll+    _                -> Nothing++epTok :: Located Token -> EpToken tok+epTok (L !l _) = EpTok (EpaSpan l)++epUniTok :: Located Token -> EpUniToken tok utok+epUniTok t@(L !l _) = EpUniTok (EpaSpan l) u+  where+    u = if isUnicode t then UnicodeSyntax else NormalSyntax++-- |Construct an EpToken from the location of the token, provided the span is not zero width+mzEpTok :: Located Token -> EpToken tok+mzEpTok !l = if isZeroWidthSpan (gl l) then NoEpTok else (epTok l)++epExplicitBraces :: Located Token -> Located Token -> EpLayout+epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2)++-- -------------------------------------++addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b)+addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)+addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)++addTrailingVbarA :: MonadP m => LocatedA a -> EpToken "|" -> m (LocatedA a)+addTrailingVbarA  la tok = addTrailingAnnA la tok AddVbarAnn++addTrailingSemiA :: MonadP m => LocatedA a -> EpToken ";" -> m (LocatedA a)+addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn++addTrailingCommaA :: MonadP m => LocatedA a -> EpToken "," -> m (LocatedA a)+addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn++addTrailingAnnA :: (MonadP m, HasLoc tok) => LocatedA a -> tok -> (tok -> TrailingAnn) -> m (LocatedA a)+addTrailingAnnA (L anns a) tok ta = do+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let+    anns' = if isZeroWidthSpan (getHasLoc tok)+              then anns+              else addTrailingAnnToA (ta tok) cs anns+  return (L anns' a)++-- -------------------------------------++addTrailingVbarL :: MonadP m => LocatedL a -> EpToken "|" -> m (LocatedL a)+addTrailingVbarL  la tok = addTrailingAnnL la (AddVbarAnn tok)++addTrailingCommaL :: MonadP m => LocatedL a -> EpToken "," -> m (LocatedL a)+addTrailingCommaL  la tok = addTrailingAnnL la (AddCommaAnn tok)++addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)+addTrailingAnnL (L anns a) ta = do+  !cs <- getCommentsFor (locA anns)+  let anns' = addTrailingAnnToL ta cs anns+  return (L anns' a)++-- -------------------------------------++-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation+addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)+addTrailingCommaN (L anns a) span = do+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let anns' = if isZeroWidthSpan span+                then anns+                else addTrailingCommaToN anns (srcSpan2e span)+  return (L anns' a)++addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral+addTrailingCommaS (L l sl) span+    = L (widenSpanL l [span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) })++-- -------------------------------------++addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a+addTrailingDarrowC (L (EpAnn lr (AnnContext _ o c) csc) a) lt cs =+  let+    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax+  in L (EpAnn lr (AnnContext (Just (epUniTok lt)) o c) (cs Semi.<> csc)) a++-- -------------------------------------++isUnicodeSyntax :: Located Token -> IsUnicodeSyntax+isUnicodeSyntax lt = if isUnicode lt then UnicodeSyntax else NormalSyntax++-- We need a location for the where binds, when computing the SrcSpan+-- for the AST element using them.  Where there is a span, we return+-- it, else noLoc, which is ignored in the comb2 call.+adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))+                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)+adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)+adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)++combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan+combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)++fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA+fromTrailingN (EpAnn anc ann cs)+    = EpAnn anc (AnnListItem (nann_trailing ann)) cs }
compiler/GHC/Parser/Annotation.hs view
@@ -1,1297 +1,1271 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}--module GHC.Parser.Annotation (-  -- * Core Exact Print Annotation types-  AnnKeywordId(..),-  EpaComment(..), EpaCommentTok(..),-  IsUnicodeSyntax(..),-  unicodeAnn,-  HasE(..),--  -- * In-tree Exact Print Annotations-  AddEpAnn(..),-  EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,-  TokenLocation(..),-  DeltaPos(..), deltaPos, getDeltaLine,--  EpAnn(..), Anchor(..), AnchorOperation(..),-  spanAsAnchor, realSpanAsAnchor,-  noAnn,--  -- ** Comments in Annotations--  EpAnnComments(..), LEpaComment, emptyComments,-  getFollowingComments, setFollowingComments, setPriorComments,-  EpAnnCO,--  -- ** Annotations in 'GenLocated'-  LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,-  SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,-  SrcSpanAnn'(..), SrcAnn,--  -- ** Annotation data types used in 'GenLocated'--  AnnListItem(..), AnnList(..),-  AnnParen(..), ParenType(..), parenTypeKws,-  AnnPragma(..),-  AnnContext(..),-  NameAnn(..), NameAdornment(..),-  NoEpAnns(..),-  AnnSortKey(..),--  -- ** Trailing annotations in lists-  TrailingAnn(..), trailingAnnToAddEpAnn,-  addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,--  -- ** Utilities for converting between different 'GenLocated' when-  -- ** we do not care about the annotations.-  la2na, na2la, n2l, l2n, l2l, la2la,-  reLoc, reLocA, reLocL, reLocC, reLocN,--  srcSpan2e, la2e, realSrcSpan,--  -- ** Building up annotations-  extraToAnnList, reAnn,-  reAnnL, reAnnC,-  addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorR, widenLocatedAn,--  -- ** Querying annotations-  getLocAnn,-  epAnnAnns, epAnnAnnsL,-  annParen2AddEpAnn,-  epAnnComments,--  -- ** Working with locations of annotations-  sortLocatedA,-  mapLocA,-  combineLocsA,-  combineSrcSpansA,-  addCLocA, addCLocAA,--  -- ** Constructing 'GenLocated' annotation types when we do not care-  -- about annotations.-  noLocA, getLocA,-  noSrcSpanA,-  noAnnSrcSpan,--  -- ** Working with comments in annotations-  noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,-  addCommentsToEpAnn, setCommentsEpAnn,-  transferAnnsA, commentsOnlyA, removeCommentsA,--  placeholderRealSpan,-  ) where--import GHC.Prelude--import Data.Data-import Data.Function (on)-import Data.List (sortBy)-import Data.Semigroup-import GHC.Data.FastString-import GHC.Types.Name-import GHC.Types.SrcLoc-import GHC.Hs.DocString-import GHC.Utils.Outputable hiding ( (<>) )-import GHC.Utils.Panic-import qualified GHC.Data.Strict as Strict--{--Note [exact print annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a parse tree of a Haskell module, how can we reconstruct-the original Haskell source code, retaining all whitespace and-source code comments?  We need to track the locations of all-elements from the original source: this includes keywords such as-'let' / 'in' / 'do' etc as well as punctuation such as commas and-braces, and also comments.  We collectively refer to this-metadata as the "exact print annotations".--NON-COMMENT ELEMENTS--Intuitively, every AST element directly contains a bag of keywords-(keywords can show up more than once in a node: a semicolon i.e. newline-can show up multiple times before the next AST element), each of which-needs to be associated with its location in the original source code.--These keywords are recorded directly in the AST element in which they-occur, for the GhcPs phase.--For any given element in the AST, there is only a set number of-keywords that are applicable for it (e.g., you'll never see an-'import' keyword associated with a let-binding.)  The set of allowed-keywords is documented in a comment associated with the constructor-of a given AST element, although the ground truth is in GHC.Parser-and GHC.Parser.PostProcess (which actually add the annotations).--COMMENT ELEMENTS--We associate comments with the lowest (most specific) AST element-enclosing them--PARSER STATE--There are three fields in PState (the parser state) which play a role-with annotation comments.-->  comment_q :: [LEpaComment],->  header_comments :: Maybe [LEpaComment],->  eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token--The 'comment_q' field captures comments as they are seen in the token stream,-so that when they are ready to be allocated via the parser they are-available.--The 'header_comments' capture the comments coming at the top of the-source file.  They are moved there from the `comment_q` when comments-are allocated for the first top-level declaration.--The 'eof_pos' captures the final location in the file, and the-location of the immediately preceding token to the last location, so-that the exact-printer can work out how far to advance to add the-trailing whitespace.--PARSER EMISSION OF ANNOTATIONS--The parser interacts with the lexer using the functions--> getCommentsFor      :: (MonadP m) => SrcSpan -> m EpAnnComments-> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments--The 'getCommentsFor' function is the one used most often.  It takes-the AST element SrcSpan and removes and returns any comments in the-'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is-responsible for making sure we only return comments that actually fit-in the 'SrcSpan'.--The 'getPriorCommentsFor' function is used for top-level declarations,-and removes and returns any comments in the 'comment_q' that either-precede or are included in the given SrcSpan. This is to ensure that-preceding documentation comments are kept together with the-declaration they belong to.--The 'getFinalCommentsFor' function is called right at the end when EOF-is hit. This drains the 'comment_q' completely, and returns the-'header_comments', remaining 'comment_q' entries and the-'eof_pos'. These values are inserted into the 'HsModule' AST element.--The wiki page describing this feature is-https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations---}---- ------------------------------------------------------------------------ | Exact print annotations exist so that tools can perform source to--- source conversions of Haskell code. They are used to keep track of--- the various syntactic keywords that are not otherwise captured in the--- AST.------ The wiki page describing this feature is--- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations--- https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow/in-tree-api-annotations------ Note: in general the names of these are taken from the--- corresponding token, unless otherwise noted--- See Note [exact print annotations] above for details of the usage-data AnnKeywordId-    = AnnAnyclass-    | AnnAs-    | AnnBang  -- ^ '!'-    | AnnBackquote -- ^ '`'-    | AnnBy-    | AnnCase -- ^ case or lambda case-    | AnnCases -- ^ lambda cases-    | AnnClass-    | AnnClose -- ^  '\#)' or '\#-}'  etc-    | AnnCloseB -- ^ '|)'-    | AnnCloseBU -- ^ '|)', unicode variant-    | AnnCloseC -- ^ '}'-    | AnnCloseQ  -- ^ '|]'-    | AnnCloseQU -- ^ '|]', unicode variant-    | AnnCloseP -- ^ ')'-    | AnnClosePH -- ^ '\#)'-    | AnnCloseS -- ^ ']'-    | AnnColon-    | AnnComma -- ^ as a list separator-    | AnnCommaTuple -- ^ in a RdrName for a tuple-    | AnnDarrow -- ^ '=>'-    | AnnDarrowU -- ^ '=>', unicode variant-    | AnnData-    | AnnDcolon -- ^ '::'-    | AnnDcolonU -- ^ '::', unicode variant-    | AnnDefault-    | AnnDeriving-    | AnnDo-    | AnnDot    -- ^ '.'-    | AnnDotdot -- ^ '..'-    | AnnElse-    | AnnEqual-    | AnnExport-    | AnnFamily-    | AnnForall-    | AnnForallU -- ^ Unicode variant-    | AnnForeign-    | AnnFunId -- ^ for function name in matches where there are-               -- multiple equations for the function.-    | AnnGroup-    | AnnHeader -- ^ for CType-    | AnnHiding-    | AnnIf-    | AnnImport-    | AnnIn-    | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'-    | AnnInstance-    | AnnLam-    | AnnLarrow     -- ^ '<-'-    | AnnLarrowU    -- ^ '<-', unicode variant-    | AnnLet-    | AnnLollyU     -- ^ The '⊸' unicode arrow-    | AnnMdo-    | AnnMinus -- ^ '-'-    | AnnModule-    | AnnNewtype-    | AnnName -- ^ where a name loses its location in the AST, this carries it-    | AnnOf-    | AnnOpen    -- ^ '{-\# DEPRECATED' etc. Opening of pragmas where-                 -- the capitalisation of the string can be changed by-                 -- the user. The actual text used is stored in a-                 -- 'SourceText' on the relevant pragma item.-    | AnnOpenB   -- ^ '(|'-    | AnnOpenBU  -- ^ '(|', unicode variant-    | AnnOpenC   -- ^ '{'-    | AnnOpenE   -- ^ '[e|' or '[e||'-    | AnnOpenEQ  -- ^ '[|'-    | AnnOpenEQU -- ^ '[|', unicode variant-    | AnnOpenP   -- ^ '('-    | AnnOpenS   -- ^ '['-    | AnnOpenPH  -- ^ '(\#'-    | AnnDollar          -- ^ prefix '$'   -- TemplateHaskell-    | AnnDollarDollar    -- ^ prefix '$$'  -- TemplateHaskell-    | AnnPackageName-    | AnnPattern-    | AnnPercent    -- ^ '%'  -- for HsExplicitMult-    | AnnPercentOne -- ^ '%1' -- for HsLinearArrow-    | AnnProc-    | AnnQualified-    | AnnRarrow -- ^ '->'-    | AnnRarrowU -- ^ '->', unicode variant-    | AnnRec-    | AnnRole-    | AnnSafe-    | AnnSemi -- ^ ';'-    | AnnSimpleQuote -- ^ '''-    | AnnSignature-    | AnnStatic -- ^ 'static'-    | AnnStock-    | AnnThen-    | AnnThTyQuote -- ^ double '''-    | AnnTilde -- ^ '~'-    | AnnType-    | AnnUnit -- ^ '()' for types-    | AnnUsing-    | AnnVal  -- ^ e.g. INTEGER-    | AnnValStr  -- ^ String value, will need quotes when output-    | AnnVbar -- ^ '|'-    | AnnVia -- ^ 'via'-    | AnnWhere-    | Annlarrowtail -- ^ '-<'-    | AnnlarrowtailU -- ^ '-<', unicode variant-    | Annrarrowtail -- ^ '->'-    | AnnrarrowtailU -- ^ '->', unicode variant-    | AnnLarrowtail -- ^ '-<<'-    | AnnLarrowtailU -- ^ '-<<', unicode variant-    | AnnRarrowtail -- ^ '>>-'-    | AnnRarrowtailU -- ^ '>>-', unicode variant-    deriving (Eq, Ord, Data, Show)--instance Outputable AnnKeywordId where-  ppr x = text (show x)---- | Certain tokens can have alternate representations when unicode syntax is--- enabled. This flag is attached to those tokens in the lexer so that the--- original source representation can be reproduced in the corresponding--- 'EpAnnotation'-data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax-    deriving (Eq, Ord, Data, Show)---- | Convert a normal annotation into its unicode equivalent one-unicodeAnn :: AnnKeywordId -> AnnKeywordId-unicodeAnn AnnForall     = AnnForallU-unicodeAnn AnnDcolon     = AnnDcolonU-unicodeAnn AnnLarrow     = AnnLarrowU-unicodeAnn AnnRarrow     = AnnRarrowU-unicodeAnn AnnDarrow     = AnnDarrowU-unicodeAnn Annlarrowtail = AnnlarrowtailU-unicodeAnn Annrarrowtail = AnnrarrowtailU-unicodeAnn AnnLarrowtail = AnnLarrowtailU-unicodeAnn AnnRarrowtail = AnnRarrowtailU-unicodeAnn AnnOpenB      = AnnOpenBU-unicodeAnn AnnCloseB     = AnnCloseBU-unicodeAnn AnnOpenEQ     = AnnOpenEQU-unicodeAnn AnnCloseQ     = AnnCloseQU-unicodeAnn ann           = ann----- | Some template haskell tokens have two variants, one with an `e` the other--- not:------ >  [| or [e|--- >  [|| or [e||------ This type indicates whether the 'e' is present or not.-data HasE = HasE | NoE-     deriving (Eq, Ord, Data, Show)---- -----------------------------------------------------------------------data EpaComment =-  EpaComment-    { ac_tok :: EpaCommentTok-    , ac_prior_tok :: RealSrcSpan-    -- ^ The location of the prior token, used in exact printing.  The-    -- 'EpaComment' appears as an 'LEpaComment' containing its-    -- location.  The difference between the end of the prior token-    -- and the start of this location is used for the spacing when-    -- exact printing the comment.-    }-    deriving (Eq, Data, Show)--data EpaCommentTok =-  -- Documentation annotations-    EpaDocComment      HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString-  | EpaDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)-  | EpaLineComment     String     -- ^ comment starting by "--"-  | EpaBlockComment    String     -- ^ comment in {- -}-  | EpaEofComment                 -- ^ empty comment, capturing-                                  -- location of EOF--  -- See #19697 for a discussion of EpaEofComment's use and how it-  -- should be removed in favour of capturing it in the location for-  -- 'Located HsModule' in the parser.--    deriving (Eq, Data, Show)--- Note: these are based on the Token versions, but the Token type is--- defined in GHC.Parser.Lexer and bringing it in here would create a loop--instance Outputable EpaComment where-  ppr x = text (show x)---- ------------------------------------------------------------------------- | Captures an annotation, storing the @'AnnKeywordId'@ and its--- location.  The parser only ever inserts @'EpaLocation'@ fields with a--- RealSrcSpan being the original location of the annotation in the--- source file.--- The @'EpaLocation'@ can also store a delta position if the AST has been--- modified and needs to be pretty printed again.--- The usual way an 'AddEpAnn' is created is using the 'mj' ("make--- jump") function, and then it can be inserted into the appropriate--- annotation.-data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)---- | The anchor for an @'AnnKeywordId'@. The Parser inserts the--- @'EpaSpan'@ variant, giving the exact location of the original item--- in the parsed source.  This can be replaced by the @'EpaDelta'@--- version, to provide a position for the item relative to the end of--- the previous item in the source.  This is useful when editing an--- AST prior to exact printing the changed one. The list of comments--- in the @'EpaDelta'@ variant captures any comments between the prior--- output and the thing being marked here, since we cannot otherwise--- sort the relative order.-data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)-                 | EpaDelta !DeltaPos ![LEpaComment]-               deriving (Data,Eq)---- | 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---- | Spacing between output items when exact printing.  It captures--- the spacing from the current print position on the page to the--- position required for the thing about to be printed.  This is--- either on the same line in which case is is simply the number of--- spaces to emit, or it is some number of lines down, with a given--- column offset.  The exact printing algorithm keeps track of the--- column offset pertaining to the current anchor position, so the--- `deltaColumn` is the additional spaces to add in this case.  See--- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for--- details.-data DeltaPos-  = SameLine { deltaColumn :: !Int }-  | DifferentLine-      { deltaLine   :: !Int, -- ^ deltaLine should always be > 0-        deltaColumn :: !Int-      } deriving (Show,Eq,Ord,Data)---- | Smart constructor for a 'DeltaPos'. It preserves the invariant--- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.-deltaPos :: Int -> Int -> DeltaPos-deltaPos l c = case l of-  0 -> SameLine c-  _ -> DifferentLine l c--getDeltaLine :: DeltaPos -> Int-getDeltaLine (SameLine _) = 0-getDeltaLine (DifferentLine r _) = r---- | Used in the parser only, extract the 'RealSrcSpan' from an--- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the--- partial function is safe.-epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan-epaLocationRealSrcSpan (EpaSpan r _) = r-epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"--epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation-epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing--instance Outputable EpaLocation where-  ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r-  ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs--instance Outputable AddEpAnn where-  ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss---- ------------------------------------------------------------------------- | The exact print annotations (EPAs) are kept in the HsSyn AST for---   the GhcPs phase. We do not always have EPAs though, only for code---   that has been parsed as they do not exist for generated---   code. This type captures that they may be missing.------ A goal of the annotations is that an AST can be edited, including--- moving subtrees from one place to another, duplicating them, and so--- on.  This means that each fragment must be self-contained.  To this--- end, each annotated fragment keeps track of the anchor position it--- was originally captured at, being simply the start span of the--- topmost element of the ast fragment.  This gives us a way to later--- re-calculate all Located items in this layer of the AST, as well as--- any annotations captured. The comments associated with the AST--- fragment are also captured here.------ The 'ann' type parameter allows this general structure to be--- specialised to the specific set of locations of original exact--- print annotation elements.  So for 'HsLet' we have------    type instance XLet GhcPs = EpAnn AnnsLet---    data AnnsLet---      = AnnsLet {---          alLet :: EpaLocation,---          alIn :: EpaLocation---          } deriving Data------ The spacing between the items under the scope of a given EpAnn is--- normally derived from the original 'Anchor'.  But if a sub-element--- is not in its original position, the required spacing can be--- directly captured in the 'anchor_op' field of the 'entry' Anchor.--- This allows us to freely move elements around, and stitch together--- new AST fragments out of old ones, and have them still printed out--- in a precise way.-data EpAnn ann-  = EpAnn { entry   :: !Anchor-           -- ^ Base location for the start of the syntactic element-           -- holding the annotations.-           , anns     :: !ann -- ^ Annotations added by the Parser-           , comments :: !EpAnnComments-              -- ^ Comments enclosed in the SrcSpan of the element-              -- this `EpAnn` is attached to-           }-  | EpAnnNotUsed -- ^ No Annotation for generated code,-                  -- e.g. from TH, deriving, etc.-        deriving (Data, Eq, Functor)---- | An 'Anchor' records the base location for the start of the--- syntactic element holding the annotations, and is used as the point--- of reference for calculating delta positions for contained--- annotations.--- It is also normally used as the reference point for the spacing of--- the element relative to its container. If it is moved, that--- relationship is tracked in the 'anchor_op' instead.--data Anchor = Anchor        { anchor :: RealSrcSpan-                                 -- ^ Base location for the start of-                                 -- the syntactic element holding-                                 -- the annotations.-                            , anchor_op :: AnchorOperation }-        deriving (Data, Eq, Show)---- | If tools modify the parsed source, the 'MovedAnchor' variant can--- directly provide the spacing for this item relative to the previous--- one when printing. This allows AST fragments with a particular--- anchor to be freely moved, without worrying about recalculating the--- appropriate anchor span.-data AnchorOperation = UnchangedAnchor-                     | MovedAnchor DeltaPos-        deriving (Data, Eq, Show)---spanAsAnchor :: SrcSpan -> Anchor-spanAsAnchor s  = Anchor (realSrcSpan s) UnchangedAnchor--realSpanAsAnchor :: RealSrcSpan -> Anchor-realSpanAsAnchor s  = Anchor s UnchangedAnchor---- ------------------------------------------------------------------------- | When we are parsing we add comments that belong a particular AST--- element, and print them together with the element, interleaving--- them into the output stream.  But when editing the AST to move--- fragments around it is useful to be able to first separate the--- comments into those occurring before the AST element and those--- following it.  The 'EpaCommentsBalanced' constructor is used to do--- this. The GHC parser will only insert the 'EpaComments' form.-data EpAnnComments = EpaComments-                        { priorComments :: ![LEpaComment] }-                    | EpaCommentsBalanced-                        { priorComments :: ![LEpaComment]-                        , followingComments :: ![LEpaComment] }-        deriving (Data, Eq)--type LEpaComment = GenLocated Anchor EpaComment--emptyComments :: EpAnnComments-emptyComments = EpaComments []---- ------------------------------------------------------------------------ Annotations attached to a 'SrcSpan'.--- ------------------------------------------------------------------------- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with--- an extra annotation type. This is mapped to a specific `GenLocated`--- usage in the AST through the `XRec` and `Anno` type families.---- Important that the fields are strict as these live inside L nodes which--- are live for a long time.-data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }-        deriving (Data, Eq)--- See Note [XRec and Anno in the AST]---- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\''-type SrcAnn ann = SrcSpanAnn' (EpAnn ann)--type LocatedA = GenLocated SrcSpanAnnA-type LocatedN = GenLocated SrcSpanAnnN--type LocatedL = GenLocated SrcSpanAnnL-type LocatedP = GenLocated SrcSpanAnnP-type LocatedC = GenLocated SrcSpanAnnC--type SrcSpanAnnA = SrcAnn AnnListItem-type SrcSpanAnnN = SrcAnn NameAnn--type SrcSpanAnnL = SrcAnn AnnList-type SrcSpanAnnP = SrcAnn AnnPragma-type SrcSpanAnnC = SrcAnn AnnContext---- | General representation of a 'GenLocated' type carrying a--- parameterised annotation type.-type LocatedAn an = GenLocated (SrcAnn an)--{--Note [XRec and Anno in the AST]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The exact print annotations are captured directly inside the AST, using-TTG extension points. However certain annotations need to be captured-on the Located versions too.  While there is a general form for these,-captured in the type SrcSpanAnn', there are also specific usages in-different contexts.--Some of the particular use cases are--1) RdrNames, which can have additional items such as backticks or parens--2) Items which occur in lists, and the annotation relates purely-to its usage inside a list.--See the section above this note for the rest.--The Anno type family maps the specific SrcSpanAnn' variant for a given-item.--So--  type instance XRec (GhcPass p) a = GenLocated (Anno a) a-  type instance Anno RdrName = SrcSpanAnnN-  type LocatedN = GenLocated SrcSpanAnnN--meaning we can have type LocatedN RdrName---}---- ------------------------------------------------------------------------ Annotations for items in a list--- ------------------------------------------------------------------------- | Captures the location of punctuation occurring between items,--- normally in a list.  It is captured as a trailing annotation.-data TrailingAnn-  = AddSemiAnn EpaLocation    -- ^ Trailing ';'-  | AddCommaAnn EpaLocation   -- ^ Trailing ','-  | AddVbarAnn EpaLocation    -- ^ Trailing '|'-  deriving (Data, Eq)--instance Outputable TrailingAnn where-  ppr (AddSemiAnn ss)    = text "AddSemiAnn"    <+> ppr ss-  ppr (AddCommaAnn ss)   = text "AddCommaAnn"   <+> ppr ss-  ppr (AddVbarAnn ss)    = text "AddVbarAnn"    <+> ppr ss---- | Annotation for items appearing in a list. They can have one or--- more trailing punctuations items, such as commas or semicolons.-data AnnListItem-  = AnnListItem {-      lann_trailing  :: [TrailingAnn]-      }-  deriving (Data, Eq)---- ------------------------------------------------------------------------ Annotations for the context of a list of items--- ------------------------------------------------------------------------- | Annotation for the "container" of a list. This captures--- surrounding items such as braces if present, and introductory--- keywords such as 'where'.-data AnnList-  = AnnList {-      al_anchor    :: Maybe Anchor, -- ^ start point of a list having layout-      al_open      :: Maybe AddEpAnn,-      al_close     :: Maybe AddEpAnn,-      al_rest      :: [AddEpAnn], -- ^ context, such as 'where' keyword-      al_trailing  :: [TrailingAnn] -- ^ items appearing after the-                                    -- list, such as '=>' for a-                                    -- context-      } deriving (Data,Eq)---- ------------------------------------------------------------------------ Annotations for parenthesised elements, such as tuples, lists--- ------------------------------------------------------------------------- | exact print annotation for an item having surrounding "brackets", such as--- tuples or lists-data AnnParen-  = AnnParen {-      ap_adornment :: ParenType,-      ap_open      :: EpaLocation,-      ap_close     :: EpaLocation-      } deriving (Data)---- | Detail of the "brackets" used in an 'AnnParen' exact print annotation.-data ParenType-  = AnnParens       -- ^ '(', ')'-  | AnnParensHash   -- ^ '(#', '#)'-  | AnnParensSquare -- ^ '[', ']'-  deriving (Eq, Ord, Data)---- | Maps the 'ParenType' to the related opening and closing--- AnnKeywordId. Used when actually printing the item.-parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId)-parenTypeKws AnnParens       = (AnnOpenP, AnnCloseP)-parenTypeKws AnnParensHash   = (AnnOpenPH, AnnClosePH)-parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS)---- ------------------------------------------------------------------------- | Exact print annotation for the 'Context' data type.-data AnnContext-  = AnnContext {-      ac_darrow    :: Maybe (IsUnicodeSyntax, EpaLocation),-                      -- ^ location and encoding of the '=>', if present.-      ac_open      :: [EpaLocation], -- ^ zero or more opening parentheses.-      ac_close     :: [EpaLocation]  -- ^ zero or more closing parentheses.-      } deriving (Data)----- ------------------------------------------------------------------------ Annotations for names--- ------------------------------------------------------------------------- | exact print annotations for a 'RdrName'.  There are many kinds of--- adornment that can be attached to a given 'RdrName'. This type--- captures them, as detailed on the individual constructors.-data NameAnn-  -- | Used for a name with an adornment, so '`foo`', '(bar)'-  = NameAnn {-      nann_adornment :: NameAdornment,-      nann_open      :: EpaLocation,-      nann_name      :: EpaLocation,-      nann_close     :: EpaLocation,-      nann_trailing  :: [TrailingAnn]-      }-  -- | Used for @(,,,)@, or @(#,,,#)#-  | NameAnnCommas {-      nann_adornment :: NameAdornment,-      nann_open      :: EpaLocation,-      nann_commas    :: [EpaLocation],-      nann_close     :: EpaLocation,-      nann_trailing  :: [TrailingAnn]-      }-  -- | Used for @(# | | #)@-  | NameAnnBars {-      nann_adornment :: NameAdornment,-      nann_open      :: EpaLocation,-      nann_bars      :: [EpaLocation],-      nann_close     :: EpaLocation,-      nann_trailing  :: [TrailingAnn]-      }-  -- | Used for @()@, @(##)@, @[]@-  | NameAnnOnly {-      nann_adornment :: NameAdornment,-      nann_open      :: EpaLocation,-      nann_close     :: EpaLocation,-      nann_trailing  :: [TrailingAnn]-      }-  -- | Used for @->@, as an identifier-  | NameAnnRArrow {-      nann_name      :: EpaLocation,-      nann_trailing  :: [TrailingAnn]-      }-  -- | Used for an item with a leading @'@. The annotation for-  -- unquoted item is stored in 'nann_quoted'.-  | NameAnnQuote {-      nann_quote     :: EpaLocation,-      nann_quoted    :: SrcSpanAnnN,-      nann_trailing  :: [TrailingAnn]-      }-  -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN'-  -- which has no Api Annotation (via the 'EpAnnNotUsed' constructor.-  | NameAnnTrailing {-      nann_trailing  :: [TrailingAnn]-      }-  deriving (Data, Eq)---- | A 'NameAnn' can capture the locations of surrounding adornments,--- such as parens or backquotes. This data type identifies what--- particular pair are being used.-data NameAdornment-  = NameParens -- ^ '(' ')'-  | NameParensHash -- ^ '(#' '#)'-  | NameBackquotes -- ^ '`'-  | NameSquare -- ^ '[' ']'-  deriving (Eq, Ord, Data)---- ------------------------------------------------------------------------- | exact print annotation used for capturing the locations of--- annotations in pragmas.-data AnnPragma-  = AnnPragma {-      apr_open      :: AddEpAnn,-      apr_close     :: AddEpAnn,-      apr_rest      :: [AddEpAnn]-      } deriving (Data,Eq)---- ------------------------------------------------------------------------ | Captures the sort order of sub elements. This is needed when the--- sub-elements have been split (as in a HsLocalBind which holds separate--- binds and sigs) or for infix patterns where the order has been--- re-arranged. It is captured explicitly so that after the Delta phase a--- SrcSpan is used purely as an index into the annotations, allowing--- transformations of the AST including the introduction of new Located--- items or re-arranging existing ones.-data AnnSortKey-  = NoAnnSortKey-  | AnnSortKey [RealSrcSpan]-  deriving (Data, Eq)---- ------------------------------------------------------------------------- | Convert a 'TrailingAnn' to an 'AddEpAnn'-trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn-trailingAnnToAddEpAnn (AddSemiAnn ss)    = AddEpAnn AnnSemi ss-trailingAnnToAddEpAnn (AddCommaAnn ss)   = AddEpAnn AnnComma ss-trailingAnnToAddEpAnn (AddVbarAnn ss)    = AddEpAnn AnnVbar ss---- | Helper function used in the parser to add a 'TrailingAnn' items--- to an existing annotation.-addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments-                  -> EpAnn AnnList -> EpAnn AnnList-addTrailingAnnToL s t cs EpAnnNotUsed-  = EpAnn (spanAsAnchor s) (AnnList (Just $ spanAsAnchor s) Nothing Nothing [] [t]) cs-addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n)-                               , comments = comments n <> cs }-  where-    -- See Note [list append in addTrailing*]-    addTrailing n = n { al_trailing = al_trailing n ++ [t]}---- | Helper function used in the parser to add a 'TrailingAnn' items--- to an existing annotation.-addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments-                  -> EpAnn AnnListItem -> EpAnn AnnListItem-addTrailingAnnToA s t cs EpAnnNotUsed-  = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs-addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n)-                               , comments = comments n <> cs }-  where-    -- See Note [list append in addTrailing*]-    addTrailing n = n { lann_trailing = lann_trailing n ++ [t] }---- | Helper function used in the parser to add a comma location to an--- existing annotation.-addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn-addTrailingCommaToN s EpAnnNotUsed l-  = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments-addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }-  where-    -- See Note [list append in addTrailing*]-    addTrailing :: NameAnn -> EpaLocation -> NameAnn-    addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]}--{--Note [list append in addTrailing*]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN-functions are used to add a separator for an item when it occurs in a-list.  So they are used to capture a comma, vbar, semicolon and similar.--In general, a given element will have zero or one of these.  In-extreme (test) cases, there may be multiple semicolons.--In exact printing we sometimes convert the EpaLocation variant for an-trailing annotation to the EpaDelta variant, which cannot be sorted.--Hence it is critical that these annotations are captured in the order-they appear in the original source file.--And so we use the less efficient list append to preserve the order,-knowing that in most cases the original list is empty.--}---- ------------------------------------------------------------------------- |Helper function (temporary) during transition of names---  Discards any annotations-l2n :: LocatedAn a1 a2 -> LocatedN a2-l2n (L la a) = L (noAnnSrcSpan (locA la)) a--n2l :: LocatedN a -> LocatedA a-n2l (L la a) = L (na2la la) a---- |Helper function (temporary) during transition of names---  Discards any annotations-la2na :: SrcSpanAnn' a -> SrcSpanAnnN-la2na l = noAnnSrcSpan (locA l)---- |Helper function (temporary) during transition of names---  Discards any annotations-la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2-la2la (L la a) = L (noAnnSrcSpan (locA la)) a--l2l :: SrcSpanAnn' a -> SrcAnn ann-l2l l = noAnnSrcSpan (locA l)---- |Helper function (temporary) during transition of names---  Discards any annotations-na2la :: SrcSpanAnn' a -> SrcAnn ann-na2la l = noAnnSrcSpan (locA l)--reLoc :: LocatedAn a e -> Located e-reLoc (L (SrcSpanAnn _ l) a) = L l a--reLocA :: Located e -> LocatedAn ann e-reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)--reLocL :: LocatedN e -> LocatedA e-reLocL (L l a) = (L (na2la l) a)--reLocC :: LocatedN e -> LocatedC e-reLocC (L l a) = (L (na2la l) a)--reLocN :: LocatedN a -> Located a-reLocN (L (SrcSpanAnn _ l) a) = L l a---- -----------------------------------------------------------------------realSrcSpan :: SrcSpan -> RealSrcSpan-realSrcSpan (RealSrcSpan s _) = s-realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary-  where-    l = mkRealSrcLoc (fsLit "foo") (-1) (-1)--srcSpan2e :: SrcSpan -> EpaLocation-srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb-srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing--la2e :: SrcSpanAnn' a -> EpaLocation-la2e = srcSpan2e . locA--extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList-extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t--reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a-reAnn anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem anns) cs) l) a--reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a-reAnnC anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a--reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e-reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a--getLocAnn :: Located a  -> SrcSpanAnnA-getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l---getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan-getLocA (L (SrcSpanAnn _ l) _) = l--noLocA :: a -> LocatedAn an a-noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)--noAnnSrcSpan :: SrcSpan -> SrcAnn ann-noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l--noSrcSpanA :: SrcAnn ann-noSrcSpanA = noAnnSrcSpan noSrcSpan---- | Short form for 'EpAnnNotUsed'-noAnn :: EpAnn a-noAnn = EpAnnNotUsed---addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]-addAnns (EpAnn l as1 cs) as2 cs2-  = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2)-addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed-addAnns EpAnnNotUsed [] (EpaCommentsBalanced [] []) = EpAnnNotUsed-addAnns EpAnnNotUsed as cs = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) as cs---- AZ:TODO use widenSpan here too-addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA-addAnnsA (SrcSpanAnn (EpAnn l as1 cs) loc) as2 cs2-  = SrcSpanAnn (EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)) loc-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaComments [])-  = SrcSpanAnn EpAnnNotUsed loc-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaCommentsBalanced [] [])-  = SrcSpanAnn EpAnnNotUsed loc-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) as cs-  = SrcSpanAnn (EpAnn (spanAsAnchor loc) (AnnListItem as) cs) loc---- | The annotations need to all come after the anchor.  Make sure--- this is the case.-widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan-widenSpan s as = foldl combineSrcSpans s (go as)-  where-    go [] = []-    go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest-    go (AddEpAnn _ (EpaDelta _ _):rest) = go rest---- | The annotations need to all come after the anchor.  Make sure--- this is the case.-widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan-widenRealSpan s as = foldl combineRealSrcSpans s (go as)-  where-    go [] = []-    go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest-    go (AddEpAnn _ (EpaDelta _ _):rest) =     go rest--widenAnchor :: Anchor -> [AddEpAnn] -> Anchor-widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op--widenAnchorR :: Anchor -> RealSrcSpan -> Anchor-widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op--widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an-widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as)--epAnnAnnsL :: EpAnn a -> [a]-epAnnAnnsL EpAnnNotUsed = []-epAnnAnnsL (EpAnn _ anns _) = [anns]--epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn]-epAnnAnns EpAnnNotUsed = []-epAnnAnns (EpAnn _ anns _) = anns--annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn]-annParen2AddEpAnn EpAnnNotUsed = []-annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _)-  = [AddEpAnn ai o, AddEpAnn ac c]-  where-    (ai,ac) = parenTypeKws pt--epAnnComments :: EpAnn an -> EpAnnComments-epAnnComments EpAnnNotUsed = EpaComments []-epAnnComments (EpAnn _ _ cs) = cs---- ------------------------------------------------------------------------ sortLocatedA :: [LocatedA a] -> [LocatedA a]-sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]-sortLocatedA = sortBy (leftmost_smallest `on` getLocA)--mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b-mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)---- AZ:TODO: move this somewhere sane--combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a-combineLocsA (L a _) (L b _) = combineSrcSpansA a b--combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a-combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)-  = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of-      SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l-      SrcSpanAnn (EpAnn anc an cs) l ->-        SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l---- | Combine locations from two 'Located' things and add them to a third thing-addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3-addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c--addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3-addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c---- ------------------------------------------------------------------------ Utilities for manipulating EpAnnComments--- -----------------------------------------------------------------------getFollowingComments :: EpAnnComments -> [LEpaComment]-getFollowingComments (EpaComments _) = []-getFollowingComments (EpaCommentsBalanced _ cs) = cs--setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments-setFollowingComments (EpaComments ls) cs           = EpaCommentsBalanced ls cs-setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs--setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments-setPriorComments (EpaComments _) cs            = EpaComments cs-setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts---- ------------------------------------------------------------------------ Comment-only annotations--- -----------------------------------------------------------------------type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only--data NoEpAnns = NoEpAnns-  deriving (Data,Eq,Ord)--noComments ::EpAnnCO-noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments---- TODO:AZ get rid of this-placeholderRealSpan :: RealSrcSpan-placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1))--comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO-comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs---- ------------------------------------------------------------------------ Utilities for managing comments in an `EpAnn a` structure.--- ------------------------------------------------------------------------- | Add additional comments to a 'SrcAnn', used for manipulating the--- AST prior to exact printing the changed one.-addCommentsToSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann-addCommentsToSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs-  = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc-addCommentsToSrcAnn (SrcSpanAnn (EpAnn a an cs) loc) cs'-  = SrcSpanAnn (EpAnn a an (cs <> cs')) loc---- | Replace any existing comments on a 'SrcAnn', used for manipulating the--- AST prior to exact printing the changed one.-setCommentsSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann-setCommentsSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs-  = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc-setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs-  = SrcSpanAnn (EpAnn a an cs) loc---- | Add additional comments, used for manipulating the--- AST prior to exact printing the changed one.-addCommentsToEpAnn :: (Monoid a)-  => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a-addCommentsToEpAnn loc EpAnnNotUsed cs-  = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs-addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs)---- | Replace any existing comments, used for manipulating the--- AST prior to exact printing the changed one.-setCommentsEpAnn :: (Monoid a)-  => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a-setCommentsEpAnn loc EpAnnNotUsed cs-  = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs-setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs---- | Transfer comments and trailing items from the annotations in the--- first 'SrcSpanAnnA' argument to those in the second.-transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)-transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)-transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to-  = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to')-  where-    to' = case to of-      (SrcSpanAnn EpAnnNotUsed loc)-        ->  SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc-      (SrcSpanAnn (EpAnn a an' cs') loc)-        -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc---- | Remove the exact print annotations payload, leaving only the--- anchor and comments.-commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann-commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc-commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)---- | Remove the comments, leaving the exact print annotations payload-removeCommentsA :: SrcAnn ann -> SrcAnn ann-removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc-removeCommentsA (SrcSpanAnn (EpAnn a an _) loc)-  = (SrcSpanAnn (EpAnn a an emptyComments) loc)---- ------------------------------------------------------------------------ Semigroup instances, to allow easy combination of annotaion elements--- -----------------------------------------------------------------------instance (Semigroup an) => Semigroup (SrcSpanAnn' an) where-  (SrcSpanAnn a1 l1) <> (SrcSpanAnn a2 l2) = SrcSpanAnn (a1 <> a2) (combineSrcSpans l1 l2)-   -- The critical part about the location is its left edge, and all-   -- annotations must follow it. So we combine them which yields the-   -- largest span--instance (Semigroup a) => Semigroup (EpAnn a) where-  EpAnnNotUsed <> x = x-  x <> EpAnnNotUsed = x-  (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2)-   -- The critical part about the anchor is its left edge, and all-   -- annotations must follow it. So we combine them which yields the-   -- largest span--instance Ord Anchor where-  compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2--instance Semigroup Anchor where-  Anchor r1 o1 <> Anchor r2 _ = Anchor (combineRealSrcSpans r1 r2) o1--instance Semigroup EpAnnComments where-  EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2)-  EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2-  EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1-  EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2)---instance (Monoid a) => Monoid (EpAnn a) where-  mempty = EpAnnNotUsed--instance Semigroup NoEpAnns where-  _ <> _ = NoEpAnns--instance Semigroup AnnListItem where-  (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)--instance Monoid AnnListItem where-  mempty = AnnListItem []---instance Semigroup AnnList where-  (AnnList a1 o1 c1 r1 t1) <> (AnnList a2 o2 c2 r2 t2)-    = AnnList (a1 <> a2) (c o1 o2) (c c1 c2) (r1 <> r2) (t1 <> t2)-    where-      -- Left biased combination for the open and close annotations-      c Nothing x = x-      c x Nothing = x-      c f _       = f--instance Monoid AnnList where-  mempty = AnnList Nothing Nothing Nothing [] []--instance Semigroup NameAnn where-  _ <> _ = panic "semigroup nameann"--instance Monoid NameAnn where-  mempty = NameAnnTrailing []---instance Semigroup AnnSortKey where-  NoAnnSortKey <> x = x-  x <> NoAnnSortKey = x-  AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)--instance Monoid AnnSortKey where-  mempty = NoAnnSortKey--instance (Outputable a) => Outputable (EpAnn a) where-  ppr (EpAnn l a c)  = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c-  ppr EpAnnNotUsed = text "EpAnnNotUsed"--instance Outputable NoEpAnns where-  ppr NoEpAnns = text "NoEpAnns"--instance Outputable Anchor where-  ppr (Anchor a o)        = text "Anchor" <+> ppr a <+> ppr o--instance Outputable AnchorOperation where-  ppr UnchangedAnchor   = text "UnchangedAnchor"-  ppr (MovedAnchor d)   = text "MovedAnchor" <+> ppr d--instance Outputable DeltaPos where-  ppr (SameLine c) = text "SameLine" <+> ppr c-  ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c--instance Outputable (GenLocated Anchor EpaComment) where-  ppr (L l c) = text "L" <+> ppr l <+> ppr c--instance Outputable EpAnnComments where-  ppr (EpaComments cs) = text "EpaComments" <+> ppr cs-  ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts--instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where-  getName (L l a) = getName (L (locA l) a)--instance Outputable AnnContext where-  ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c--instance Outputable AnnSortKey where-  ppr NoAnnSortKey    = text "NoAnnSortKey"-  ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls--instance Outputable IsUnicodeSyntax where-  ppr = text . show--instance (Outputable a) => Outputable (SrcSpanAnn' a) where-  ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l--instance (Outputable a, Outputable e)-     => Outputable (GenLocated (SrcSpanAnn' a) e) where-  ppr = pprLocated--instance (Outputable a, OutputableBndr e)-     => OutputableBndr (GenLocated (SrcSpanAnn' a) e) where-  pprInfixOcc = pprInfixOcc . unLoc-  pprPrefixOcc = pprPrefixOcc . unLoc--instance Outputable AnnListItem where-  ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts--instance Outputable NameAdornment where-  ppr NameParens     = text "NameParens"-  ppr NameParensHash = text "NameParensHash"-  ppr NameBackquotes = text "NameBackquotes"-  ppr NameSquare     = text "NameSquare"--instance Outputable NameAnn where-  ppr (NameAnn a o n c t)-    = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t-  ppr (NameAnnCommas a o n c t)-    = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t-  ppr (NameAnnBars a o n b t)-    = text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t-  ppr (NameAnnOnly a o c t)-    = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t-  ppr (NameAnnRArrow n t)-    = text "NameAnnRArrow" <+> ppr n <+> ppr t-  ppr (NameAnnQuote q n t)-    = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t-  ppr (NameAnnTrailing t)-    = text "NameAnnTrailing" <+> ppr t--instance Outputable AnnList where-  ppr (AnnList a o c r t)-    = text "AnnList" <+> ppr a <+> ppr o <+> ppr c <+> ppr r <+> ppr t--instance Outputable AnnPragma where-  ppr (AnnPragma o c r) = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr r+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}++module GHC.Parser.Annotation (+  -- * Core Exact Print Annotation types+  EpToken(..), EpUniToken(..),+  getEpTokenSrcSpan,+  getEpTokenBufSpan,+  getEpTokenLocs, getEpTokenLoc, getEpUniTokenLoc,+  TokDcolon, TokDarrow, TokRarrow, TokForall,+  EpLayout(..),+  EpaComment(..), EpaCommentTok(..),+  IsUnicodeSyntax(..),+  HasE(..),++  -- * In-tree Exact Print Annotations+  EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan,+  DeltaPos(..), deltaPos, getDeltaLine,++  EpAnn(..),+  spanAsAnchor, realSpanAsAnchor,+  noSpanAnchor,+  NoAnn(..),++  -- ** Comments in Annotations++  EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments,+  epaToNoCommentsLocation, noCommentsToEpaLocation,+  getFollowingComments, setFollowingComments, setPriorComments,+  EpAnnCO,++  -- ** Annotations in 'GenLocated'+  LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,+  LocatedLC, LocatedLS, LocatedLW, LocatedLI,+  SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,+  SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI,+  LocatedE,++  -- ** Annotation data types used in 'GenLocated'++  AnnListItem(..), AnnList(..), AnnListBrackets(..),+  AnnParen(..),+  AnnPragma(..),+  AnnContext(..),+  NameAnn(..), NameAdornment(..),+  NoEpAnns(..),+  AnnSortKey(..), DeclTag(..), BindTag(..),++  -- ** Trailing annotations in lists+  TrailingAnn(..), ta_location,+  addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,+  noTrailingN,++  -- ** Utilities for converting between different 'GenLocated' when+  -- ** we do not care about the annotations.+  l2l, la2la,+  reLoc,+  HasLoc(..), getHasLocList,++  srcSpan2e, realSrcSpan,++  -- ** Building up annotations+  addAnnsA, widenSpanL, widenSpanT, widenAnchorT, widenAnchorS,+  widenLocatedAnL,+  listLocation,++  -- ** Querying annotations+  getLocAnn,+  epAnnComments,++  -- ** Working with locations of annotations+  sortLocatedA,+  mapLocA,+  combineLocsA,+  combineSrcSpansA,+  addCLocA,++  -- ** Constructing 'GenLocated' annotation types when we do not care+  -- about annotations.+  HasAnnotation(..),+  locA,+  noLocA,+  getLocA,+  noSrcSpanA,++  -- ** Working with comments in annotations+  noComments, comment, addCommentsToEpAnn, setCommentsEpAnn,+  transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA,+  transferPriorCommentsA, transferFollowingA,++  placeholderRealSpan,+  ) where++import GHC.Prelude++import Data.Data+import Data.Function (on)+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+import GHC.Types.SourceText (SourceText (NoSourceText))++{-+Note [exact print annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a parse tree of a Haskell module, how can we reconstruct+the original Haskell source code, retaining all whitespace and+source code comments?  We need to track the locations of all+elements from the original source: this includes keywords such as+'let' / 'in' / 'do' etc as well as punctuation such as commas and+braces, and also comments.  We collectively refer to this+metadata as the "exact print annotations".++NON-COMMENT ELEMENTS++Intuitively, every AST element directly contains a bag of keywords+(keywords can show up more than once in a node: a semicolon i.e. newline+can show up multiple times before the next AST element), each of which+needs to be associated with its location in the original source code.++These keywords are recorded directly in the AST element in which they+occur, for the GhcPs phase.++For any given element in the AST, there is only a set number of+keywords that are applicable for it (e.g., you'll never see an+'import' keyword associated with a let-binding.)  The set of allowed+keywords is documented in a comment associated with the constructor+of a given AST element, although the ground truth is in GHC.Parser+and GHC.Parser.PostProcess (which actually add the annotations).++COMMENT ELEMENTS++We associate comments with the lowest (most specific) AST element+enclosing them++PARSER STATE++There are three fields in PState (the parser state) which play a role+with annotation comments.++>  comment_q :: [LEpaComment],+>  header_comments :: Maybe [LEpaComment],+>  eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token++The 'comment_q' field captures comments as they are seen in the token stream,+so that when they are ready to be allocated via the parser they are+available.++The 'header_comments' capture the comments coming at the top of the+source file.  They are moved there from the `comment_q` when comments+are allocated for the first top-level declaration.++The 'eof_pos' captures the final location in the file, and the+location of the immediately preceding token to the last location, so+that the exact-printer can work out how far to advance to add the+trailing whitespace.++PARSER EMISSION OF ANNOTATIONS++The parser interacts with the lexer using the functions++> getCommentsFor      :: (MonadP m) => SrcSpan -> m EpAnnComments+> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments++The 'getCommentsFor' function is the one used most often.  It takes+the AST element SrcSpan and removes and returns any comments in the+'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is+responsible for making sure we only return comments that actually fit+in the 'SrcSpan'.++The 'getPriorCommentsFor' function is used for top-level declarations,+and removes and returns any comments in the 'comment_q' that either+precede or are included in the given SrcSpan. This is to ensure that+preceding documentation comments are kept together with the+declaration they belong to.++The 'getFinalCommentsFor' function is called right at the end when EOF+is hit. This drains the 'comment_q' completely, and returns the+'header_comments', remaining 'comment_q' entries and the+'eof_pos'. These values are inserted into the 'HsModule' AST element.++The wiki page describing this feature is+https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations++-}++-- --------------------------------------------------------------------++-- | Certain tokens can have alternate representations when unicode syntax is+-- enabled. This flag is attached to those tokens in the lexer so that the+-- original source representation can be reproduced in the corresponding+-- 'EpAnnotation'+data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax+    deriving (Eq, Ord, Data, Show)++-- | Some template haskell tokens have two variants, one with an `e` the other+-- not:+--+-- >  [| or [e|+-- >  [|| or [e||+--+-- This type indicates whether the 'e' is present or not.+data HasE = HasE | NoE+     deriving (Eq, Ord, Data, Show)++-- ---------------------------------------------------------------------++-- | A token stored in the syntax tree. For example, when parsing a+-- let-expression, we store @EpToken "let"@ and @EpToken "in"@.+-- The locations of those tokens can be used to faithfully reproduce+-- (exactprint) the original program text.+data EpToken (tok :: Symbol)+  = NoEpTok+  | EpTok !EpaLocation++instance KnownSymbol tok => Outputable (EpToken tok) where+  ppr _ = text (symbolVal (Proxy @tok))++-- | With @UnicodeSyntax@, there might be multiple ways to write the same+-- token. For example an arrow could be either @->@ or @→@. This choice must be+-- recorded in order to exactprint such tokens, so instead of @EpToken "->"@ we+-- introduce @EpUniToken "->" "→"@.+data EpUniToken (tok :: Symbol) (utok :: Symbol)+  = NoEpUniTok+  | EpUniTok !EpaLocation !IsUnicodeSyntax++deriving instance Eq (EpToken tok)+deriving instance Eq (EpUniToken tok utok)+deriving instance KnownSymbol tok => Data (EpToken tok)+deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok)++instance (KnownSymbol tok, KnownSymbol utok) => Outputable (EpUniToken tok utok) where+  ppr NoEpUniTok                 = text $ symbolVal (Proxy @tok)+  ppr (EpUniTok _ NormalSyntax)  = text $ symbolVal (Proxy @tok)+  ppr (EpUniTok _ UnicodeSyntax) = text $ symbolVal (Proxy @utok)++getEpTokenSrcSpan :: EpToken tok -> SrcSpan+getEpTokenSrcSpan NoEpTok = noSrcSpan+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+    go NoEpTok   = []+    go (EpTok l) = [l]++getEpTokenLoc :: EpToken tok -> EpaLocation+getEpTokenLoc NoEpTok   = noAnn+getEpTokenLoc (EpTok l) = l++getEpUniTokenLoc :: EpUniToken tok toku -> EpaLocation+getEpUniTokenLoc NoEpUniTok     = noAnn+getEpUniTokenLoc (EpUniTok l _) = l++-- TODO:AZ: check we have all of the unicode tokens+type TokDcolon = EpUniToken "::" "∷"+type TokDarrow = EpUniToken "=>"  "⇒"+type TokRarrow = EpUniToken "->" "→"+type TokForall = EpUniToken "forall" "∀"++-- | Layout information for declarations.+data EpLayout =++    -- | Explicit braces written by the user.+    --+    -- @+    -- class C a where { foo :: a; bar :: a }+    -- @+    EpExplicitBraces !(EpToken "{") !(EpToken "}")+  |+    -- | Virtual braces inserted by the layout algorithm.+    --+    -- @+    -- class C a where+    --   foo :: a+    --   bar :: a+    -- @+    EpVirtualBraces+      !Int -- ^ Layout column (indentation level, begins at 1)+  |+    -- | Empty or compiler-generated blocks do not have layout information+    -- associated with them.+    EpNoLayout++deriving instance Data EpLayout++-- ---------------------------------------------------------------------++data EpaComment =+  EpaComment+    { ac_tok :: EpaCommentTok+    , ac_prior_tok :: RealSrcSpan+    -- ^ The location of the prior token, used in exact printing.  The+    -- 'EpaComment' appears as an 'LEpaComment' containing its+    -- location.  The difference between the end of the prior token+    -- and the start of this location is used for the spacing when+    -- exact printing the comment.+    }+    deriving (Eq, Data, Show)++data EpaCommentTok =+  -- Documentation annotations+    EpaDocComment      HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString+  | EpaDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)+  | EpaLineComment     String     -- ^ comment starting by "--"+  | EpaBlockComment    String     -- ^ comment in {- -}+    deriving (Eq, Data, Show)+-- Note: these are based on the Token versions, but the Token type is+-- defined in GHC.Parser.Lexer and bringing it in here would create a loop++instance Outputable EpaComment where+  ppr x = text (show x)++-- ---------------------------------------------------------------------++type EpaLocation = EpaLocation' [LEpaComment]++epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation+epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss+epaToNoCommentsLocation (EpaDelta ss dp []) = EpaDelta ss dp NoComments+epaToNoCommentsLocation (EpaDelta _ _ _ ) = panic "epaToNoCommentsLocation"++noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation+noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss+noCommentsToEpaLocation (EpaDelta ss dp NoComments) = EpaDelta ss dp []++-- | Used in the parser only, extract the 'RealSrcSpan' from an+-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the+-- partial function is safe.+epaLocationRealSrcSpan :: EpaLocation' a -> RealSrcSpan+epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r+epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"++-- ---------------------------------------------------------------------++-- | The exact print annotations (EPAs) are kept in the HsSyn AST for+--   the GhcPs phase. They are usually inserted into the AST by the parser,+--   and in case of generated code (e.g. by TemplateHaskell) they are usually+--   initialized using 'NoAnn' type class.+--+-- A goal of the annotations is that an AST can be edited, including+-- moving subtrees from one place to another, duplicating them, and so+-- on.  This means that each fragment must be self-contained.  To this+-- end, each annotated fragment keeps track of the anchor position it+-- was originally captured at, being simply the start span of the+-- topmost element of the ast fragment.  This gives us a way to later+-- re-calculate all Located items in this layer of the AST, as well as+-- any annotations captured. The comments associated with the AST+-- fragment are also captured here.+--+-- The 'ann' type parameter allows this general structure to be+-- specialised to the specific set of locations of original exact+-- print annotation elements.  For example+--+-- @+-- type SrcSpannAnnA = EpAnn AnnListItem+-- @+--+-- is a commonly used type alias that specializes the 'ann' type parameter to+-- 'AnnListItem'.+--+-- The spacing between the items under the scope of a given EpAnn is+-- normally derived from the original 'Anchor'.  But if a sub-element+-- is not in its original position, the required spacing can be+-- captured using an appropriate 'EpaDelta' value for the 'entry' Anchor.+-- This allows us to freely move elements around, and stitch together+-- new AST fragments out of old ones, and have them still printed out+-- in a precise way.+data EpAnn ann+  = EpAnn { entry   :: !EpaLocation+           -- ^ Base location for the start of the syntactic element+           -- holding the annotations.+           , anns     :: !ann -- ^ Annotations added by the Parser+           , comments :: !EpAnnComments+              -- ^ Comments enclosed in the SrcSpan of the element+              -- this `EpAnn` is attached to+           }+        deriving (Data, Eq, Functor)+-- See Note [XRec and Anno in the AST]+++spanAsAnchor :: SrcSpan -> (EpaLocation' a)+spanAsAnchor ss  = EpaSpan ss++realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a)+realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing)++noSpanAnchor :: (NoAnn a) => EpaLocation' a+noSpanAnchor =  EpaDelta noSrcSpan (SameLine 0) noAnn++-- ---------------------------------------------------------------------++-- | When we are parsing we add comments that belong to a particular AST+-- element, and print them together with the element, interleaving+-- them into the output stream.  But when editing the AST to move+-- fragments around it is useful to be able to first separate the+-- comments into those occurring before the AST element and those+-- following it.  The 'EpaCommentsBalanced' constructor is used to do+-- this. The GHC parser will only insert the 'EpaComments' form.+data EpAnnComments = EpaComments+                        { priorComments :: ![LEpaComment] }+                    | EpaCommentsBalanced+                        { priorComments :: ![LEpaComment]+                        , followingComments :: ![LEpaComment] }+        deriving (Data, Eq)++type LEpaComment = GenLocated NoCommentsLocation EpaComment++emptyComments :: EpAnnComments+emptyComments = EpaComments []++-- ---------------------------------------------------------------------+-- Annotations attached to a 'SrcSpan'.+-- ---------------------------------------------------------------------++type LocatedA = GenLocated SrcSpanAnnA+type LocatedN = GenLocated SrcSpanAnnN++type LocatedL = GenLocated SrcSpanAnnL+type LocatedLC = GenLocated SrcSpanAnnLC+type LocatedLS = GenLocated SrcSpanAnnLS+type LocatedLW = GenLocated SrcSpanAnnLW+type LocatedLI = GenLocated SrcSpanAnnLI+type LocatedP = GenLocated SrcSpanAnnP+type LocatedC = GenLocated SrcSpanAnnC++type SrcSpanAnnA = EpAnn AnnListItem+type SrcSpanAnnN = EpAnn NameAnn++type SrcSpanAnnL = EpAnn (AnnList ())+type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","])+type SrcSpanAnnLS = EpAnn (AnnList ())+type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where"))+type SrcSpanAnnLI = EpAnn (AnnList (EpToken "hiding", [EpToken ","]))+type SrcSpanAnnP = EpAnn AnnPragma+type SrcSpanAnnC = EpAnn AnnContext++type LocatedE = GenLocated EpaLocation++-- | General representation of a 'GenLocated' type carrying a+-- parameterised annotation type.+type LocatedAn an = GenLocated (EpAnn an)++{-+Note [XRec and Anno in the AST]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The exact print annotations are captured directly inside the AST, using+TTG extension points. However certain annotations need to be captured+on the Located versions too.  There is a general form for these,+captured in the type 'EpAnn ann' with the specific usage captured in+the 'ann' parameter in different contexts.++Some of the particular use cases are++1) RdrNames, which can have additional items such as backticks or parens++2) Items which occur in lists, and the annotation relates purely+to its usage inside a list.++See the section above this note for the rest.++The Anno type family maps to the specific EpAnn variant for a given+item.++So++  type instance XRec (GhcPass p) a = XRecGhc a+  type XRecGhc a = GenLocated (Anno a) a++  type instance Anno RdrName = SrcSpanAnnN+  type LocatedN = GenLocated SrcSpanAnnN++meaning we can have type LocatedN RdrName++-}++-- ---------------------------------------------------------------------+-- Annotations for items in a list+-- ---------------------------------------------------------------------++-- | Captures the location of punctuation occurring between items,+-- normally in a list.  It is captured as a trailing annotation.+data TrailingAnn+  = AddSemiAnn    (EpToken ";") -- ^ Trailing ';'+  | AddCommaAnn   (EpToken ",") -- ^ Trailing ','+  | AddVbarAnn    (EpToken "|") -- ^ Trailing '|'+  | AddDarrowAnn  TokDarrow     -- ^ Trailing '=>' / '⇒'+  deriving (Data, Eq)++ta_location :: TrailingAnn -> EpaLocation+ta_location (AddSemiAnn    tok) = getEpTokenLoc tok+ta_location (AddCommaAnn   tok) = getEpTokenLoc tok+ta_location (AddVbarAnn    tok) = getEpTokenLoc tok+ta_location (AddDarrowAnn  tok) = getEpUniTokenLoc tok+++instance Outputable TrailingAnn where+  ppr (AddSemiAnn tok)    = text "AddSemiAnn"    <+> ppr tok+  ppr (AddCommaAnn tok)   = text "AddCommaAnn"   <+> ppr tok+  ppr (AddVbarAnn tok)    = text "AddVbarAnn"    <+> ppr tok+  ppr (AddDarrowAnn tok)  = text "AddDarrowAnn"  <+> ppr tok++-- | Annotation for items appearing in a list. They can have one or+-- more trailing punctuations items, such as commas or semicolons.+data AnnListItem+  = AnnListItem {+      lann_trailing  :: [TrailingAnn]+      }+  deriving (Data, Eq)++-- ---------------------------------------------------------------------+-- Annotations for the context of a list of items+-- ---------------------------------------------------------------------++-- | Annotation for the "container" of a list. This captures+-- surrounding items such as braces if present, and introductory+-- keywords such as 'where'.+data AnnList a+  = AnnList {+      al_anchor    :: !(Maybe EpaLocation), -- ^ start point of a list having layout+      al_brackets  :: !AnnListBrackets,+      al_semis     :: [EpToken ";"], -- decls+      al_rest      :: !a,+      al_trailing  :: ![TrailingAnn] -- ^ items appearing after the+                                     -- list, such as '=>' for a+                                     -- context+      } deriving (Data,Eq)++data AnnListBrackets+  = ListParens (EpToken "(")         (EpToken ")")+  | ListBraces (EpToken "{")         (EpToken "}")+  | ListSquare (EpToken "[")         (EpToken "]")+  | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)"  "⦈")+  | ListNone+  deriving (Data,Eq)++-- ---------------------------------------------------------------------+-- Annotations for parenthesised elements, such as tuples, lists+-- ---------------------------------------------------------------------++-- | exact print annotation for an item having surrounding "brackets", such as+-- tuples or lists+data AnnParen+  = AnnParens       (EpToken "(")  (EpToken ")")  -- ^ '(', ')'+  | AnnParensHash   (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)'+  | AnnParensSquare (EpToken "[")  (EpToken "]")  -- ^ '[', ']'+  deriving Data++-- ---------------------------------------------------------------------++-- | Exact print annotation for the 'Context' data type.+data AnnContext+  = AnnContext {+      ac_darrow    :: Maybe TokDarrow,+                      -- ^ location of the '=>', if present.+      ac_open      :: [EpToken "("], -- ^ zero or more opening parentheses.+      ac_close     :: [EpToken ")"]  -- ^ zero or more closing parentheses.+      } deriving (Data)+++-- ---------------------------------------------------------------------+-- Annotations for names+-- ---------------------------------------------------------------------++-- | exact print annotations for a 'RdrName'.  There are many kinds of+-- adornment that can be attached to a given 'RdrName'. This type+-- captures them, as detailed on the individual constructors.+data NameAnn+  -- | Used for a name with an adornment, so '`foo`', '(bar)'+  = NameAnn {+      nann_adornment :: NameAdornment,+      nann_name      :: EpaLocation,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @(,,,)@, or @(#,,,#)@+  | NameAnnCommas {+      nann_adornment :: NameAdornment,+      nann_commas    :: [EpToken ","],+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @(# | | #)@+  | NameAnnBars {+      nann_parensh   :: (EpToken "(#", EpToken "#)"),+      nann_bars      :: [EpToken "|"],+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @()@, @(##)@, @[]@+  | NameAnnOnly {+      nann_adornment :: NameAdornment,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @->@, as an identifier+  | NameAnnRArrow {+      nann_mopen     :: Maybe (EpToken "("),+      nann_arrow     :: TokRarrow,+      nann_mclose    :: Maybe (EpToken ")"),+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for an item with a leading @'@. The annotation for+  -- unquoted item is stored in 'nann_quoted'.+  | NameAnnQuote {+      nann_quote     :: EpToken "'",+      nann_quoted    :: SrcSpanAnnN,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN'+  -- which has no Api Annotation.+  | NameAnnTrailing {+      nann_trailing  :: [TrailingAnn]+      }+  deriving (Data, Eq)++-- | A 'NameAnn' can capture the locations of surrounding adornments,+-- such as parens or backquotes. This data type identifies what+-- particular pair are being used.+data NameAdornment+  = NameParens     (EpToken "(")  (EpToken ")")+  | NameParensHash (EpToken "(#") (EpToken "#)")+  | NameBackquotes (EpToken "`")  (EpToken "`")+  | NameSquare     (EpToken "[")  (EpToken "]")+  | NameNoAdornment+  deriving (Eq, Data)+++-- ---------------------------------------------------------------------++-- | exact print annotation used for capturing the locations of+-- annotations in pragmas.+data AnnPragma+  = AnnPragma {+      apr_open      :: EpaLocation,+      apr_close     :: EpToken "#-}",+      apr_squares   :: (EpToken "[", EpToken "]"),+      apr_loc1      :: EpaLocation,+      apr_loc2      :: EpaLocation,+      apr_type      :: EpToken "type",+      apr_module    :: EpToken "module"+      } deriving (Data,Eq)++-- ---------------------------------------------------------------------++-- | Captures the sort order of sub elements for `ValBinds`,+-- `ClassDecl`, `ClsInstDecl`+data AnnSortKey tag+  -- See Note [AnnSortKey] below+  = NoAnnSortKey+  | AnnSortKey [tag]+  deriving (Data, Eq)++-- | Used to track of interleaving of binds and signatures for ValBind+data BindTag+  -- See Note [AnnSortKey] below+  = BindTag+  | SigDTag+  deriving (Eq,Data,Ord,Show)++-- | Used to track interleaving of class methods, class signatures,+-- associated types and associate type defaults in `ClassDecl` and+-- `ClsInstDecl`.+data DeclTag+  -- See Note [AnnSortKey] below+  = ClsMethodTag+  | ClsSigTag+  | ClsAtTag+  | ClsAtdTag+  deriving (Eq,Data,Ord,Show)++{-+Note [AnnSortKey]+~~~~~~~~~~~~~~~~~++For some constructs in the ParsedSource we have mixed lists of items+that can be freely intermingled.++An example is the binds in a where clause, captured in++    ValBinds+        (XValBinds idL idR)+        (LHsBindsLR idL idR) [LSig idR]++This keeps separate ordered collections of LHsBind GhcPs and LSig GhcPs.++But there is no constraint on the original source code as to how these+should appear, so they can have all the signatures first, then their+binds, or grouped with a signature preceding each bind.++   fa :: Int+   fa = 1++   fb :: Char+   fb = 'c'++Or++   fa :: Int+   fb :: Char++   fb = 'c'+   fa = 1++When exact printing these, we need to restore the original order. As+initially parsed we have the SrcSpan, and can sort on those. But if we+have modified the AST prior to printing, we cannot rely on the+SrcSpans for order any more.++The bag of LHsBind GhcPs is physically ordered, as is the list of LSig+GhcPs. So in effect we have a list of binds in the order we care+about, and a list of sigs in the order we care about. The only problem+is to know how to merge the lists.++This is where AnnSortKey comes in, which we store in the TTG extension+point for ValBinds.++    data AnnSortKey tag+      = NoAnnSortKey+      | AnnSortKey [tag]++When originally parsed, with SrcSpans we can rely on, we do not need+any extra information, so we tag it with NoAnnSortKey.++If the binds and signatures are updated in any way, such that we can+no longer rely on their SrcSpans (e.g. they are copied from elsewhere,+parsed from scratch for insertion, have a fake SrcSpan), we use+`AnnSortKey [BindTag]` to keep track.++    data BindTag+      = BindTag+      | SigDTag++We use it as a merge selector, and have one entry for each bind and+signature.++So for the first example we have++  binds: fa = 1 , fb = 'c'+  sigs:  fa :: Int, fb :: Char+  tags: SigDTag, BindTag, SigDTag, BindTag++so we draw first from the signatures, then the binds, and same again.++For the second example we have++  binds: fb = 'c', fa = 1+  sigs:  fa :: Int, fb :: Char+  tags: SigDTag, SigDTag, BindTag, BindTag++so we draw two signatures, then two binds.++We do similar for ClassDecl and ClsInstDecl, but we have four+different lists we must manage. For this we use DeclTag.++-}++-- ---------------------------------------------------------------------++-- | Helper function used in the parser to add a 'TrailingAnn' items+-- to an existing annotation.+addTrailingAnnToL :: TrailingAnn -> EpAnnComments+                  -> EpAnn (AnnList a) -> EpAnn (AnnList a)+addTrailingAnnToL t cs n = n { anns = addTrailing (anns n)+                               , comments = comments n <> cs }+  where+    -- See Note [list append in addTrailing*]+    addTrailing n = n { al_trailing = al_trailing n ++ [t]}++-- | Helper function used in the parser to add a 'TrailingAnn' items+-- to an existing annotation.+addTrailingAnnToA :: TrailingAnn -> EpAnnComments+                  -> EpAnn AnnListItem -> EpAnn AnnListItem+addTrailingAnnToA t cs n = n { anns = addTrailing (anns n)+                               , comments = comments n <> cs }+  where+    -- See Note [list append in addTrailing*]+    addTrailing n = n { lann_trailing = lann_trailing n ++ [t] }++-- | Helper function used in the parser to add a comma location to an+-- existing annotation.+addTrailingCommaToN :: EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn+addTrailingCommaToN  n l = n { anns = addTrailing (anns n) l }+  where+    -- See Note [list append in addTrailing*]+    addTrailing :: NameAnn -> EpaLocation -> NameAnn+    addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn (EpTok l)]}++noTrailingN :: SrcSpanAnnN -> SrcSpanAnnN+noTrailingN s = s { anns = (anns s) { nann_trailing = [] } }++{-+Note [list append in addTrailing*]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN+functions are used to add a separator for an item when it occurs in a+list.  So they are used to capture a comma, vbar, semicolon and similar.++In general, a given element will have zero or one of these.  In+extreme (test) cases, there may be multiple semicolons.++In exact printing we sometimes convert the EpaLocation variant for an+trailing annotation to the EpaDelta variant, which cannot be sorted.++Hence it is critical that these annotations are captured in the order+they appear in the original source file.++And so we use the less efficient list append to preserve the order,+knowing that in most cases the original list is empty.+-}++-- ---------------------------------------------------------------------++-- |Helper function for converting annotation types.+--  Discards any annotations+l2l :: (HasLoc a, HasAnnotation b) => a -> b+l2l a = noAnnSrcSpan (getHasLoc a)++-- |Helper function for converting annotation types.+--  Discards any annotations+la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a+la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a++locA :: (HasLoc a) => a -> SrcSpan+locA = getHasLoc++reLoc :: (HasLoc (GenLocated a e), HasAnnotation b)+      => GenLocated a e -> GenLocated b e+reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a+++-- ---------------------------------------------------------------------++class HasAnnotation e where+  noAnnSrcSpan :: SrcSpan -> e++instance HasAnnotation SrcSpan where+  noAnnSrcSpan l = l++instance HasAnnotation EpaLocation where+  noAnnSrcSpan l = EpaSpan l++instance (NoAnn ann) => HasAnnotation (EpAnn ann) where+  noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments++noLocA :: (HasAnnotation e) => a -> GenLocated e a+noLocA = L (noAnnSrcSpan noSrcSpan)++getLocA :: (HasLoc a) => GenLocated a e -> SrcSpan+getLocA = getHasLoc++noSrcSpanA :: (HasAnnotation e) => e+noSrcSpanA = noAnnSrcSpan noSrcSpan++-- ---------------------------------------------------------------------++class NoAnn a where+  -- | equivalent of `mempty`, but does not need Semigroup+  noAnn :: a++-- ---------------------------------------------------------------------++class HasLoc a where+  -- ^ conveniently calculate locations for things without locations attached+  getHasLoc :: a -> SrcSpan++instance (HasLoc l) => HasLoc (GenLocated l a) where+  getHasLoc (L l _) = getHasLoc l++instance HasLoc SrcSpan where+  getHasLoc l = l++instance (HasLoc a) => (HasLoc (Maybe a)) where+  getHasLoc (Just a) = getHasLoc a+  getHasLoc Nothing = noSrcSpan++instance HasLoc (EpAnn a) where+  getHasLoc (EpAnn l _ _) = getHasLoc l++instance HasLoc EpaLocation where+  getHasLoc (EpaSpan l) = l+  getHasLoc (EpaDelta l _ _) = l++instance HasLoc (EpToken tok) where+  getHasLoc = getEpTokenSrcSpan++instance HasLoc (EpUniToken tok utok) where+  getHasLoc NoEpUniTok = noSrcSpan+  getHasLoc (EpUniTok l _) = getHasLoc l++getHasLocList :: HasLoc a => [a] -> SrcSpan+getHasLocList = foldl1WithDefault' noSrcSpan combineSrcSpans . map getHasLoc++-- ---------------------------------------------------------------------++realSrcSpan :: SrcSpan -> RealSrcSpan+realSrcSpan (RealSrcSpan s _) = s+realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary+  where+    l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)++srcSpan2e :: SrcSpan -> EpaLocation+srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss+srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing)++getLocAnn :: Located a  -> SrcSpanAnnA+getLocAnn (L l _) = noAnnSrcSpan l++-- AZ:TODO use widenSpan here too+addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA+addAnnsA (EpAnn l as1 cs) as2 cs2+  = EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)++-- | The annotations need to all come after the anchor.  Make sure+-- this is the case.+widenSpanL :: SrcSpan -> [EpaLocation] -> SrcSpan+widenSpanL s as = foldl combineSrcSpans s (go as)+  where+    go [] = []+    go ((EpaSpan (RealSrcSpan s mb):rest)) = RealSrcSpan s mb : go rest+    go ((EpaSpan _):rest) = go rest+    go ((EpaDelta _ _ _):rest) = go rest++widenSpanT :: SrcSpan -> EpToken tok -> SrcSpan+widenSpanT l (EpTok loc) = widenSpanL l [loc]+widenSpanT l NoEpTok = l++listLocation :: [LocatedAn an a] -> EpaLocation+listLocation as = EpaSpan (go noSrcSpan as)+  where+    combine l r = combineSrcSpans l r++    go acc [] = acc+    go acc (L (EpAnn (EpaSpan s) _ _) _:rest) = go (combine acc s) rest+    go acc (_:rest) = go acc rest++widenAnchorT :: EpaLocation -> EpToken tok -> EpaLocation+widenAnchorT (EpaSpan ss) (EpTok l) = widenAnchorS l ss+widenAnchorT ss _ = ss++widenAnchorS :: EpaLocation -> SrcSpan -> EpaLocation+widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr)+  = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr))+widenAnchorS (EpaSpan us) _ = EpaSpan us+widenAnchorS EpaDelta{} (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb)+widenAnchorS anc _ = anc++widenLocatedAnL :: EpAnn an -> [EpaLocation] -> EpAnn an+widenLocatedAnL (EpAnn (EpaSpan l) a cs) as = EpAnn (spanAsAnchor l') a cs+  where+    l' = widenSpanL l as+widenLocatedAnL (EpAnn anc a cs) _as = EpAnn anc a cs++epAnnComments :: EpAnn an -> EpAnnComments+epAnnComments (EpAnn _ _ cs) = cs++-- ---------------------------------------------------------------------+sortLocatedA :: (HasLoc (EpAnn a)) => [GenLocated (EpAnn a) e] -> [GenLocated (EpAnn a) e]+sortLocatedA = sortBy (leftmost_smallest `on` getLocA)++mapLocA :: (NoAnn ann) => (a -> b) -> GenLocated SrcSpan a -> GenLocated (EpAnn ann) b+mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)++-- AZ:TODO: move this somewhere sane+combineLocsA :: Semigroup a => GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a+combineLocsA (L a _) (L b _) = combineSrcSpansA a b++combineSrcSpansA :: Semigroup a => EpAnn a -> EpAnn a -> EpAnn a+combineSrcSpansA aa ab = aa <> ab++-- | Combine locations from two 'Located' things and add them to a third thing+addCLocA :: (HasLoc a, HasLoc b, HasAnnotation l)+         => a -> b -> c -> GenLocated l c+addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (getHasLoc a) (getHasLoc b)) c++-- ---------------------------------------------------------------------+-- Utilities for manipulating EpAnnComments+-- ---------------------------------------------------------------------++getFollowingComments :: EpAnnComments -> [LEpaComment]+getFollowingComments (EpaComments _) = []+getFollowingComments (EpaCommentsBalanced _ cs) = cs++setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+setFollowingComments (EpaComments ls) cs           = EpaCommentsBalanced ls cs+setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs++setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+setPriorComments (EpaComments _) cs            = EpaComments cs+setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts++-- ---------------------------------------------------------------------+-- Comment-only annotations+-- ---------------------------------------------------------------------++type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only++data NoEpAnns = NoEpAnns+  deriving (Data,Eq,Ord)++noComments ::EpAnnCO+noComments = EpAnn noSpanAnchor NoEpAnns emptyComments++-- TODO:AZ get rid of this+placeholderRealSpan :: RealSrcSpan+placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1))++comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO+comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs++-- ---------------------------------------------------------------------+-- Utilities for managing comments in an `EpAnn a` structure.+-- ---------------------------------------------------------------------++-- | Add additional comments to a 'EpAnn', used for manipulating the+-- AST prior to exact printing the changed one.+addCommentsToEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann+addCommentsToEpAnn (EpAnn a an cs) cs' = EpAnn a an (cs <> cs')++-- | Replace any existing comments on a 'EpAnn', used for manipulating the+-- AST prior to exact printing the changed one.+setCommentsEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann+setCommentsEpAnn (EpAnn a an _) cs = (EpAnn a an cs)++-- | Transfer comments and trailing items from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferAnnsA (EpAnn a an cs) (EpAnn a' an' cs')+  = (EpAnn a noAnn emptyComments, EpAnn a' (an' <> an) (cs' <> cs))++-- | Transfer trailing items but not comments from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferFollowingA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferFollowingA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2)+  = (EpAnn a1 noAnn cs1', EpAnn a2 (an1 <> an2) cs2')+  where+    pc = priorComments cs1+    fc = getFollowingComments cs1+    cs1' = setPriorComments emptyComments pc+    cs2' = setFollowingComments cs2 fc++-- | Transfer trailing items from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')+  = (EpAnn a noAnn cs, EpAnn a' (an' <> an) cs')++-- | Transfer comments from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a,  EpAnn b)+transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')+  = (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs'))++-- | Transfer prior comments only from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferPriorCommentsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferPriorCommentsA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2)+  = (EpAnn a1 an1 cs1', EpAnn a2 an2 cs2')+  where+    pc = priorComments cs1+    fc = getFollowingComments cs1+    cs1' = setFollowingComments emptyComments fc+    cs2' = setPriorComments cs2 (priorComments cs2 <> pc)++-- ---------------------------------------------------------------------+-- Semigroup instances, to allow easy combination of annotation elements+-- ---------------------------------------------------------------------++instance (Semigroup a) => Semigroup (EpAnn a) where+  (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2)+   -- The critical part about the anchor is its left edge, and all+   -- annotations must follow it. So we combine them which yields the+   -- largest span++instance Semigroup EpaLocation where+  EpaSpan s1       <> EpaSpan s2        = EpaSpan (combineSrcSpans s1 s2)+  EpaSpan s1       <> _                 = EpaSpan s1+  _                <> EpaSpan s2        = EpaSpan s2+  EpaDelta s1 dp1 cs1 <> EpaDelta s2 _dp2 cs2 = EpaDelta (combineSrcSpans s1 s2) dp1 (cs1<>cs2)++instance Semigroup EpAnnComments where+  EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2)+  EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2+  EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1+  EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2)++instance Semigroup AnnListItem where+  (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)++instance Semigroup (AnnSortKey tag) where+  NoAnnSortKey <> x = x+  x <> NoAnnSortKey = x+  AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)++instance Monoid (AnnSortKey tag) where+  mempty = NoAnnSortKey++-- ---------------------------------------------------------------------+-- NoAnn instances+-- ---------------------------------------------------------------------++instance NoAnn EpaLocation where+  noAnn = EpaDelta noSrcSpan (SameLine 0) []++instance NoAnn [a] where+  noAnn = []++instance NoAnn (Maybe a) where+  noAnn = Nothing++instance NoAnn a => NoAnn (Either a b) where+  noAnn = Left noAnn++instance (NoAnn a, NoAnn b) => NoAnn (a, b) where+  noAnn = (noAnn, noAnn)++instance (NoAnn a, NoAnn b, NoAnn c) => NoAnn (a, b, c) where+  noAnn = (noAnn, noAnn, noAnn)++instance (NoAnn a, NoAnn b, NoAnn c, NoAnn d) => NoAnn (a, b, c, d) where+  noAnn = (noAnn, noAnn, noAnn, noAnn)++instance NoAnn Bool where+  noAnn = False++instance NoAnn () where+  noAnn = ()++instance (NoAnn ann) => NoAnn (EpAnn ann) where+  noAnn = EpAnn noSpanAnchor noAnn emptyComments++instance NoAnn NoEpAnns where+  noAnn = NoEpAnns++instance NoAnn AnnListItem where+  noAnn = AnnListItem []++instance NoAnn AnnContext where+  noAnn = AnnContext Nothing [] []++instance NoAnn a => NoAnn (AnnList a) where+  noAnn = AnnList Nothing ListNone noAnn noAnn []++instance NoAnn NameAnn where+  noAnn = NameAnnTrailing []++instance NoAnn AnnPragma where+  noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn++instance NoAnn AnnParen where+  noAnn = AnnParens noAnn noAnn++instance NoAnn (EpToken s) where+  noAnn = NoEpTok++instance NoAnn (EpUniToken s t) where+  noAnn = NoEpUniTok++instance NoAnn SourceText where+  noAnn = NoSourceText++-- ---------------------------------------------------------------------++instance (Outputable a) => Outputable (EpAnn a) where+  ppr (EpAnn l a c)  = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c++instance Outputable NoEpAnns where+  ppr NoEpAnns = text "NoEpAnns"++instance Outputable (GenLocated NoCommentsLocation EpaComment) where+  ppr (L l c) = text "L" <+> ppr l <+> ppr c++instance Outputable EpAnnComments where+  ppr (EpaComments cs) = text "EpaComments" <+> ppr cs+  ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts++instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where+  getName (L l a) = getName (L (locA l) a)++instance Outputable AnnContext where+  ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c++instance Outputable BindTag where+  ppr tag = text $ show tag++instance Outputable DeclTag where+  ppr tag = text $ show tag++instance Outputable tag => Outputable (AnnSortKey tag) where+  ppr NoAnnSortKey    = text "NoAnnSortKey"+  ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls++instance Outputable IsUnicodeSyntax where+  ppr = text . show++instance (Outputable a, Outputable e)+     => Outputable (GenLocated (EpAnn a) e) where+  ppr = pprLocated++instance (Outputable a, OutputableBndr e)+     => OutputableBndr (GenLocated (EpAnn a) e) where+  pprInfixOcc = pprInfixOcc . unLoc+  pprPrefixOcc = pprPrefixOcc . unLoc++instance (Outputable e)+     => Outputable (GenLocated EpaLocation e) where+  ppr = pprLocated++instance Outputable AnnParen where+  ppr (AnnParens       o c) = text "AnnParens" <+> ppr o <+> ppr c+  ppr (AnnParensHash   o c) = text "AnnParensHash" <+> ppr o <+> ppr c+  ppr (AnnParensSquare o c) = text "AnnParensSquare" <+> ppr o <+> ppr c++instance Outputable AnnListItem where+  ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts++instance Outputable NameAdornment where+  ppr (NameParens     o c) = text "NameParens" <+> ppr o <+> ppr c+  ppr (NameParensHash o c) = text "NameParensHash" <+> ppr o <+> ppr c+  ppr (NameBackquotes o c) = text "NameBackquotes" <+> ppr o <+> ppr c+  ppr (NameSquare     o c) = text "NameSquare" <+> ppr o <+> ppr c+  ppr NameNoAdornment      = text "NameNoAdornment"++instance Outputable NameAnn where+  ppr (NameAnn a n t)+    = text "NameAnn" <+> ppr a <+> ppr n <+> ppr t+  ppr (NameAnnCommas a n t)+    = text "NameAnnCommas" <+> ppr a <+> ppr n <+> ppr t+  ppr (NameAnnBars a n t)+    = text "NameAnnBars" <+> ppr a <+> ppr n <+> ppr t+  ppr (NameAnnOnly a t)+    = text "NameAnnOnly" <+> ppr a <+> ppr t+  ppr (NameAnnRArrow o n c t)+    = text "NameAnnRArrow" <+> ppr o <+> ppr n <+> ppr c <+> ppr t+  ppr (NameAnnQuote q n t)+    = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t+  ppr (NameAnnTrailing t)+    = text "NameAnnTrailing" <+> ppr t++instance (Outputable a) => Outputable (AnnList a) where+  ppr (AnnList anc p s a t)+    = text "AnnList" <+> ppr anc <+> ppr p <+> ppr s <+> ppr a <+> ppr t++instance Outputable AnnListBrackets where+  ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c+  ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c+  ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c+  ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c+  ppr ListNone         = text "ListNone"++instance Outputable AnnPragma where+  ppr (AnnPragma o c s l ca t m)+    = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l+                       <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m
compiler/GHC/Parser/CharClass.hs view
@@ -36,7 +36,7 @@  {-# INLINABLE is_ctype #-} is_ctype :: Word8 -> Char -> Bool-is_ctype mask c = (charType c .&. mask) /= 0+is_ctype mask c = c <= '\127' && (charType c .&. mask) /= 0  is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit,     is_alphanum :: Char -> Bool
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -22,27 +23,28 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Data.FastString import GHC.Data.Maybe (catMaybes)-import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)-import GHC.Hs.Type (pprLHsContext)+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)+import GHC.Hs.Extension+import GHC.Parser.Annotation (noAnn)   instance Diagnostic PsMessage where   type DiagnosticOpts PsMessage = NoDiagnosticOpts-  defaultDiagnosticOpts = NoDiagnosticOpts-  diagnosticMessage _ = \case-    PsUnknownMessage (UnknownDiagnostic @e m)-      -> diagnosticMessage (defaultDiagnosticOpts @e) m+  diagnosticMessage opts = \case+    PsUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m      PsHeaderMessage m       -> psHeaderMessageDiagnostic m@@ -121,7 +123,32 @@       -> mkSimpleDecorated $             text "Found" <+> quotes (text "qualified")              <+> text "in prepositive position"+    PsWarnViewPatternSignatures old new+      -> mkDecorated $+          [ text "Found an unparenthesized pattern signature on the RHS of a view pattern."+          , vcat [ text "This code might stop working in a future GHC release"+                 , text "due to a planned change to the precedence of view patterns,"+                 , text "unless the view function is an endofunction." ]+          , nest 2 $+            vcat [ text "Current parse:" <+> quotes (ppr (add_parens_sig old))+                 , text "Future parse:" <+> quotes (ppr (add_parens_view new)) ]+          ]+      where+        add_parens_sig :: LPat GhcPs -> LPat GhcPs+        add_parens_sig = go+          where go (L l (ViewPat x e p)) = L l (ViewPat x e (go p))+                go (L l (SigPat x p sig)) = par_pat (L l (SigPat x p sig))+                go p = p +        add_parens_view :: LPat GhcPs -> LPat GhcPs+        add_parens_view = go+          where go (L l (ViewPat x e p)) = par_pat (L l (ViewPat x e p))+                go (L l (SigPat x p sig)) = L l (SigPat x (go p) sig)+                go p = p++        par_pat :: LPat GhcPs -> LPat GhcPs+        par_pat p = L noAnn (ParPat noAnn p)+     PsErrLexer err kind       -> mkSimpleDecorated $ hcat            [ case err of@@ -129,8 +156,6 @@               LexUnknownPragma       -> text "unknown pragma"               LexErrorInPragma       -> text "lexical error in pragma"               LexNumEscapeRange      -> text "numeric escape sequence out of range"-              LexStringCharLit       -> text "lexical error in string/character literal"-              LexStringCharLitEOF    -> text "unexpected end-of-file in string/character literal"               LexUnterminatedComment -> text "unterminated `{-'"               LexUnterminatedOptions -> text "unterminated OPTIONS pragma"               LexUnterminatedQQ      -> text "unterminated quasiquotation"@@ -202,7 +227,7 @@              NumUnderscore_Integral -> "Illegal underscores in integer literals"              NumUnderscore_Float    -> "Illegal underscores in floating literals"     PsErrIllegalBangPattern e-      -> mkSimpleDecorated $ text "Illegal bang-pattern" $$ ppr e+      -> mkSimpleDecorated $ text "Illegal bang-pattern or strict binding" $$ ppr e     PsErrOverloadedRecordDotInvalid       -> mkSimpleDecorated $            text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"@@ -248,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@@ -262,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"@@ -328,16 +360,12 @@       -> mkSimpleDecorated $ text "do-notation in pattern"     PsErrIfThenElseInPat       -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"-    (PsErrLambdaCaseInPat lc_variant)-      -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern"     PsErrCaseInPat       -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"     PsErrLetInPat       -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern"-    PsErrLambdaInPat-      -> mkSimpleDecorated $-           text "Lambda-syntax in pattern."-           $$ text "Pattern matching on functions is not possible."+    PsErrLambdaInPat lam_variant+      -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword lam_variant <> text "-syntax in pattern"     PsErrArrowExprInPat e       -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e     PsErrArrowCmdInPat c@@ -348,18 +376,16 @@            [ text "Arrow command found where an expression was expected:"            , nest 2 (ppr c)            ]-    PsErrViewPatInExpr a b+    PsErrOrPatInExpr p       -> mkSimpleDecorated $-           sep [ text "View pattern in expression context:"-               , nest 4 (ppr a <+> text "->" <+> ppr b)+           sep [ text "Or pattern in expression context:"+               , nest 4 (ppr p)                ]-    PsErrLambdaCmdInFunAppCmd a-      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a     PsErrCaseCmdInFunAppCmd a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a-    PsErrLambdaCaseCmdInFunAppCmd lc_variant a+    PsErrLambdaCmdInFunAppCmd lam_variant a       -> mkSimpleDecorated $-           pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a+           pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "command") a     PsErrIfCmdInFunAppCmd a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a     PsErrLetCmdInFunAppCmd a@@ -370,12 +396,10 @@       -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a     PsErrMDoInFunAppExpr m a       -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a-    PsErrLambdaInFunAppExpr a-      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a     PsErrCaseInFunAppExpr a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a-    PsErrLambdaCaseInFunAppExpr lc_variant a-      -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a+    PsErrLambdaInFunAppExpr lam_variant a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "expression") a     PsErrLetInFunAppExpr a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a     PsErrIfInFunAppExpr a@@ -395,7 +419,8 @@       -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'"     PsErrSuffixAT       -> mkSimpleDecorated $-           text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."+           text "The symbol '@' occurs as a suffix." $$+           text "For an as-pattern, there must not be any whitespace surrounding '@'."     PsErrPrecedenceOutOfRange i       -> mkSimpleDecorated $ text "Precedence out of range: " <> int i     PsErrSemiColonsInCondExpr c st t se e@@ -430,14 +455,6 @@       -> mkSimpleDecorated $            text "Malformed" <+> what            <+> text "declaration for" <+> quotes (ppr for)-    PsErrUnexpectedTypeAppInDecl ki what for-      -> mkSimpleDecorated $-           vcat [ text "Unexpected type application"-                  <+> text "@" <> ppr ki-                , text "In the" <+> what-                  <+> text "declaration for"-                  <+> quotes (ppr for)-                ]     PsErrNotADataCon name       -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name)     PsErrInferredTypeVarNotAllowed@@ -451,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)@@ -471,28 +482,29 @@     PsErrIllegalRoleName role _nearby       -> mkSimpleDecorated $            text "Illegal role name" <+> quotes (ppr role)-    PsErrInvalidTypeSignature lhs-      -> mkSimpleDecorated $-           text "Invalid type signature:"-           <+> ppr lhs-           <+> text ":: ..."+    PsErrInvalidTypeSignature reason lhs+      -> mkSimpleDecorated $ case reason of+           PsErrInvalidTypeSig_DataCon   -> text "Invalid data constructor" <+> quotes (ppr lhs) <+>+                                            text "in type signature" <> colon $$+                                            text "You can only define data constructors in data type declarations."+           PsErrInvalidTypeSig_Qualified -> text "Invalid qualified name in type signature."+           PsErrInvalidTypeSig_Other     -> text "Invalid type signature" <> colon $$+                                            text "A type signature should be of form" <+>+                                            placeHolder "variables" <+> dcolon <+> placeHolder "type" <>+                                            dot+            where placeHolder = angleBrackets . text     PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where        -> 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)@@ -523,7 +535,50 @@                 , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma                 , text "but it is not" ] -  diagnosticReason = \case+    PsErrInvalidPun PEP_QuoteDisambiguation+      -> mkSimpleDecorated $ vcat+        [ text "Disambiguating data constructors of tuples and lists is disabled."+        , text "Remove the quote to use the data constructor."+        ]++    PsErrInvalidPun PEP_TupleSyntaxType+      -> mkSimpleDecorated $ vcat+        [ text "Unboxed tuple data constructors are not supported in types."+        , text "Use" <+> quotes (text "Tuple<n># a b c ...") <+> text "to refer to the type constructor."+        ]++    PsErrInvalidPun PEP_SumSyntaxType+      -> mkSimpleDecorated $ vcat+        [ text "Unboxed sum data constructors are not supported in types."+        , text "Use" <+> quotes (text "Sum<n># a b c ...") <+> text "to refer to the type constructor."+        ]+    PsErrTypeSyntaxInPat ctx+      -> mkSimpleDecorated $ vcat+        [ text "Illegal" <+> text what <+> "in pattern:" <+> quotes ctx'+        , text "Type syntax in patterns isn't supported at the time"]+        where+          (what, ctx') = case ctx of+            PETS_FunctionArrow arg arr res -> ("function arrow", ppr arg <+> pprHsArrow arr <+> ppr res)+            PETS_Multiplicity tok p        -> ("multiplicity annotation", ppr tok <> ppr p)+            PETS_ForallTelescope tele body -> ("forall telescope", pprHsForAll tele Nothing <+> ppr body)+            PETS_ConstraintContext ctx     -> ("constraint context", ppr ctx)++    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     PsWarnBidirectionalFormatChars{}              -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters@@ -538,6 +593,7 @@     PsWarnUnrecognisedPragma{}                    -> WarningWithFlag Opt_WarnUnrecognisedPragmas     PsWarnMisplacedPragma{}                       -> WarningWithFlag Opt_WarnMisplacedPragmas     PsWarnImportPreQualified                      -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule+    PsWarnViewPatternSignatures{}                 -> WarningWithFlag Opt_WarnViewPatternSignatures     PsErrLexer{}                                  -> ErrorWithoutFlag     PsErrCmmLexer                                 -> ErrorWithoutFlag     PsErrCmmParser{}                              -> ErrorWithoutFlag@@ -568,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@@ -593,17 +650,15 @@     PsErrIllegalUnboxedFloatingLitInPat{}         -> ErrorWithoutFlag     PsErrDoNotationInPat{}                        -> ErrorWithoutFlag     PsErrIfThenElseInPat                          -> ErrorWithoutFlag-    PsErrLambdaCaseInPat{}                        -> ErrorWithoutFlag     PsErrCaseInPat                                -> ErrorWithoutFlag     PsErrLetInPat                                 -> ErrorWithoutFlag-    PsErrLambdaInPat                              -> ErrorWithoutFlag+    PsErrLambdaInPat{}                            -> ErrorWithoutFlag     PsErrArrowExprInPat{}                         -> ErrorWithoutFlag     PsErrArrowCmdInPat{}                          -> ErrorWithoutFlag     PsErrArrowCmdInExpr{}                         -> ErrorWithoutFlag-    PsErrViewPatInExpr{}                          -> ErrorWithoutFlag-    PsErrLambdaCmdInFunAppCmd{}                   -> ErrorWithoutFlag+    PsErrOrPatInExpr{}                            -> ErrorWithoutFlag     PsErrCaseCmdInFunAppCmd{}                     -> ErrorWithoutFlag-    PsErrLambdaCaseCmdInFunAppCmd{}               -> ErrorWithoutFlag+    PsErrLambdaCmdInFunAppCmd{}                   -> ErrorWithoutFlag     PsErrIfCmdInFunAppCmd{}                       -> ErrorWithoutFlag     PsErrLetCmdInFunAppCmd{}                      -> ErrorWithoutFlag     PsErrDoCmdInFunAppCmd{}                       -> ErrorWithoutFlag@@ -611,7 +666,6 @@     PsErrMDoInFunAppExpr{}                        -> ErrorWithoutFlag     PsErrLambdaInFunAppExpr{}                     -> ErrorWithoutFlag     PsErrCaseInFunAppExpr{}                       -> ErrorWithoutFlag-    PsErrLambdaCaseInFunAppExpr{}                 -> ErrorWithoutFlag     PsErrLetInFunAppExpr{}                        -> ErrorWithoutFlag     PsErrIfInFunAppExpr{}                         -> ErrorWithoutFlag     PsErrProcInFunAppExpr{}                       -> ErrorWithoutFlag@@ -626,7 +680,6 @@     PsErrAtInPatPos                               -> ErrorWithoutFlag     PsErrParseErrorOnInput{}                      -> ErrorWithoutFlag     PsErrMalformedDecl{}                          -> ErrorWithoutFlag-    PsErrUnexpectedTypeAppInDecl{}                -> ErrorWithoutFlag     PsErrNotADataCon{}                            -> ErrorWithoutFlag     PsErrInferredTypeVarNotAllowed                -> ErrorWithoutFlag     PsErrIllegalTraditionalRecordSyntax{}         -> ErrorWithoutFlag@@ -641,6 +694,12 @@     PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag     PsErrMultipleConForNewtype {}                 -> ErrorWithoutFlag     PsErrUnicodeCharLooksLike{}                   -> ErrorWithoutFlag+    PsErrInvalidPun {}                            -> ErrorWithoutFlag+    PsErrIllegalOrPat{}                           -> ErrorWithoutFlag+    PsErrTypeSyntaxInPat{}                        -> ErrorWithoutFlag+    PsErrSpecExprMultipleTypeAscription{}         -> ErrorWithoutFlag+    PsWarnSpecMultipleTypeAscription{}            -> WarningWithFlag Opt_WarnDeprecatedPragmas+    PsWarnPatternNamespaceSpecifier{}             -> WarningWithFlag Opt_WarnPatternNamespaceSpecifier    diagnosticHints = \case     PsUnknownMessage m                            -> diagnosticHints m@@ -663,6 +722,7 @@     PsWarnMisplacedPragma{}                       -> [SuggestPlacePragmaInHeader]     PsWarnImportPreQualified                      -> [ SuggestQualifiedAfterModuleName                                                      , suggestExtension LangExt.ImportQualifiedPost]+    PsWarnViewPatternSignatures{}                 -> [SuggestParenthesizePatternRHS]     PsErrLexer{}                                  -> noHints     PsErrCmmLexer                                 -> noHints     PsErrCmmParser{}                              -> noHints@@ -694,10 +754,8 @@     PsErrOverloadedRecordDotInvalid{}             -> noHints     PsErrIllegalPatSynExport                      -> [suggestExtension LangExt.PatternSynonyms]     PsErrOverloadedRecordUpdateNoQualifiedFields  -> noHints-    PsErrExplicitForall is_unicode                ->-      let info = text "or a similar language extension to enable explicit-forall syntax:" <+>-                 forallSym is_unicode <+> text "<tvs>. <type>"-      in [ suggestExtensionWithInfo info LangExt.RankNTypes ]+    PsErrExplicitForall is_unicode                -> [useExtensionInOrderTo info LangExt.ExplicitForAll]+      where info = "to enable syntax:" <+> forallSym is_unicode <+> angleBrackets "tvs" <> dot <+> angleBrackets "type"     PsErrIllegalQualifiedDo{}                     -> [suggestExtension LangExt.QualifiedDo]     PsErrQualifiedDoInCmd{}                       -> noHints     PsErrRecordSyntaxInPatSynDecl{}               -> noHints@@ -706,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@@ -732,17 +791,15 @@     PsErrIllegalUnboxedFloatingLitInPat{}         -> noHints     PsErrDoNotationInPat{}                        -> noHints     PsErrIfThenElseInPat                          -> noHints-    PsErrLambdaCaseInPat{}                        -> noHints     PsErrCaseInPat                                -> noHints     PsErrLetInPat                                 -> noHints-    PsErrLambdaInPat                              -> noHints+    PsErrLambdaInPat{}                            -> noHints     PsErrArrowExprInPat{}                         -> noHints     PsErrArrowCmdInPat{}                          -> noHints     PsErrArrowCmdInExpr{}                         -> noHints-    PsErrViewPatInExpr{}                          -> noHints+    PsErrOrPatInExpr{}                            -> noHints     PsErrLambdaCmdInFunAppCmd{}                   -> suggestParensAndBlockArgs     PsErrCaseCmdInFunAppCmd{}                     -> suggestParensAndBlockArgs-    PsErrLambdaCaseCmdInFunAppCmd{}               -> suggestParensAndBlockArgs     PsErrIfCmdInFunAppCmd{}                       -> suggestParensAndBlockArgs     PsErrLetCmdInFunAppCmd{}                      -> suggestParensAndBlockArgs     PsErrDoCmdInFunAppCmd{}                       -> suggestParensAndBlockArgs@@ -750,14 +807,11 @@     PsErrMDoInFunAppExpr{}                        -> suggestParensAndBlockArgs     PsErrLambdaInFunAppExpr{}                     -> suggestParensAndBlockArgs     PsErrCaseInFunAppExpr{}                       -> suggestParensAndBlockArgs-    PsErrLambdaCaseInFunAppExpr{}                 -> suggestParensAndBlockArgs     PsErrLetInFunAppExpr{}                        -> suggestParensAndBlockArgs     PsErrIfInFunAppExpr{}                         -> suggestParensAndBlockArgs     PsErrProcInFunAppExpr{}                       -> suggestParensAndBlockArgs     PsErrMalformedTyOrClDecl{}                    -> noHints-    PsErrIllegalWhereInDataDecl                   ->-      [ suggestExtensionWithInfo (text "or a similar language extension to enable syntax: data T where")-                                 LangExt.GADTs ]+    PsErrIllegalWhereInDataDecl                   -> [useExtensionInOrderTo "to enable syntax: data T where" LangExt.GADTSyntax]     PsErrIllegalDataTypeContext{}                 -> [suggestExtension LangExt.DatatypeContexts]     PsErrPrimStringInvalidChar                    -> noHints     PsErrSuffixAT                                 -> noHints@@ -767,7 +821,6 @@     PsErrAtInPatPos                               -> noHints     PsErrParseErrorOnInput{}                      -> noHints     PsErrMalformedDecl{}                          -> noHints-    PsErrUnexpectedTypeAppInDecl{}                -> noHints     PsErrNotADataCon{}                            -> noHints     PsErrInferredTypeVarNotAllowed                -> noHints     PsErrIllegalTraditionalRecordSyntax{}         -> [suggestExtension LangExt.TraditionalRecordSyntax]@@ -784,15 +837,17 @@         sug_missingdo _                                     = Nothing     PsErrParseRightOpSectionInPat{}               -> noHints     PsErrIllegalRoleName _ nearby                 -> [SuggestRoles nearby]-    PsErrInvalidTypeSignature lhs                 ->+    PsErrInvalidTypeSignature reason lhs          ->         if | foreign_RDR `looks_like` lhs            -> [suggestExtension LangExt.ForeignFunctionInterface]            | default_RDR `looks_like` lhs            -> [suggestExtension LangExt.DefaultSignatures]            | pattern_RDR `looks_like` lhs            -> [suggestExtension LangExt.PatternSynonyms]+           | PsErrInvalidTypeSig_Qualified <- reason+           -> [SuggestTypeSignatureRemoveQualifier]            | otherwise-           -> [SuggestTypeSignatureForm]+           -> []       where         -- A common error is to forget the ForeignFunctionInterface flag         -- so check for that, and suggest.  cf #3805@@ -812,8 +867,19 @@     PsErrInvalidCApiImport {}                     -> noHints     PsErrMultipleConForNewtype {}                 -> noHints     PsErrUnicodeCharLooksLike{}                   -> noHints+    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
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}  module GHC.Parser.Errors.Types where @@ -68,7 +69,7 @@         arbitrary messages to be embedded. The typical use case would be GHC plugins         willing to emit custom diagnostics.     -}-    PsUnknownMessage UnknownDiagnostic+    PsUnknownMessage (UnknownDiagnosticFor PsMessage)      {-| A group of parser messages emitted in 'GHC.Parser.Header'.         See Note [Messages from GHC.Parser.Header].@@ -141,6 +142,23 @@     | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence +   {- | PsWarnViewPatternSignatures is a warning triggered by view patterns whose+        RHS is an unparenthesised pattern signature. It warns on code that is+        highly likely to break when the precedence of view patterns relative to+        pattern signatures is changed per GHC Proposal #281. The suggested fix+        is to add parentheses.++        Example:+          f1 (isJust -> True :: Bool) = ()++        Suggested fix:+          f1 (isJust -> (True :: Bool)) = ()++        Test cases:+          T24159_viewpat+   -}+   | PsWarnViewPatternSignatures !(LPat GhcPs) !(LPat GhcPs)+    -- | LambdaCase syntax used without the extension enabled    | PsErrLambdaCase @@ -189,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@@ -249,8 +270,8 @@    -- | If-then-else syntax in pattern    | PsErrIfThenElseInPat -   -- | Lambda-case in pattern-   | PsErrLambdaCaseInPat LamCaseVariant+   -- | Lambda or Lambda-case in pattern+   | PsErrLambdaInPat HsLamVariant     -- | case..of in pattern    | PsErrCaseInPat@@ -258,9 +279,6 @@    -- | let-syntax in pattern    | PsErrLetInPat -   -- | Lambda-syntax in pattern-   | PsErrLambdaInPat-    -- | Arrow expression-syntax in pattern    | PsErrArrowExprInPat !(HsExpr GhcPs) @@ -270,8 +288,8 @@    -- | Arrow command-syntax in expression    | PsErrArrowCmdInExpr !(HsCmd GhcPs) -   -- | View-pattern in expression-   | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)+   -- | Or-pattern in expression+   | PsErrOrPatInExpr !(LPat GhcPs)     -- | Type-application without space before '@'    | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)@@ -310,14 +328,11 @@    -- | @-operator in a pattern position    | PsErrAtInPatPos -   -- | Unexpected lambda command in function application-   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)-    -- | Unexpected case command in function application    | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) -   -- | Unexpected \case(s) command in function application-   | PsErrLambdaCaseCmdInFunAppCmd !LamCaseVariant !(LHsCmd GhcPs)+   -- | Unexpected lambda or \case(s) command in function application+   | PsErrLambdaCmdInFunAppCmd !HsLamVariant !(LHsCmd GhcPs)     -- | Unexpected if command in function application    | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)@@ -334,14 +349,11 @@    -- | Unexpected mdo block in function application    | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) -   -- | Unexpected lambda expression in function application-   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)-    -- | Unexpected case expression in function application    | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) -   -- | Unexpected \case(s) expression in function application-   | PsErrLambdaCaseInFunAppExpr !LamCaseVariant !(LHsExpr GhcPs)+   -- | Unexpected lambda or \case(s) expression in function application+   | PsErrLambdaInFunAppExpr !HsLamVariant !(LHsExpr GhcPs)     -- | Unexpected let expression in function application    | PsErrLetInFunAppExpr !(LHsExpr GhcPs)@@ -367,9 +379,6 @@    -- | Malformed ... declaration for ...    | PsErrMalformedDecl !SDoc !RdrName -   -- | Unexpected type application in a declaration-   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName-    -- | Not a data constructor    | PsErrNotADataCon !RdrName @@ -401,7 +410,7 @@    | PsErrIllegalRoleName !FastString [Role]     -- | Invalid type signature-   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)+   | PsErrInvalidTypeSignature !PsInvalidTypeSignature !(LHsExpr GhcPs)     -- | Unexpected type in declaration    | PsErrUnexpectedTypeInDecl !(LHsType GhcPs)@@ -460,7 +469,7 @@    | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs)     -- | Illegal linear arrow or multiplicity annotation in GADT record syntax-   | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)+   | PsErrIllegalGadtRecordMultiplicity !(HsMultAnn GhcPs)     | PsErrInvalidCApiImport @@ -471,6 +480,41 @@       Char -- ^ the character it looks like       String -- ^ the name of the character that it looks like +   | PsErrInvalidPun !PsErrPunDetails++   -- | Or pattern used without -XOrPatterns+   | PsErrIllegalOrPat (LPat GhcPs)++   -- | Temporary error until GHC gains support for type syntax in patterns.+   --   Test cases: T24159_pat_parse_error_1+   --               T24159_pat_parse_error_2+   --               T24159_pat_parse_error_3+   --               T24159_pat_parse_error_4+   --               T24159_pat_parse_error_5+   --               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@@ -490,6 +534,11 @@     -- ^ Did we parse a \"pattern\" keyword?   } +data PsInvalidTypeSignature+  = PsErrInvalidTypeSig_Qualified+  | PsErrInvalidTypeSig_DataCon+  | PsErrInvalidTypeSig_Other+ -- | Is the parsed pattern recursive? data PatIsRecursive   = YesPatIsRecursive@@ -514,13 +563,29 @@ 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   | PEIP_OtherPatDetails !ParseContext +data PsErrPunDetails+  = PEP_QuoteDisambiguation+  | PEP_TupleSyntaxType+  | PEP_SumSyntaxType++data PsErrTypeSyntaxDetails+  = PETS_FunctionArrow+      !(LocatedA (PatBuilder GhcPs))+      !(HsMultAnnOf (LocatedA (PatBuilder GhcPs)) GhcPs)+      !(LocatedA (PatBuilder GhcPs))+  | PETS_Multiplicity+      !(EpToken "%")+      !(LocatedA (PatBuilder GhcPs))+  | PETS_ForallTelescope+      !(HsForAllTelescope GhcPs)+      !(LocatedA (PatBuilder GhcPs))+  | PETS_ConstraintContext !(LocatedA (PatBuilder GhcPs))+ noParseContext :: ParseContext noParseContext = ParseContext Nothing NoIncompleteDoBlock @@ -536,6 +601,7 @@    | NumUnderscore_Float    deriving (Show,Eq,Ord) + data LexErrKind    = LexErrKind_EOF        -- ^ End of input    | LexErrKind_UTF8       -- ^ UTF-8 decoding error@@ -547,11 +613,10 @@    | LexUnknownPragma       -- ^ Unknown pragma    | LexErrorInPragma       -- ^ Lexical error in pragma    | LexNumEscapeRange      -- ^ Numeric escape sequence out of range-   | LexStringCharLit       -- ^ Lexical error in string/character literal-   | LexStringCharLitEOF    -- ^ Unexpected end-of-file in string/character literal    | LexUnterminatedComment -- ^ Unterminated `{-'    | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma    | LexUnterminatedQQ      -- ^ Unterminated quasiquotation+   deriving (Show,Eq,Ord)  -- | Errors from the Cmm parser data CmmParserError
compiler/GHC/Parser/HaddockLex.x view
@@ -1,6 +1,4 @@ {-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}  module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where@@ -10,13 +8,13 @@ import GHC.Data.FastString import GHC.Hs.Doc import GHC.Parser.Lexer+import GHC.Parser.Lexer.Interface (adjustChar) import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Data.StringBuffer import qualified GHC.Data.Strict as Strict import GHC.Types.Name.Reader-import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Encoding import GHC.Hs.Extension@@ -178,16 +176,8 @@       pflags = mkParserOpts                  (EnumSet.fromList [LangExt.MagicHash])                  dopts-                 []                  False False False False-      dopts = DiagOpts-        { diag_warning_flags = EnumSet.empty-          , diag_fatal_warning_flags = EnumSet.empty-          , diag_warn_is_error = False-          , diag_reverse_errors = False-          , diag_max_errors = Nothing-          , diag_ppr_ctx = defaultSDocContext-        }+      dopts = emptyDiagOpts       buffer = stringBufferFromByteString str0       realSrcLc = case mloc of         RealSrcSpan loc _ -> realSrcSpanStart loc
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,12 +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-        -- allow explicit "base" package qualifier (#19082, #17045)+        -- See #17045, package qualified imports are never counted as+        -- explicit prelude imports         && case ideclPkgQual decl of             NoRawPkgQual -> True-            RawPkgQual b -> sl_fs b == unitIdFS baseUnitId+            RawPkgQual {} -> False+        -- Only a "normal" level import will override the implicit prelude import.+        && case ideclLevelSpec decl of+              NotLevelled -> True+              _ -> False         loc' = noAnnSrcSpan loc@@ -156,6 +156,7 @@                                 ideclSafe      = False,  -- Not a safe import                                 ideclQualified = NotQualified,                                 ideclAs        = Nothing,+                                ideclLevelSpec = NotLevelled,                                 ideclImportList = Nothing  }  --------------------------------------------------------------@@ -166,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)@@ -247,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)@@ -272,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@@ -294,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@@ -444,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 @@ -458,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
@@ -41,3682 +41,3597 @@ -- Alex "Haskell code fragment top"  {-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE UnboxedSums #-}-{-# LANGUAGE UnliftedNewtypes #-}-{-# LANGUAGE PatternSynonyms #-}---{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Parser.Lexer (-   Token(..), lexer, lexerDbg,-   ParserOpts(..), mkParserOpts,-   PState (..), initParserState, initPragState,-   P(..), ParseResult(POk, PFailed),-   allocateComments, allocatePriorComments, allocateFinalComments,-   MonadP(..),-   getRealSrcLoc, getPState,-   failMsgP, failLocMsgP, srcParseFail,-   getPsErrorMessages, getPsMessages,-   popContext, pushModuleContext, setLastToken, setSrcLoc,-   activeContext, nextIsEOF,-   getLexState, popLexState, pushLexState,-   ExtBits(..),-   xtest, xunset, xset,-   disableHaddock,-   lexTokenStream,-   mkParensEpAnn,-   getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,-   getEofPos,-   commentToAnnotation,-   HdkComment(..),-   warnopt,-   adjustChar,-   addPsMessage-  ) where--import GHC.Prelude-import qualified GHC.Data.Strict as Strict---- base-import Control.Monad-import Control.Applicative-import Data.Char-import Data.List (stripPrefix, isInfixOf, partition)-import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.List.NonEmpty as NE-import Data.Maybe-import Data.Word-import Debug.Trace (trace)--import GHC.Data.EnumSet as EnumSet---- ghc-boot-import qualified GHC.LanguageExtensions as LangExt---- bytestring-import Data.ByteString (ByteString)---- containers-import Data.Map (Map)-import qualified Data.Map as Map---- compiler-import GHC.Utils.Error-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Types.Error-import GHC.Types.Unique.FM-import GHC.Data.Maybe-import GHC.Data.OrdList-import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair )--import GHC.Types.SrcLoc-import GHC.Types.SourceText-import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..))-import GHC.Hs.Doc--import GHC.Parser.CharClass--import GHC.Parser.Annotation-import GHC.Driver.Flags-import GHC.Parser.Errors.Basic-import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr ()-}---- -------------------------------------------------------------------------------- Alex "Character set macros"---- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme"--- Any changes here should likely be reflected there.-$unispace    = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$nl          = [\n\r\f]-$whitechar   = [$nl\v\ $unispace]-$white_no_nl = $whitechar # \n -- TODO #8424-$tab         = \t--$ascdigit  = 0-9-$unidigit  = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$decdigit  = $ascdigit -- exactly $ascdigit, no more no less.-$digit     = [$ascdigit $unidigit]--$special   = [\(\)\,\;\[\]\`\{\}]-$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]-$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']--$unilarge  = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$asclarge  = [A-Z]-$large     = [$asclarge $unilarge]--$unismall  = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$ascsmall  = [a-z]-$small     = [$ascsmall $unismall \_]--$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$idchar    = [$small $large $digit $uniidchar \']--$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].-$graphic   = [$small $large $symbol $digit $idchar $special $unigraphic \"\']--$binit     = 0-1-$octit     = 0-7-$hexit     = [$decdigit A-F a-f]--$pragmachar = [$small $large $digit $uniidchar ]--$docsym    = [\| \^ \* \$]----- -------------------------------------------------------------------------------- Alex "Regular expression macros"--@varid     = $small $idchar*          -- variable identifiers-@conid     = $large $idchar*          -- constructor identifiers--@varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol-@consym    = \: $symbol*              -- constructor (operator) symbol---- See Note [Lexing NumericUnderscores extension] and #14473-@numspc       = _*                   -- numeric spacer (#14473)-@decimal      = $decdigit(@numspc $decdigit)*-@binary       = $binit(@numspc $binit)*-@octal        = $octit(@numspc $octit)*-@hexadecimal  = $hexit(@numspc $hexit)*-@exponent     = @numspc [eE] [\-\+]? @decimal-@bin_exponent = @numspc [pP] [\-\+]? @decimal--@qual = (@conid \.)+-@qvarid = @qual @varid-@qconid = @qual @conid-@qvarsym = @qual @varsym-@qconsym = @qual @consym---- QualifiedDo needs to parse "M.do" not as a variable, so as to keep the--- layout rules.-@qdo    = @qual "do"-@qmdo   = @qual "mdo"--@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent-@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent---- normal signed numerical literals can only be explicitly negative,--- not explicitly positive (contrast @exponent)-@negative = \------ -------------------------------------------------------------------------------- Alex "Identifier"--haskell :------ -------------------------------------------------------------------------------- Alex "Rules"---- everywhere: skip whitespace-$white_no_nl+ ;-$tab          { warnTab }---- Everywhere: deal with nested comments.  We explicitly rule out--- pragmas, "{-#", so that we don't accidentally treat them as comments.--- (this can happen even though pragmas will normally take precedence due to--- longest-match, because pragmas aren't valid in every state, but comments--- are). We also rule out nested Haddock comments, if the -haddock flag is--- set.--"{-" / { isNormalComment } { nested_comment }---- Single-line comments are a bit tricky.  Haskell 98 says that two or--- more dashes followed by a symbol should be parsed as a varsym, so we--- have to exclude those.---- Since Haddock comments aren't valid in every state, we need to rule them--- out here.---- The following two rules match comments that begin with two dashes, but--- continue with a different character. The rules test that this character--- is not a symbol (in which case we'd have a varsym), and that it's not a--- space followed by a Haddock comment symbol (docsym) (in which case we'd--- have a Haddock comment). The rules then munch the rest of the line.--"-- " ~$docsym .* { lineCommentToken }-"--" [^$symbol \ ] .* { lineCommentToken }---- Next, match Haddock comments if no -haddock flag--"-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { lineCommentToken }---- Now, when we've matched comments that begin with 2 dashes and continue--- with a different character, we need to match comments that begin with three--- or more dashes (which clearly can't be Haddock comments). We only need to--- make sure that the first non-dash character isn't a symbol, and munch the--- rest of the line.--"---"\-* ~$symbol .* { lineCommentToken }---- Since the previous rules all match dashes followed by at least one--- character, we also need to match a whole line filled with just dashes.--"--"\-* / { atEOL } { lineCommentToken }---- We need this rule since none of the other single line comment rules--- actually match this case.--"-- " / { atEOL } { lineCommentToken }---- Everywhere: check for smart quotes--they are not allowed outside of strings-$unigraphic / { isSmartQuote } { smart_quote_error }---- 'bol' state: beginning of a line.  Slurp up all the whitespace (including--- blank lines) until we find a non-whitespace character, then do layout--- processing.------ One slight wibble here: what if the line begins with {-#? In--- theory, we have to lex the pragma to see if it's one we recognise,--- and if it is, then we backtrack and do_bol, otherwise we treat it--- as a nested comment.  We don't bother with this: if the line begins--- with {-#, then we'll assume it's a pragma we know about and go for do_bol.-<bol> {-  \n                                    ;-  ^\# line                              { begin line_prag1 }-  ^\# / { followedByDigit }             { begin line_prag1 }-  ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently-  ^\# \! .* \n                          ; -- #!, for scripts  -- gcc-  ^\  \# \! .* \n                       ; --  #!, for scripts -- clang; See #6132-  ()                                    { do_bol }-}---- after a layout keyword (let, where, do, of), we begin a new layout--- context if the curly brace is missing.--- Careful! This stuff is quite delicate.-<layout, layout_do, layout_if> {-  \{ / { notFollowedBy '-' }            { hopefully_open_brace }-        -- we might encounter {-# here, but {- has been handled already-  \n                                    ;-  ^\# (line)?                           { begin line_prag1 }-}---- after an 'if', a vertical bar starts a layout context for MultiWayIf-<layout_if> {-  \| / { notFollowedBySymbol }          { new_layout_context True dontGenerateSemic ITvbar }-  ()                                    { pop }-}---- do is treated in a subtly different way, see new_layout_context-<layout>    ()                          { new_layout_context True  generateSemic ITvocurly }-<layout_do> ()                          { new_layout_context False generateSemic ITvocurly }---- after a new layout context which was found to be to the left of the--- previous context, we have generated a '{' token, and we now need to--- generate a matching '}' token.-<layout_left>  ()                       { do_layout_left }--<0,option_prags> \n                     { begin bol }--"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }-                                { dispatch_pragmas linePrags }---- single-line line pragmas, of the form---    # <line> "<file>" <extra-stuff> \n-<line_prag1> {-  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag1a }-  ()                                           { failLinePrag1 }-}-<line_prag1a> .*                               { popLinePrag1 }---- Haskell-style line pragmas, of the form---    {-# LINE <line> "<file>" #-}-<line_prag2> {-  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag2a }-}-<line_prag2a> "#-}"|"-}"                       { pop }-   -- NOTE: accept -} at the end of a LINE pragma, for compatibility-   -- with older versions of GHC which generated these.---- Haskell-style column pragmas, of the form---    {-# COLUMN <column> #-}-<column_prag> @decimal $whitechar* "#-}" { setColumn }--<0,option_prags> {-  "{-#" $whitechar* $pragmachar+-        $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }-                                 { dispatch_pragmas twoWordPrags }--  "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }-                                 { dispatch_pragmas oneWordPrags }--  -- We ignore all these pragmas, but don't generate a warning for them-  "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }-                                 { dispatch_pragmas ignoredPrags }--  -- ToDo: should only be valid inside a pragma:-  "#-}"                          { endPrag }-}--<option_prags> {-  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }-                                   { dispatch_pragmas fileHeaderPrags }-}--<0> {-  -- In the "0" mode we ignore these pragmas-  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }-                     { nested_comment }-}--<0,option_prags> {---- This code would eagerly accept and hence discard, e.g., "LANGUAGE MagicHash".---  "{-#" $whitechar* $pragmachar+---        $whitechar+ $pragmachar+---        { warn_unknown_prag twoWordPrags }--  "{-#" $whitechar* $pragmachar+-        { warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) }--  "{-#" { warn_unknown_prag Map.empty }-}---- '0' state: ordinary lexemes---- Haddock comments--"-- " $docsym      / { ifExtension HaddockBit } { multiline_doc_comment }-"{-" \ ? $docsym   / { ifExtension HaddockBit } { nested_doc_comment }---- "special" symbols--<0> {--  -- Don't check ThQuotesBit here as the renamer can produce a better-  -- error message than the lexer (see the thQuotesEnabled check in rnBracket).-  "[|"  { token (ITopenExpQuote NoE NormalSyntax) }-  "[||" { token (ITopenTExpQuote NoE) }-  "|]"  { token (ITcloseQuote NormalSyntax) }-  "||]" { token ITcloseTExpQuote }--  -- Check ThQuotesBit here as to not steal syntax.-  "[e|"       / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }-  "[e||"      / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) }-  "[p|"       / { ifExtension ThQuotesBit } { token ITopenPatQuote }-  "[d|"       / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote }-  "[t|"       / { ifExtension ThQuotesBit } { token ITopenTypQuote }--  "[" @varid "|"  / { ifExtension QqBit }   { lex_quasiquote_tok }--  -- qualified quasi-quote (#5555)-  "[" @qvarid "|"  / { ifExtension QqBit }  { lex_qquasiquote_tok }--  $unigraphic -- ⟦-    / { ifCurrentChar '⟦' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ThQuotesBit }-    { token (ITopenExpQuote NoE UnicodeSyntax) }-  $unigraphic -- ⟧-    / { ifCurrentChar '⟧' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ThQuotesBit }-    { token (ITcloseQuote UnicodeSyntax) }-}--<0> {-  "(|"-    / { ifExtension ArrowsBit `alexAndPred`-        notFollowedBySymbol }-    { special (IToparenbar NormalSyntax) }-  "|)"-    / { ifExtension ArrowsBit }-    { special (ITcparenbar NormalSyntax) }--  $unigraphic -- ⦇-    / { ifCurrentChar '⦇' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ArrowsBit }-    { special (IToparenbar UnicodeSyntax) }-  $unigraphic -- ⦈-    / { ifCurrentChar '⦈' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ArrowsBit }-    { special (ITcparenbar UnicodeSyntax) }-}--<0> {-  \? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid }-}--<0> {-  "#" $idchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid_src ITlabelvarid }-  "#" \" / { ifExtension OverloadedLabelsBit } { lex_quoted_label }-}--<0> {-  "(#" / { ifExtension UnboxedParensBit }-         { token IToubxparen }-  "#)" / { ifExtension UnboxedParensBit }-         { token ITcubxparen }-}--<0,option_prags> {-  \(                                    { special IToparen }-  \)                                    { special ITcparen }-  \[                                    { special ITobrack }-  \]                                    { special ITcbrack }-  \,                                    { special ITcomma }-  \;                                    { special ITsemi }-  \`                                    { special ITbackquote }--  \{                                    { open_brace }-  \}                                    { close_brace }-}--<0,option_prags> {-  @qdo                                      { qdo_token ITdo }-  @qmdo    / { ifExtension RecursiveDoBit } { qdo_token ITmdo }-  @qvarid                       { idtoken qvarid }-  @qconid                       { idtoken qconid }-  @varid                        { varid }-  @conid                        { idtoken conid }-}--<0> {-  @qvarid "#"+      / { ifExtension MagicHashBit } { idtoken qvarid }-  @qconid "#"+      / { ifExtension MagicHashBit } { idtoken qconid }-  @varid "#"+       / { ifExtension MagicHashBit } { varid }-  @conid "#"+       / { ifExtension MagicHashBit } { idtoken conid }-}---- ToDo: - move `var` and (sym) into lexical syntax?---       - remove backquote from $special?-<0> {-  @qvarsym                                         { idtoken qvarsym }-  @qconsym                                         { idtoken qconsym }-  @varsym                                          { with_op_ws varsym }-  @consym                                          { with_op_ws consym }-}---- For the normal boxed literals we need to be careful--- when trying to be close to Haskell98---- Note [Lexing NumericUnderscores extension] (#14473)--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- NumericUnderscores extension allows underscores in numeric literals.--- Multiple underscores are represented with @numspc macro.--- To be simpler, we have only the definitions with underscores.--- And then we have a separate function (tok_integral and tok_frac)--- that validates the literals.--- If extensions are not enabled, check that there are no underscores.----<0> {-  -- Normal integral literals (:: Num a => a, from Integer)-  @decimal                                                                   { tok_num positive 0 0 decimal }-  0[bB] @numspc @binary                / { ifExtension BinaryLiteralsBit }   { tok_num positive 2 2 binary }-  0[oO] @numspc @octal                                                       { tok_num positive 2 2 octal }-  0[xX] @numspc @hexadecimal                                                 { tok_num positive 2 2 hexadecimal }-  @negative @decimal                   / { negLitPred }                      { tok_num negative 1 1 decimal }-  @negative 0[bB] @numspc @binary      / { negLitPred `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_num negative 3 3 binary }-  @negative 0[oO] @numspc @octal       / { negLitPred }                      { tok_num negative 3 3 octal }-  @negative 0[xX] @numspc @hexadecimal / { negLitPred }                      { tok_num negative 3 3 hexadecimal }--  -- Normal rational literals (:: Fractional a => a, from Rational)-  @floating_point                                                            { tok_frac 0 tok_float }-  @negative @floating_point            / { negLitPred }                      { tok_frac 0 tok_float }-  0[xX] @numspc @hex_floating_point    / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }-  @negative 0[xX] @numspc @hex_floating_point-                                       / { ifExtension HexFloatLiteralsBit `alexAndPred`-                                           negLitPred }                      { tok_frac 0 tok_hex_float }-}--<0> {-  -- Unboxed ints (:: Int#) and words (:: Word#)-  -- It's simpler (and faster?) to give separate cases to the negatives,-  -- especially considering octal/hexadecimal prefixes.-  @decimal                          \# / { ifExtension MagicHashBit }        { tok_primint positive 0 1 decimal }-  0[bB] @numspc @binary             \# / { ifExtension MagicHashBit `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_primint positive 2 3 binary }-  0[oO] @numspc @octal              \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 octal }-  0[xX] @numspc @hexadecimal        \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 hexadecimal }-  @negative @decimal                \# / { negHashLitPred }                  { tok_primint negative 1 2 decimal }-  @negative 0[bB] @numspc @binary   \# / { negHashLitPred `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_primint negative 3 4 binary }-  @negative 0[oO] @numspc @octal    \# / { negHashLitPred }                  { tok_primint negative 3 4 octal }-  @negative 0[xX] @numspc @hexadecimal \#-                                       / { negHashLitPred }                  { tok_primint negative 3 4 hexadecimal }--  @decimal                       \# \# / { ifExtension MagicHashBit }        { tok_primword 0 2 decimal }-  0[bB] @numspc @binary          \# \# / { ifExtension MagicHashBit `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_primword 2 4 binary }-  0[oO] @numspc @octal           \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 octal }-  0[xX] @numspc @hexadecimal     \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 hexadecimal }--  -- Unboxed floats and doubles (:: Float#, :: Double#)-  -- prim_{float,double} work with signed literals-  @floating_point                  \# / { ifExtension MagicHashBit }        { tok_frac 1 tok_primfloat }-  @floating_point               \# \# / { ifExtension MagicHashBit }        { tok_frac 2 tok_primdouble }--  @negative @floating_point        \# / { negHashLitPred }                  { tok_frac 1 tok_primfloat }-  @negative @floating_point     \# \# / { negHashLitPred }                  { tok_frac 2 tok_primdouble }-}---- Strings and chars are lexed by hand-written code.  The reason is--- that even if we recognise the string or char here in the regex--- lexer, we would still have to parse the string afterward in order--- to convert it to a String.-<0> {-  \'                            { lex_char_tok }-  \"                            { lex_string_tok }-}---- Note [Whitespace-sensitive operator parsing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- In accord with GHC Proposal #229 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst--- we classify operator occurrences into four categories:------     a ! b   -- a loose infix occurrence---     a!b     -- a tight infix occurrence---     a !b    -- a prefix occurrence---     a! b    -- a suffix occurrence------ The rules are a bit more elaborate than simply checking for whitespace, in--- order to accommodate the following use cases:------     f (!a) = ...    -- prefix occurrence---     g (a !)         -- loose infix occurrence---     g (! a)         -- loose infix occurrence------ The precise rules are as follows:------  * Identifiers, literals, and opening brackets (, (#, (|, [, [|, [||, [p|,---    [e|, [t|, {, ⟦, ⦇, are considered "opening tokens". The function---    followedByOpeningToken tests whether the next token is an opening token.------  * Identifiers, literals, and closing brackets ), #), |), ], |], }, ⟧, ⦈,---    are considered "closing tokens". The function precededByClosingToken tests---    whether the previous token is a closing token.------  * Whitespace, comments, separators, and other tokens, are considered---    neither opening nor closing.------  * Any unqualified operator occurrence is classified as prefix, suffix, or---    tight/loose infix, based on preceding and following tokens:------       precededByClosingToken | followedByOpeningToken | Occurrence---      ------------------------+------------------------+---------------       False                  | True                   | prefix---       True                   | False                  | suffix---       True                   | True                   | tight infix---       False                  | False                  | loose infix---      ------------------------+------------------------+------------------ A loose infix occurrence is always considered an operator. Other types of--- occurrences may be assigned a special per-operator meaning override:------   Operator |  Occurrence   | Token returned---  ----------+---------------+---------------------------------------------    !       |  prefix       | ITbang---            |               |   strictness annotation or bang pattern,---            |               |   e.g.  f !x = rhs, data T = MkT !a---            |  not prefix   | ITvarsym "!"---            |               |   ordinary operator or type operator,---            |               |   e.g.  xs ! 3, (! x), Int ! Bool---  ----------+---------------+---------------------------------------------    ~       |  prefix       | ITtilde---            |               |   laziness annotation or lazy pattern,---            |               |   e.g.  f ~x = rhs, data T = MkT ~a---            |  not prefix   | ITvarsym "~"---            |               |   ordinary operator or type operator,---            |               |   e.g.  xs ~ 3, (~ x), Int ~ Bool---  ----------+---------------+---------------------------------------------    .       |  prefix       | ITproj True---            |               |   field projection,---            |               |   e.g.  .x---            |  tight infix  | ITproj False---            |               |   field projection,---            |               |   e.g. r.x---            |  suffix       | ITdot---            |               |   function composition,---            |               |   e.g. f. g---            |  loose infix  | ITdot---            |               |   function composition,---            |               |   e.g.  f . g---  ----------+---------------+---------------------------------------------    $  $$   |  prefix       | ITdollar, ITdollardollar---            |               |   untyped or typed Template Haskell splice,---            |               |   e.g.  $(f x), $$(f x), $$"str"---            |  not prefix   | ITvarsym "$", ITvarsym "$$"---            |               |   ordinary operator or type operator,---            |               |   e.g.  f $ g x, a $$ b---  ----------+---------------+---------------------------------------------    @       |  prefix       | ITtypeApp---            |               |   type application, e.g.  fmap @Maybe---            |  tight infix  | ITat---            |               |   as-pattern, e.g.  f p@(a,b) = rhs---            |  suffix       | parse error---            |               |   e.g. f p@ x = rhs---            |  loose infix  | ITvarsym "@"---            |               |   ordinary operator or type operator,---            |               |   e.g.  f @ g, (f @)---  ----------+---------------+------------------------------------------------ Also, some of these overrides are guarded behind language extensions.--- According to the specification, we must determine the occurrence based on--- surrounding *tokens* (see the proposal for the exact rules). However, in--- the implementation we cheat a little and do the classification based on--- characters, for reasons of both simplicity and efficiency (see--- 'followedByOpeningToken' and 'precededByClosingToken')------ When an operator is subject to a meaning override, it is mapped to special--- token: ITbang, ITtilde, ITat, ITdollar, ITdollardollar. Otherwise, it is--- returned as ITvarsym.------ For example, this is how we process the (!):------    precededByClosingToken | followedByOpeningToken | Token---   ------------------------+------------------------+----------------    False                  | True                   | ITbang---    True                   | False                  | ITvarsym "!"---    True                   | True                   | ITvarsym "!"---    False                  | False                  | ITvarsym "!"---   ------------------------+------------------------+------------------- And this is how we process the (@):------    precededByClosingToken | followedByOpeningToken | Token---   ------------------------+------------------------+----------------    False                  | True                   | ITtypeApp---    True                   | False                  | parse error---    True                   | True                   | ITat---    False                  | False                  | ITvarsym "@"---   ------------------------+------------------------+----------------- -------------------------------------------------------------------------------- Alex "Haskell code fragment bottom"--{---- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing].-data OpWs-  = OpWsPrefix         -- a !b-  | OpWsSuffix         -- a! b-  | OpWsTightInfix     -- a!b-  | OpWsLooseInfix     -- a ! b-  deriving Show---- -------------------------------------------------------------------------------- The token type--data Token-  = ITas                        -- Haskell keywords-  | ITcase-  | ITclass-  | ITdata-  | ITdefault-  | ITderiving-  | ITdo (Maybe FastString)-  | ITelse-  | IThiding-  | ITforeign-  | ITif-  | ITimport-  | ITin-  | ITinfix-  | ITinfixl-  | ITinfixr-  | ITinstance-  | ITlet-  | ITmodule-  | ITnewtype-  | ITof-  | ITqualified-  | ITthen-  | ITtype-  | ITwhere--  | ITforall            IsUnicodeSyntax -- GHC extension keywords-  | ITexport-  | ITlabel-  | ITdynamic-  | ITsafe-  | ITinterruptible-  | ITunsafe-  | ITstdcallconv-  | ITccallconv-  | ITcapiconv-  | ITprimcallconv-  | ITjavascriptcallconv-  | ITmdo (Maybe FastString)-  | ITfamily-  | ITrole-  | ITgroup-  | ITby-  | ITusing-  | ITpattern-  | ITstatic-  | ITstock-  | ITanyclass-  | ITvia--  -- Backpack tokens-  | ITunit-  | ITsignature-  | ITdependency-  | ITrequires--  -- Pragmas, see  Note [Pragma source text] in "GHC.Types.Basic"-  | ITinline_prag       SourceText InlineSpec RuleMatchInfo-  | ITopaque_prag       SourceText-  | ITspec_prag         SourceText                -- SPECIALISE-  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)-  | ITsource_prag       SourceText-  | ITrules_prag        SourceText-  | ITwarning_prag      SourceText-  | ITdeprecated_prag   SourceText-  | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'-  | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'-  | ITscc_prag          SourceText-  | ITunpack_prag       SourceText-  | ITnounpack_prag     SourceText-  | ITann_prag          SourceText-  | ITcomplete_prag     SourceText-  | ITclose_prag-  | IToptions_prag String-  | ITinclude_prag String-  | ITlanguage_prag-  | ITminimal_prag      SourceText-  | IToverlappable_prag SourceText  -- instance overlap mode-  | IToverlapping_prag  SourceText  -- instance overlap mode-  | IToverlaps_prag     SourceText  -- instance overlap mode-  | ITincoherent_prag   SourceText  -- instance overlap mode-  | ITctype             SourceText-  | ITcomment_line_prag         -- See Note [Nested comment line pragmas]--  | ITdotdot                    -- reserved symbols-  | ITcolon-  | ITdcolon            IsUnicodeSyntax-  | ITequal-  | ITlam-  | ITlcase-  | ITlcases-  | ITvbar-  | ITlarrow            IsUnicodeSyntax-  | ITrarrow            IsUnicodeSyntax-  | ITdarrow            IsUnicodeSyntax-  | ITlolly       -- The (⊸) arrow (for LinearTypes)-  | ITminus       -- See Note [Minus tokens]-  | ITprefixminus -- See Note [Minus tokens]-  | ITbang     -- Prefix (!) only, e.g. f !x = rhs-  | ITtilde    -- Prefix (~) only, e.g. f ~x = rhs-  | ITat       -- Tight infix (@) only, e.g. f x@pat = rhs-  | ITtypeApp  -- Prefix (@) only, e.g. f @t-  | ITpercent  -- Prefix (%) only, e.g. a %1 -> b-  | ITstar              IsUnicodeSyntax-  | ITdot-  | ITproj Bool -- Extension: OverloadedRecordDotBit--  | ITbiglam                    -- GHC-extension symbols--  | ITocurly                    -- special symbols-  | ITccurly-  | ITvocurly-  | ITvccurly-  | ITobrack-  | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays-  | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays-  | ITcbrack-  | IToparen-  | ITcparen-  | IToubxparen-  | ITcubxparen-  | ITsemi-  | ITcomma-  | ITunderscore-  | ITbackquote-  | ITsimpleQuote               --  '--  | ITvarid   FastString        -- identifiers-  | ITconid   FastString-  | ITvarsym  FastString-  | ITconsym  FastString-  | ITqvarid  (FastString,FastString)-  | ITqconid  (FastString,FastString)-  | ITqvarsym (FastString,FastString)-  | ITqconsym (FastString,FastString)--  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x-  | ITlabelvarid SourceText FastString   -- Overloaded label: #x-                                         -- The SourceText is required because we can-                                         -- have a string literal as a label-                                         -- Note [Literal source text] in "GHC.Types.Basic"--  | ITchar     SourceText Char       -- Note [Literal source text] in "GHC.Types.Basic"-  | ITstring   SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic"-  | ITinteger  IntegralLit           -- Note [Literal source text] in "GHC.Types.Basic"-  | ITrational FractionalLit--  | ITprimchar   SourceText Char     -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimint    SourceText Integer  -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimword   SourceText Integer  -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimfloat  FractionalLit-  | ITprimdouble FractionalLit--  -- Template Haskell extension tokens-  | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|-  | ITopenPatQuote                      --  [p|-  | ITopenDecQuote                      --  [d|-  | ITopenTypQuote                      --  [t|-  | ITcloseQuote IsUnicodeSyntax        --  |]-  | ITopenTExpQuote HasE                --  [|| or [e||-  | ITcloseTExpQuote                    --  ||]-  | ITdollar                            --  prefix $-  | ITdollardollar                      --  prefix $$-  | ITtyQuote                           --  ''-  | ITquasiQuote (FastString,FastString,PsSpan)-    -- ITquasiQuote(quoter, quote, loc)-    -- represents a quasi-quote of the form-    -- [quoter| quote |]-  | ITqQuasiQuote (FastString,FastString,FastString,PsSpan)-    -- ITqQuasiQuote(Qual, quoter, quote, loc)-    -- represents a qualified quasi-quote of the form-    -- [Qual.quoter| quote |]--  -- Arrow notation extension-  | ITproc-  | ITrec-  | IToparenbar  IsUnicodeSyntax -- ^ @(|@-  | ITcparenbar  IsUnicodeSyntax -- ^ @|)@-  | ITlarrowtail IsUnicodeSyntax -- ^ @-<@-  | ITrarrowtail IsUnicodeSyntax -- ^ @>-@-  | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@-  | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@--  | ITunknown String             -- ^ Used when the lexer can't make sense of it-  | ITeof                        -- ^ end of file token--  -- Documentation annotations. See Note [PsSpan in Comments]-  | ITdocComment   HsDocString PsSpan -- ^ The HsDocString contains more details about what-                                      -- this is and how to pretty print it-  | ITdocOptions   String      PsSpan -- ^ doc options (prune, ignore-exports, etc)-  | ITlineComment  String      PsSpan -- ^ comment starting by "--"-  | ITblockComment String      PsSpan -- ^ comment in {- -}--  deriving Show--instance Outputable Token where-  ppr x = text (show x)--{- Note [PsSpan in Comments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When using the Api Annotations to exact print a modified AST, managing-the space before a comment is important.  The PsSpan in the comment-token allows this to happen.--We also need to track the space before the end of file. The normal-mechanism of using the previous token does not work, as the ITeof is-synthesised to come at the same location of the last token, and the-normal previous token updating has by then updated the required-location.--We track this using a 2-back location, prev_loc2. This adds extra-processing to every single token, which is a performance hit for-something needed only at the end of the file. This needs-improving. Perhaps a backward scan on eof?--}--{- Note [Minus tokens]-~~~~~~~~~~~~~~~~~~~~~~-A minus sign can be used in prefix form (-x) and infix form (a - b).--When LexicalNegation is on:-  * ITprefixminus  represents the prefix form-  * ITvarsym "-"   represents the infix form-  * ITminus        is not used--When LexicalNegation is off:-  * ITminus        represents all forms-  * ITprefixminus  is not used-  * ITvarsym "-"   is not used--}--{- Note [Why not LexicalNegationBit]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One might wonder why we define NoLexicalNegationBit instead of-LexicalNegationBit. The problem lies in the following line in reservedSymsFM:--    ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit)--We want to generate ITminus only when LexicalNegation is off. How would one-do it if we had LexicalNegationBit? I (int-index) tried to use bitwise-complement:--    ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit))--This did not work, so I opted for NoLexicalNegationBit instead.--}----- the bitmap provided as the third component indicates whether the--- corresponding extension keyword is valid under the extension options--- provided to the compiler; if the extension corresponding to *any* of the--- bits set in the bitmap is enabled, the keyword is valid (this setup--- facilitates using a keyword in two different extensions that can be--- activated independently)----reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap)-reservedWordsFM = listToUFM $-    map (\(x, y, z) -> (mkFastString x, (y, z)))-        [( "_",              ITunderscore,    0 ),-         ( "as",             ITas,            0 ),-         ( "case",           ITcase,          0 ),-         ( "cases",          ITlcases,        xbit LambdaCaseBit ),-         ( "class",          ITclass,         0 ),-         ( "data",           ITdata,          0 ),-         ( "default",        ITdefault,       0 ),-         ( "deriving",       ITderiving,      0 ),-         ( "do",             ITdo Nothing,    0 ),-         ( "else",           ITelse,          0 ),-         ( "hiding",         IThiding,        0 ),-         ( "if",             ITif,            0 ),-         ( "import",         ITimport,        0 ),-         ( "in",             ITin,            0 ),-         ( "infix",          ITinfix,         0 ),-         ( "infixl",         ITinfixl,        0 ),-         ( "infixr",         ITinfixr,        0 ),-         ( "instance",       ITinstance,      0 ),-         ( "let",            ITlet,           0 ),-         ( "module",         ITmodule,        0 ),-         ( "newtype",        ITnewtype,       0 ),-         ( "of",             ITof,            0 ),-         ( "qualified",      ITqualified,     0 ),-         ( "then",           ITthen,          0 ),-         ( "type",           ITtype,          0 ),-         ( "where",          ITwhere,         0 ),--         ( "forall",         ITforall NormalSyntax, 0),-         ( "mdo",            ITmdo Nothing,   xbit RecursiveDoBit),-             -- See Note [Lexing type pseudo-keywords]-         ( "family",         ITfamily,        0 ),-         ( "role",           ITrole,          0 ),-         ( "pattern",        ITpattern,       xbit PatternSynonymsBit),-         ( "static",         ITstatic,        xbit StaticPointersBit ),-         ( "stock",          ITstock,         0 ),-         ( "anyclass",       ITanyclass,      0 ),-         ( "via",            ITvia,           0 ),-         ( "group",          ITgroup,         xbit TransformComprehensionsBit),-         ( "by",             ITby,            xbit TransformComprehensionsBit),-         ( "using",          ITusing,         xbit TransformComprehensionsBit),--         ( "foreign",        ITforeign,       xbit FfiBit),-         ( "export",         ITexport,        xbit FfiBit),-         ( "label",          ITlabel,         xbit FfiBit),-         ( "dynamic",        ITdynamic,       xbit FfiBit),-         ( "safe",           ITsafe,          xbit FfiBit .|.-                                              xbit SafeHaskellBit),-         ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),-         ( "unsafe",         ITunsafe,        xbit FfiBit),-         ( "stdcall",        ITstdcallconv,   xbit FfiBit),-         ( "ccall",          ITccallconv,     xbit FfiBit),-         ( "capi",           ITcapiconv,      xbit CApiFfiBit),-         ( "prim",           ITprimcallconv,  xbit FfiBit),-         ( "javascript",     ITjavascriptcallconv, xbit FfiBit),--         ( "unit",           ITunit,          0 ),-         ( "dependency",     ITdependency,       0 ),-         ( "signature",      ITsignature,     0 ),--         ( "rec",            ITrec,           xbit ArrowsBit .|.-                                              xbit RecursiveDoBit),-         ( "proc",           ITproc,          xbit ArrowsBit)-     ]--{------------------------------------Note [Lexing type pseudo-keywords]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--One might think that we wish to treat 'family' and 'role' as regular old-varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.-But, there is no need to do so. These pseudo-keywords are not stolen syntax:-they are only used after the keyword 'type' at the top-level, where varids are-not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that-type families and role annotations are never declared without their extensions-on. In fact, by unconditionally lexing these pseudo-keywords as special, we-can get better error messages.--Also, note that these are included in the `varid` production in the parser ---a key detail to make all this work.--------------------------------------}--reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap)-reservedSymsFM = listToUFM $-    map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))-      [ ("..",  ITdotdot,                   NormalSyntax,  0 )-        -- (:) is a reserved op, meaning only list cons-       ,(":",   ITcolon,                    NormalSyntax,  0 )-       ,("::",  ITdcolon NormalSyntax,      NormalSyntax,  0 )-       ,("=",   ITequal,                    NormalSyntax,  0 )-       ,("\\",  ITlam,                      NormalSyntax,  0 )-       ,("|",   ITvbar,                     NormalSyntax,  0 )-       ,("<-",  ITlarrow NormalSyntax,      NormalSyntax,  0 )-       ,("->",  ITrarrow NormalSyntax,      NormalSyntax,  0 )-       ,("=>",  ITdarrow NormalSyntax,      NormalSyntax,  0 )-       ,("-",   ITminus,                    NormalSyntax,  xbit NoLexicalNegationBit)--       ,("*",   ITstar NormalSyntax,        NormalSyntax,  xbit StarIsTypeBit)--       ,("-<",  ITlarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)-       ,(">-",  ITrarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)-       ,("-<<", ITLarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)-       ,(">>-", ITRarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)--       ,("∷",   ITdcolon UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("⇒",   ITdarrow UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("∀",   ITforall UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("→",   ITrarrow UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("←",   ITlarrow UnicodeSyntax,     UnicodeSyntax, 0 )--       ,("⊸",   ITlolly, UnicodeSyntax, 0)--       ,("⤙",   ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)-       ,("⤚",   ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)-       ,("⤛",   ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)-       ,("⤜",   ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)--       ,("★",   ITstar UnicodeSyntax,       UnicodeSyntax, xbit StarIsTypeBit)--        -- ToDo: ideally, → and ∷ should be "specials", so that they cannot-        -- form part of a large operator.  This would let us have a better-        -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).-       ]---- -------------------------------------------------------------------------------- Lexer actions--type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token)--special :: Token -> Action-special tok span _buf _len _buf2 = return (L span tok)--token, layout_token :: Token -> Action-token t span _buf _len _buf2 = return (L span t)-layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t)--idtoken :: (StringBuffer -> Int -> Token) -> Action-idtoken f span buf len _buf2 = return (L span $! (f buf len))--qdo_token :: (Maybe FastString -> Token) -> Action-qdo_token con span buf len _buf2 = do-    maybe_layout token-    return (L span $! token)-  where-    !token = con $! Just $! fst $! splitQualName buf len False--skip_one_varid :: (FastString -> Token) -> Action-skip_one_varid f span buf len _buf2-  = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))--skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action-skip_one_varid_src f span buf len _buf2-  = return (L span $! f (SourceText $ lexemeToString (stepOn buf) (len-1))-                        (lexemeToFastString (stepOn buf) (len-1)))--skip_two_varid :: (FastString -> Token) -> Action-skip_two_varid f span buf len _buf2-  = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))--strtoken :: (String -> Token) -> Action-strtoken f span buf len _buf2 =-  return (L span $! (f $! lexemeToString buf len))--begin :: Int -> Action-begin code _span _str _len _buf2 = do pushLexState code; lexToken--pop :: Action-pop _span _buf _len _buf2 =-  do _ <- popLexState-     lexToken--- See Note [Nested comment line pragmas]-failLinePrag1 :: Action-failLinePrag1 span _buf _len _buf2 = do-  b <- getBit InNestedCommentBit-  if b then return (L span ITcomment_line_prag)-       else lexError LexErrorInPragma---- See Note [Nested comment line pragmas]-popLinePrag1 :: Action-popLinePrag1 span _buf _len _buf2 = do-  b <- getBit InNestedCommentBit-  if b then return (L span ITcomment_line_prag) else do-    _ <- popLexState-    lexToken--hopefully_open_brace :: Action-hopefully_open_brace span buf len buf2- = do relaxed <- getBit RelaxedLayoutBit-      ctx <- getContext-      (AI l _) <- getInput-      let offset = srcLocCol (psRealLoc l)-          isOK = relaxed ||-                 case ctx of-                 Layout prev_off _ : _ -> prev_off < offset-                 _                     -> True-      if isOK then pop_and open_brace span buf len buf2-              else addFatalError $-                     mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock--pop_and :: Action -> Action-pop_and act span buf len buf2 =-  do _ <- popLexState-     act span buf len buf2---- See Note [Whitespace-sensitive operator parsing]-followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap-followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf-precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf---- The input is the buffer *after* the token.-followedByOpeningToken' :: StringBuffer -> Bool-followedByOpeningToken' buf-  | atEnd buf = False-  | otherwise =-      case nextChar buf of-        ('{', buf') -> nextCharIsNot buf' (== '-')-        ('(', _) -> True-        ('[', _) -> True-        ('\"', _) -> True-        ('\'', _) -> True-        ('_', _) -> True-        ('⟦', _) -> True-        ('⦇', _) -> True-        (c, _) -> isAlphaNum c---- The input is the buffer *before* the token.-precededByClosingToken' :: StringBuffer -> Bool-precededByClosingToken' buf =-  case prevChar buf '\n' of-    '}' -> decodePrevNChars 1 buf /= "-"-    ')' -> True-    ']' -> True-    '\"' -> True-    '\'' -> True-    '_' -> True-    '⟧' -> True-    '⦈' -> True-    c -> isAlphaNum c--get_op_ws :: StringBuffer -> StringBuffer -> OpWs-get_op_ws buf1 buf2 =-    mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2)-  where-    mk_op_ws False True  = OpWsPrefix-    mk_op_ws True  False = OpWsSuffix-    mk_op_ws True  True  = OpWsTightInfix-    mk_op_ws False False = OpWsLooseInfix--{-# INLINE with_op_ws #-}-with_op_ws :: (OpWs -> Action) -> Action-with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2--{-# INLINE nextCharIs #-}-nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool-nextCharIs buf p = not (atEnd buf) && p (currentChar buf)--{-# INLINE nextCharIsNot #-}-nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool-nextCharIsNot buf p = not (nextCharIs buf p)--notFollowedBy :: Char -> AlexAccPred ExtsBitmap-notFollowedBy char _ _ _ (AI _ buf)-  = nextCharIsNot buf (== char)--notFollowedBySymbol :: AlexAccPred ExtsBitmap-notFollowedBySymbol _ _ _ (AI _ buf)-  = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")--followedByDigit :: AlexAccPred ExtsBitmap-followedByDigit _ _ _ (AI _ buf)-  = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))--ifCurrentChar :: Char -> AlexAccPred ExtsBitmap-ifCurrentChar char _ (AI _ buf) _ _-  = nextCharIs buf (== char)---- We must reject doc comments as being ordinary comments everywhere.--- In some cases the doc comment will be selected as the lexeme due to--- maximal munch, but not always, because the nested comment rule is--- valid in all states, but the doc-comment rules are only valid in--- the non-layout states.-isNormalComment :: AlexAccPred ExtsBitmap-isNormalComment bits _ _ (AI _ buf)-  | HaddockBit `xtest` bits = notFollowedByDocOrPragma-  | otherwise               = nextCharIsNot buf (== '#')-  where-    notFollowedByDocOrPragma-       = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))--afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool-afterOptionalSpace buf p-    = if nextCharIs buf (== ' ')-      then p (snd (nextChar buf))-      else p buf--atEOL :: AlexAccPred ExtsBitmap-atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'---- Check if we should parse a negative literal (e.g. -123) as a single token.-negLitPred :: AlexAccPred ExtsBitmap-negLitPred =-    prefix_minus `alexAndPred`-    (negative_literals `alexOrPred` lexical_negation)-  where-    negative_literals = ifExtension NegativeLiteralsBit--    lexical_negation  =-      -- See Note [Why not LexicalNegationBit]-      alexNotPred (ifExtension NoLexicalNegationBit)--    prefix_minus =-      -- Note [prefix_minus in negLitPred and negHashLitPred]-      alexNotPred precededByClosingToken---- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token.-negHashLitPred :: AlexAccPred ExtsBitmap-negHashLitPred = prefix_minus `alexAndPred` magic_hash-  where-    magic_hash = ifExtension MagicHashBit-    prefix_minus =-      -- Note [prefix_minus in negLitPred and negHashLitPred]-      alexNotPred precededByClosingToken--{- Note [prefix_minus in negLitPred and negHashLitPred]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to parse -1 as a single token, but x-1 as three tokens.-So in negLitPred (and negHashLitPred) we require that we have a prefix-occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing]-for a detailed definition of a prefix occurrence.--The condition for a prefix occurrence of an operator is:--  not precededByClosingToken && followedByOpeningToken--but we don't check followedByOpeningToken when parsing a negative literal.-It holds simply because we immediately lex a literal after the minus.--}--ifExtension :: ExtBits -> AlexAccPred ExtsBitmap-ifExtension extBits bits _ _ _ = extBits `xtest` bits--alexNotPred p userState in1 len in2-  = not (p userState in1 len in2)--alexOrPred p1 p2 userState in1 len in2-  = p1 userState in1 len in2 || p2 userState in1 len in2--multiline_doc_comment :: Action-multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker-  where-    worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input-      where-        go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of-            Just ('\n', input')-              | checkNextLine -> case checkIfCommentLine input' of-                Just input@(AI next_start _) ->  go next_start "" (locatedLine : prevLines) input -- Start a new line-                Nothing -> endComment-              | otherwise -> endComment-            Just (c, input) -> go start_loc (c:curLine) prevLines input-            Nothing -> endComment-          where-            lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc-            locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine)-            commentLines = NE.reverse $ locatedLine :| prevLines-            endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span--    -- Check if the next line of input belongs to this doc comment as well.-    -- A doc comment continues onto the next line when the following-    -- conditions are met:-    --   * The line starts with "--"-    --   * The line doesn't start with "---".-    --   * The line doesn't start with "-- $", because that would be the-    --     start of a /new/ named haddock chunk (#10398).-    checkIfCommentLine :: AlexInput -> Maybe AlexInput-    checkIfCommentLine input = check (dropNonNewlineSpace input)-      where-        check input = do-          ('-', input) <- alexGetChar' input-          ('-', input) <- alexGetChar' input-          (c, after_c) <- alexGetChar' input-          case c of-            '-' -> Nothing-            ' ' -> case alexGetChar' after_c of-                     Just ('$', _) -> Nothing-                     _ -> Just input-            _   -> Just input--        dropNonNewlineSpace input = case alexGetChar' input of-          Just (c, input')-            | isSpace c && c /= '\n' -> dropNonNewlineSpace input'-            | otherwise -> input-          Nothing -> input--lineCommentToken :: Action-lineCommentToken span buf len buf2 = do-  b <- getBit RawTokenStreamBit-  if b then do-         lt <- getLastLocComment-         strtoken (\s -> ITlineComment s lt) span buf len buf2-       else lexToken---{--  nested comments require traversing by hand, they can't be parsed-  using regular expressions.--}-nested_comment :: Action-nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do-  l <- getLastLocComment-  let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span-  input <- getInput-  -- Include decorator in comment-  let start_decorator = reverse $ lexemeToString buf len-  nested_comment_logic endComment start_decorator input span--nested_doc_comment :: Action-nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker-  where-    worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span))-      where-        endComment input lcomment-          = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span--        dropTrailingDec [] = []-        dropTrailingDec "-}" = ""-        dropTrailingDec (x:xs) = x:dropTrailingDec xs--{-# INLINE nested_comment_logic #-}--- | Includes the trailing '-}' decorators--- drop the last two elements with the callback if you don't want them to be included-nested_comment_logic-  :: (AlexInput -> Located String -> P (PsLocated Token))  -- ^ Continuation that gets the rest of the input and the lexed comment-  -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment-  -> AlexInput-  -> PsSpan-  -> P (PsLocated Token)-nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input-  where-    go commentAcc 0 input@(AI end_loc _) = do-      let comment = reverse commentAcc-          cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc-          lcomment = L cspan comment-      endComment input lcomment-    go commentAcc n input = case alexGetChar' input of-      Nothing -> errBrace input (psRealSpan span)-      Just ('-',input) -> case alexGetChar' input of-        Nothing  -> errBrace input (psRealSpan span)-        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'-        Just (_,_)          -> go ('-':commentAcc) n input-      Just ('\123',input) -> case alexGetChar' input of  -- '{' char-        Nothing  -> errBrace input (psRealSpan span)-        Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input-        Just (_,_)       -> go ('\123':commentAcc) n input-      -- See Note [Nested comment line pragmas]-      Just ('\n',input) -> case alexGetChar' input of-        Nothing  -> errBrace input (psRealSpan span)-        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input-                           go (parsedAcc ++ '\n':commentAcc) n input-        Just (_,_)   -> go ('\n':commentAcc) n input-      Just (c,input) -> go (c:commentAcc) n input---- See Note [Nested comment line pragmas]-parseNestedPragma :: AlexInput -> P (String,AlexInput)-parseNestedPragma input@(AI _ buf) = do-  origInput <- getInput-  setInput input-  setExts (.|. xbit InNestedCommentBit)-  pushLexState bol-  lt <- lexToken-  _ <- popLexState-  setExts (.&. complement (xbit InNestedCommentBit))-  postInput@(AI _ postBuf) <- getInput-  setInput origInput-  case unLoc lt of-    ITcomment_line_prag -> do-      let bytes = byteDiff buf postBuf-          diff  = lexemeToString buf bytes-      return (reverse diff, postInput)-    lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))--{--Note [Nested comment line pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to ignore cpp-preprocessor-generated #line pragmas if they were inside-nested comments.--Now, when parsing a nested comment, if we encounter a line starting with '#' we-call parseNestedPragma, which executes the following:-1. Save the current lexer input (loc, buf) for later-2. Set the current lexer input to the beginning of the line starting with '#'-3. Turn the 'InNestedComment' extension on-4. Push the 'bol' lexer state-5. Lex a token. Due to (2), (3), and (4), this should always lex a single line-   or less and return the ITcomment_line_prag token. This may set source line-   and file location if a #line pragma is successfully parsed-6. Restore lexer input and state to what they were before we did all this-7. Return control to the function parsing a nested comment, informing it of-   what the lexer parsed--Regarding (5) above:-Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)-checks if the 'InNestedComment' extension is set. If it is, that function will-return control to parseNestedPragma by returning the ITcomment_line_prag token.--See #314 for more background on the bug this fixes.--}--{-# INLINE withLexedDocType #-}-withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))-                 -> P (PsLocated Token)-withLexedDocType lexDocComment = do-  input@(AI _ buf) <- getInput-  l <- getLastLocComment-  case prevChar buf ' ' of-    -- The `Bool` argument to lexDocComment signals whether or not the next-    -- line of input might also belong to this doc comment.-    '|' -> lexDocComment input (mkHdkCommentNext l) True-    '^' -> lexDocComment input (mkHdkCommentPrev l) True-    '$' -> case lexDocName input of-       Nothing -> do setInput input; lexToken -- eof reached, lex it normally-       Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True-    '*' -> lexDocSection l 1 input-    _ -> panic "withLexedDocType: Bad doc type"- where-    lexDocSection l n input = case alexGetChar' input of-      Just ('*', input) -> lexDocSection l (n+1) input-      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection l n) False-      Nothing -> do setInput input; lexToken -- eof reached, lex it normally--    lexDocName :: AlexInput -> Maybe (String, AlexInput)-    lexDocName = go ""-      where-        go acc input = case alexGetChar' input of-          Just (c, input')-            | isSpace c -> Just (reverse acc, input)-            | otherwise -> go (c:acc) input'-          Nothing -> Nothing--mkHdkCommentNext, mkHdkCommentPrev  :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)-mkHdkCommentNext loc mkDS =  (HdkCommentNext ds,ITdocComment ds loc)-  where ds = mkDS HsDocStringNext-mkHdkCommentPrev loc mkDS =  (HdkCommentPrev ds,ITdocComment ds loc)-  where ds = mkDS HsDocStringPrevious--mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)-mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc)-  where ds = mkDS (HsDocStringNamed name)--mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)-mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)-  where ds = mkDS (HsDocStringGroup n)---- RULES pragmas turn on the forall and '.' keywords, and we turn them--- off again at the end of the pragma.-rulePrag :: Action-rulePrag span buf len _buf2 = do-  setExts (.|. xbit InRulePragBit)-  let !src = lexemeToString buf len-  return (L span (ITrules_prag (SourceText src)))---- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead--- of updating the position in 'PState'-linePrag :: Action-linePrag span buf len buf2 = do-  usePosPrags <- getBit UsePosPragsBit-  if usePosPrags-    then begin line_prag2 span buf len buf2-    else let !src = lexemeToString buf len-         in return (L span (ITline_prag (SourceText src)))---- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead--- of updating the position in 'PState'-columnPrag :: Action-columnPrag span buf len buf2 = do-  usePosPrags <- getBit UsePosPragsBit-  let !src = lexemeToString buf len-  if usePosPrags-    then begin column_prag span buf len buf2-    else let !src = lexemeToString buf len-         in return (L span (ITcolumn_prag (SourceText src)))--endPrag :: Action-endPrag span _buf _len _buf2 = do-  setExts (.&. complement (xbit InRulePragBit))-  return (L span ITclose_prag)---- docCommentEnd----------------------------------------------------------------------------------- This function is quite tricky. We can't just return a new token, we also--- need to update the state of the parser. Why? Because the token is longer--- than what was lexed by Alex, and the lexToken function doesn't know this, so--- it writes the wrong token length to the parser state. This function is--- called afterwards, so it can just update the state.--{-# INLINE commentEnd #-}-commentEnd :: P (PsLocated Token)-           -> AlexInput-           -> (Maybe HdkComment, Token)-           -> StringBuffer-           -> PsSpan-           -> P (PsLocated Token)-commentEnd cont input (m_hdk_comment, hdk_token) buf span = do-  setInput input-  let (AI loc nextBuf) = input-      span' = mkPsSpan (psSpanStart span) loc-      last_len = byteDiff buf nextBuf-  span `seq` setLastToken span' last_len-  whenIsJust m_hdk_comment $ \hdk_comment ->-    P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) ()-  b <- getBit RawTokenStreamBit-  if b then return (L span' hdk_token)-       else cont--{-# INLINE docCommentEnd #-}-docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer ->-                 PsSpan -> P (PsLocated Token)-docCommentEnd input (hdk_comment, tok) buf span-  = commentEnd lexToken input (Just hdk_comment, tok) buf span--errBrace :: AlexInput -> RealSrcSpan -> P a-errBrace (AI end _) span =-  failLocMsgP (realSrcSpanStart span)-              (psRealLoc end)-              (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF))--open_brace, close_brace :: Action-open_brace span _str _len _buf2 = do-  ctx <- getContext-  setContext (NoLayout:ctx)-  return (L span ITocurly)-close_brace span _str _len _buf2 = do-  popContext-  return (L span ITccurly)--qvarid, qconid :: StringBuffer -> Int -> Token-qvarid buf len = ITqvarid $! splitQualName buf len False-qconid buf len = ITqconid $! splitQualName buf len False--splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)--- takes a StringBuffer and a length, and returns the module name--- and identifier parts of a qualified name.  Splits at the *last* dot,--- because of hierarchical module names.------ Throws an error if the name is not qualified.-splitQualName orig_buf len parens = split orig_buf orig_buf-  where-    split buf dot_buf-        | orig_buf `byteDiff` buf >= len  = done dot_buf-        | c == '.'                        = found_dot buf'-        | otherwise                       = split buf' dot_buf-      where-       (c,buf') = nextChar buf--    -- careful, we might get names like M....-    -- so, if the character after the dot is not upper-case, this is-    -- the end of the qualifier part.-    found_dot buf -- buf points after the '.'-        | isUpper c    = split buf' buf-        | otherwise    = done buf-      where-       (c,buf') = nextChar buf--    done dot_buf-        | qual_size < 1 = error "splitQualName got an unqualified named"-        | otherwise =-        (lexemeToFastString orig_buf (qual_size - 1),-         if parens -- Prelude.(+)-            then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)-            else lexemeToFastString dot_buf (len - qual_size))-      where-        qual_size = orig_buf `byteDiff` dot_buf--varid :: Action-varid span buf len _buf2 =-  case lookupUFM reservedWordsFM fs of-    Just (ITcase, _) -> do-      lastTk <- getLastTk-      keyword <- case lastTk of-        Strict.Just (L _ ITlam) -> do-          lambdaCase <- getBit LambdaCaseBit-          unless lambdaCase $ do-            pState <- getPState-            addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase-          return ITlcase-        _ -> return ITcase-      maybe_layout keyword-      return $ L span keyword-    Just (ITlcases, _) -> do-      lastTk <- getLastTk-      lambdaCase <- getBit LambdaCaseBit-      token <- case lastTk of-        Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases-        _ -> return $ ITvarid fs-      maybe_layout token-      return $ L span token-    Just (keyword, 0) -> do-      maybe_layout keyword-      return $ L span keyword-    Just (keyword, i) -> do-      exts <- getExts-      if exts .&. i /= 0-        then do-          maybe_layout keyword-          return $ L span keyword-        else-          return $ L span $ ITvarid fs-    Nothing ->-      return $ L span $ ITvarid fs-  where-    !fs = lexemeToFastString buf len--conid :: StringBuffer -> Int -> Token-conid buf len = ITconid $! lexemeToFastString buf len--qvarsym, qconsym :: StringBuffer -> Int -> Token-qvarsym buf len = ITqvarsym $! splitQualName buf len False-qconsym buf len = ITqconsym $! splitQualName buf len False---- See Note [Whitespace-sensitive operator parsing]-varsym :: OpWs -> Action-varsym opws@OpWsPrefix = sym $ \span exts s ->-  let warnExtConflict errtok =-        do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)-           ; return (ITvarsym s) }-  in-  if | s == fsLit "@" ->-         return ITtypeApp  -- regardless of TypeApplications for better error messages-     | s == fsLit "%" ->-         if xtest LinearTypesBit exts-         then return ITpercent-         else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent-     | s == fsLit "$" ->-         if xtest ThQuotesBit exts-         then return ITdollar-         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar-     | s == fsLit "$$" ->-         if xtest ThQuotesBit exts-         then return ITdollardollar-         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar-     | s == fsLit "-" ->-         return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus-                              -- and don't hit this code path. See Note [Minus tokens]-     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts ->-         return (ITproj True) -- e.g. '(.x)'-     | s == fsLit "." -> return ITdot-     | s == fsLit "!" -> return ITbang-     | s == fsLit "~" -> return ITtilde-     | otherwise ->-         do { warnOperatorWhitespace opws span s-            ; return (ITvarsym s) }-varsym opws@OpWsSuffix = sym $ \span _ s ->-  if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)-     | s == fsLit "." -> return ITdot-     | otherwise ->-         do { warnOperatorWhitespace opws span s-            ; return (ITvarsym s) }-varsym opws@OpWsTightInfix = sym $ \span exts s ->-  if | s == fsLit "@" -> return ITat-     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)-     | s == fsLit "." -> return ITdot-     | otherwise ->-         do { warnOperatorWhitespace opws span s-            ; return (ITvarsym s) }-varsym OpWsLooseInfix = sym $ \_ _ s ->-  if | s == fsLit "."-     -> return ITdot-     | otherwise-     -> return $ ITvarsym s--consym :: OpWs -> Action-consym opws = sym $ \span _exts s ->-  do { warnOperatorWhitespace opws span s-     ; return (ITconsym s) }--warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P ()-warnOperatorWhitespace opws span s =-  whenIsJust (check_unusual_opws opws) $ \opws' ->-    addPsMessage-      (mkSrcSpanPs span)-      (PsWarnOperatorWhitespace s opws')---- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix).--- This determines if -Woperator-whitespace is triggered.-check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence-check_unusual_opws opws =-  case opws of-    OpWsPrefix     -> Just OperatorWhitespaceOccurrence_Prefix-    OpWsSuffix     -> Just OperatorWhitespaceOccurrence_Suffix-    OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix-    OpWsLooseInfix -> Nothing--sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action-sym con span buf len _buf2 =-  case lookupUFM reservedSymsFM fs of-    Just (keyword, NormalSyntax, 0) ->-      return $ L span keyword-    Just (keyword, NormalSyntax, i) -> do-      exts <- getExts-      if exts .&. i /= 0-        then return $ L span keyword-        else L span <$!> con span exts fs-    Just (keyword, UnicodeSyntax, 0) -> do-      exts <- getExts-      if xtest UnicodeSyntaxBit exts-        then return $ L span keyword-        else L span <$!> con span exts fs-    Just (keyword, UnicodeSyntax, i) -> do-      exts <- getExts-      if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts-        then return $ L span keyword-        else L span <$!> con span exts fs-    Nothing -> do-      exts <- getExts-      L span <$!> con span exts fs-  where-    !fs = lexemeToFastString buf len---- Variations on the integral numeric literal.-tok_integral :: (SourceText -> Integer -> Token)-             -> (Integer -> Integer)-             -> Int -> Int-             -> (Integer, (Char -> Int))-             -> Action-tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do-  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473-  let src = lexemeToString buf len-  when ((not numericUnderscores) && ('_' `elem` src)) $ do-    pState <- getPState-    let msg = PsErrNumUnderscores NumUnderscore_Integral-    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg-  return $ L span $ itint (SourceText src)-       $! transint $ parseUnsignedInteger-       (offsetBytes transbuf buf) (subtract translen len) radix char_to_int--tok_num :: (Integer -> Integer)-        -> Int -> Int-        -> (Integer, (Char->Int)) -> Action-tok_num = tok_integral $ \case-    st@(SourceText ('-':_)) -> itint st (const True)-    st@(SourceText _)       -> itint st (const False)-    st@NoSourceText         -> itint st (< 0)-  where-    itint :: SourceText -> (Integer -> Bool) -> Integer -> Token-    itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val)--tok_primint :: (Integer -> Integer)-            -> Int -> Int-            -> (Integer, (Char->Int)) -> Action-tok_primint = tok_integral ITprimint---tok_primword :: Int -> Int-             -> (Integer, (Char->Int)) -> Action-tok_primword = tok_integral ITprimword positive-positive, negative :: (Integer -> Integer)-positive = id-negative = negate-decimal, octal, hexadecimal :: (Integer, Char -> Int)-decimal = (10,octDecDigit)-binary = (2,octDecDigit)-octal = (8,octDecDigit)-hexadecimal = (16,hexDigit)---- readSignificandExponentPair can understand negative rationals, exponents, everything.-tok_frac :: Int -> (String -> Token) -> Action-tok_frac drop f span buf len _buf2 = do-  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473-  let src = lexemeToString buf (len-drop)-  when ((not numericUnderscores) && ('_' `elem` src)) $ do-    pState <- getPState-    let msg = PsErrNumUnderscores NumUnderscore_Float-    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg-  return (L span $! (f $! src))--tok_float, tok_primfloat, tok_primdouble :: String -> Token-tok_float        str = ITrational   $! readFractionalLit str-tok_hex_float    str = ITrational   $! readHexFractionalLit str-tok_primfloat    str = ITprimfloat  $! readFractionalLit str-tok_primdouble   str = ITprimdouble $! readFractionalLit str--readFractionalLit, readHexFractionalLit :: String -> FractionalLit-readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2-readFractionalLit = readFractionalLitX readSignificandExponentPair Base10--readFractionalLitX :: (String -> (Integer, Integer))-                   -> FractionalExponentBase-                   -> String -> FractionalLit-readFractionalLitX readStr b str =-  mkSourceFractionalLit str is_neg i e b-  where-    is_neg = case str of-                    '-' : _ -> True-                    _      -> False-    (i, e) = readStr str---- -------------------------------------------------------------------------------- Layout processing---- we're at the first token on a line, insert layout tokens if necessary-do_bol :: Action-do_bol span _str _len _buf2 = do-        -- See Note [Nested comment line pragmas]-        b <- getBit InNestedCommentBit-        if b then return (L span ITcomment_line_prag) else do-          (pos, gen_semic) <- getOffside-          case pos of-              LT -> do-                  --trace "layout: inserting '}'" $ do-                  popContext-                  -- do NOT pop the lex state, we might have a ';' to insert-                  return (L span ITvccurly)-              EQ | gen_semic -> do-                  --trace "layout: inserting ';'" $ do-                  _ <- popLexState-                  return (L span ITsemi)-              _ -> do-                  _ <- popLexState-                  lexToken---- certain keywords put us in the "layout" state, where we might--- add an opening curly brace.-maybe_layout :: Token -> P ()-maybe_layout t = do -- If the alternative layout rule is enabled then-                    -- we never create an implicit layout context here.-                    -- Layout is handled XXX instead.-                    -- The code for closing implicit contexts, or-                    -- inserting implicit semi-colons, is therefore-                    -- irrelevant as it only applies in an implicit-                    -- context.-                    alr <- getBit AlternativeLayoutRuleBit-                    unless alr $ f t-    where f (ITdo _)    = pushLexState layout_do-          f (ITmdo _)   = pushLexState layout_do-          f ITof        = pushLexState layout-          f ITlcase     = pushLexState layout-          f ITlcases    = pushLexState layout-          f ITlet       = pushLexState layout-          f ITwhere     = pushLexState layout-          f ITrec       = pushLexState layout-          f ITif        = pushLexState layout_if-          f _           = return ()---- Pushing a new implicit layout context.  If the indentation of the--- next token is not greater than the previous layout context, then--- Haskell 98 says that the new layout context should be empty; that is--- the lexer must generate {}.------ We are slightly more lenient than this: when the new context is started--- by a 'do', then we allow the new context to be at the same indentation as--- the previous context.  This is what the 'strict' argument is for.-new_layout_context :: Bool -> Bool -> Token -> Action-new_layout_context strict gen_semic tok span _buf len _buf2 = do-    _ <- popLexState-    (AI l _) <- getInput-    let offset = srcLocCol (psRealLoc l) - len-    ctx <- getContext-    nondecreasing <- getBit NondecreasingIndentationBit-    let strict' = strict || not nondecreasing-    case ctx of-        Layout prev_off _ : _  |-           (strict'     && prev_off >= offset  ||-            not strict' && prev_off > offset) -> do-                -- token is indented to the left of the previous context.-                -- we must generate a {} sequence now.-                pushLexState layout_left-                return (L span tok)-        _ -> do setContext (Layout offset gen_semic : ctx)-                return (L span tok)--do_layout_left :: Action-do_layout_left span _buf _len _buf2 = do-    _ <- popLexState-    pushLexState bol  -- we must be at the start of a line-    return (L span ITvccurly)---- -------------------------------------------------------------------------------- LINE pragmas--setLineAndFile :: Int -> Action-setLineAndFile code (PsSpan span _) buf len _buf2 = do-  let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark-      linenumLen = length $ head $ words src-      linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit-      file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src-          -- skip everything through first quotation mark to get to the filename-        where go ('\\':c:cs) = c : go cs-              go (c:cs)      = c : go cs-              go []          = []-              -- decode escapes in the filename.  e.g. on Windows-              -- when our filenames have backslashes in, gcc seems to-              -- escape the backslashes.  One symptom of not doing this-              -- is that filenames in error messages look a bit strange:-              --   C:\\foo\bar.hs-              -- only the first backslash is doubled, because we apply-              -- System.FilePath.normalise before printing out-              -- filenames and it does not remove duplicate-              -- backslashes after the drive letter (should it?).-  resetAlrLastLoc file-  setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))-      -- subtract one: the line number refers to the *following* line-  addSrcFile file-  _ <- popLexState-  pushLexState code-  lexToken--setColumn :: Action-setColumn (PsSpan span _) buf len _buf2 = do-  let column =-        case reads (lexemeToString buf len) of-          [(column, _)] -> column-          _ -> error "setColumn: expected integer" -- shouldn't happen-  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)-                          (fromIntegral (column :: Integer)))-  _ <- popLexState-  lexToken--alrInitialLoc :: FastString -> RealSrcSpan-alrInitialLoc file = mkRealSrcSpan loc loc-    where -- This is a hack to ensure that the first line in a file-          -- looks like it is after the initial location:-          loc = mkRealSrcLoc file (-1) (-1)---- -------------------------------------------------------------------------------- Options, includes and language pragmas.---lex_string_prag :: (String -> Token) -> Action-lex_string_prag mkTok = lex_string_prag_comment mkTok'-  where-    mkTok' s _ = mkTok s--lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action-lex_string_prag_comment mkTok span _buf _len _buf2-    = do input <- getInput-         start <- getParsedLoc-         l <- getLastLocComment-         tok <- go l [] input-         end <- getParsedLoc-         return (L (mkPsSpan start end) tok)-    where go l acc input-              = if isString input "#-}"-                   then do setInput input-                           return (mkTok (reverse acc) l)-                   else case alexGetChar input of-                          Just (c,i) -> go l (c:acc) i-                          Nothing -> err input-          isString _ [] = True-          isString i (x:xs)-              = case alexGetChar i of-                  Just (c,i') | c == x    -> isString i' xs-                  _other -> False-          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span))-                                       (psRealLoc end)-                                       (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF)---- -------------------------------------------------------------------------------- Strings & Chars---- This stuff is horrible.  I hates it.--lex_string_tok :: Action-lex_string_tok span buf _len _buf2 = do-  lexed <- lex_string-  (AI end bufEnd) <- getInput-  let-    tok = case lexed of-      LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s)-      LexedRegularString s -> ITstring (SourceText src) (mkFastString s)-    src = lexemeToString buf (cur bufEnd - cur buf)-  return $ L (mkPsSpan (psSpanStart span) end) tok---lex_quoted_label :: Action-lex_quoted_label span buf _len _buf2 = do-  start <- getInput-  s <- lex_string_helper "" start-  (AI end bufEnd) <- getInput-  let-    token = ITlabelvarid (SourceText src) (mkFastString s)-    src = lexemeToString (stepOn buf) (cur bufEnd - cur buf - 1)-    start = psSpanStart span--  return $ L (mkPsSpan start end) token---data LexedString = LexedRegularString String | LexedPrimString String--lex_string :: P LexedString-lex_string = do-  start <- getInput-  s <- lex_string_helper "" start-  magicHash <- getBit MagicHashBit-  if magicHash-    then do-      i <- getInput-      case alexGetChar' i of-        Just ('#',i) -> do-          setInput i-          when (any (> '\xFF') s) $ do-            pState <- getPState-            let msg = PsErrPrimStringInvalidChar-            let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg-            addError err-          return $ LexedPrimString s-        _other ->-          return $ LexedRegularString s-    else-      return $ LexedRegularString s---lex_string_helper :: String -> AlexInput -> P String-lex_string_helper s start = do-  i <- getInput-  case alexGetChar' i of-    Nothing -> lit_error i--    Just ('"',i)  -> do-      setInput i-      return (reverse s)--    Just ('\\',i)-        | Just ('&',i) <- next -> do-                setInput i; lex_string_helper s start-        | Just (c,i) <- next, c <= '\x7f' && is_space c -> do-                           -- is_space only works for <= '\x7f' (#3751, #5425)-                setInput i; lex_stringgap s start-        where next = alexGetChar' i--    Just (c, i1) -> do-        case c of-          '\\' -> do setInput i1; c' <- lex_escape; lex_string_helper (c':s) start-          c | isAny c -> do setInput i1; lex_string_helper (c:s) start-          _other | any isDoubleSmartQuote s -> do-            -- if the built-up string s contains a smart double quote character, it was-            -- likely the reason why the string literal was not lexed correctly-            setInput start -- rewind to the first character in the string literal-                           -- so we can find the smart quote character's location-            advance_to_smart_quote_character-            i2@(AI loc _) <- getInput-            case alexGetChar' i2 of-              Just (c, _) -> do add_nonfatal_smart_quote_error c loc; lit_error i-              Nothing -> lit_error i -- should never get here-          _other -> lit_error i---lex_stringgap :: String -> AlexInput -> P String-lex_stringgap s start = do-  i <- getInput-  c <- getCharOrFail i-  case c of-    '\\' -> lex_string_helper s start-    c | c <= '\x7f' && is_space c -> lex_stringgap s start-                           -- is_space only works for <= '\x7f' (#3751, #5425)-    _other -> lit_error i---lex_char_tok :: Action--- Here we are basically parsing character literals, such as 'x' or '\n'--- but we additionally spot 'x and ''T, returning ITsimpleQuote and--- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part--- (the parser does that).--- So we have to do two characters of lookahead: when we see 'x we need to--- see if there's a trailing quote-lex_char_tok span buf _len _buf2 = do        -- We've seen '-   i1 <- getInput       -- Look ahead to first character-   let loc = psSpanStart span-   case alexGetChar' i1 of-        Nothing -> lit_error  i1--        Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''-                   setInput i2-                   return (L (mkPsSpan loc end2)  ITtyQuote)--        Just ('\\', i2@(AI end2 _)) -> do      -- We've seen 'backslash-                  setInput i2-                  lit_ch <- lex_escape-                  i3 <- getInput-                  mc <- getCharOrFail i3 -- Trailing quote-                  if mc == '\'' then finish_char_tok buf loc lit_ch-                  else if isSingleSmartQuote mc then add_smart_quote_error mc end2-                  else lit_error i3--        Just (c, i2@(AI end2 _))-                | not (isAny c) -> lit_error i1-                | otherwise ->--                -- We've seen 'x, where x is a valid character-                --  (i.e. not newline etc) but not a quote or backslash-           case alexGetChar' i2 of      -- Look ahead one more character-                Just ('\'', i3) -> do   -- We've seen 'x'-                        setInput i3-                        finish_char_tok buf loc c-                Just (c, _) | isSingleSmartQuote c -> add_smart_quote_error c end2-                _other -> do            -- We've seen 'x not followed by quote-                                        -- (including the possibility of EOF)-                                        -- Just parse the quote only-                        let (AI end _) = i1-                        return (L (mkPsSpan loc end) ITsimpleQuote)--finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token)-finish_char_tok buf loc ch  -- We've already seen the closing quote-                        -- Just need to check for trailing #-  = do  magicHash <- getBit MagicHashBit-        i@(AI end bufEnd) <- getInput-        let src = lexemeToString buf (cur bufEnd - cur buf)-        if magicHash then do-            case alexGetChar' i of-              Just ('#',i@(AI end bufEnd')) -> do-                setInput i-                -- Include the trailing # in SourceText-                let src' = lexemeToString buf (cur bufEnd' - cur buf)-                return (L (mkPsSpan loc end)-                          (ITprimchar (SourceText src') ch))-              _other ->-                return (L (mkPsSpan loc end)-                          (ITchar (SourceText src) ch))-            else do-              return (L (mkPsSpan loc end) (ITchar (SourceText src) ch))--isAny :: Char -> Bool-isAny c | c > '\x7f' = isPrint c-        | otherwise  = is_any c--lex_escape :: P Char-lex_escape = do-  i0@(AI loc _) <- getInput-  c <- getCharOrFail i0-  case c of-        'a'   -> return '\a'-        'b'   -> return '\b'-        'f'   -> return '\f'-        'n'   -> return '\n'-        'r'   -> return '\r'-        't'   -> return '\t'-        'v'   -> return '\v'-        '\\'  -> return '\\'-        '"'   -> return '\"'-        '\''  -> return '\''-        -- the next two patterns build up a Unicode smart quote error (#21843)-        smart_double_quote | isDoubleSmartQuote smart_double_quote ->-          add_smart_quote_error smart_double_quote loc-        smart_single_quote | isSingleSmartQuote smart_single_quote ->-          add_smart_quote_error smart_single_quote loc-        '^'   -> do i1 <- getInput-                    c <- getCharOrFail i1-                    if c >= '@' && c <= '_'-                        then return (chr (ord c - ord '@'))-                        else lit_error i1--        'x'   -> readNum is_hexdigit 16 hexDigit-        'o'   -> readNum is_octdigit  8 octDecDigit-        x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)--        c1 ->  do-           i <- getInput-           case alexGetChar' i of-            Nothing -> lit_error i0-            Just (c2,i2) ->-              case alexGetChar' i2 of-                Nothing -> do lit_error i0-                Just (c3,i3) ->-                   let str = [c1,c2,c3] in-                   case [ (c,rest) | (p,c) <- silly_escape_chars,-                                     Just rest <- [stripPrefix p str] ] of-                          (escape_char,[]):_ -> do-                                setInput i3-                                return escape_char-                          (escape_char,_:_):_ -> do-                                setInput i2-                                return escape_char-                          [] -> lit_error i0--readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char-readNum is_digit base conv = do-  i <- getInput-  c <- getCharOrFail i-  if is_digit c-        then readNum2 is_digit base conv (conv c)-        else lit_error i--readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char-readNum2 is_digit base conv i = do-  input <- getInput-  read i input-  where read i input = do-          case alexGetChar' input of-            Just (c,input') | is_digit c -> do-               let i' = i*base + conv c-               if i' > 0x10ffff-                  then setInput input >> lexError LexNumEscapeRange-                  else read i' input'-            _other -> do-              setInput input; return (chr i)---silly_escape_chars :: [(String, Char)]-silly_escape_chars = [-        ("NUL", '\NUL'),-        ("SOH", '\SOH'),-        ("STX", '\STX'),-        ("ETX", '\ETX'),-        ("EOT", '\EOT'),-        ("ENQ", '\ENQ'),-        ("ACK", '\ACK'),-        ("BEL", '\BEL'),-        ("BS", '\BS'),-        ("HT", '\HT'),-        ("LF", '\LF'),-        ("VT", '\VT'),-        ("FF", '\FF'),-        ("CR", '\CR'),-        ("SO", '\SO'),-        ("SI", '\SI'),-        ("DLE", '\DLE'),-        ("DC1", '\DC1'),-        ("DC2", '\DC2'),-        ("DC3", '\DC3'),-        ("DC4", '\DC4'),-        ("NAK", '\NAK'),-        ("SYN", '\SYN'),-        ("ETB", '\ETB'),-        ("CAN", '\CAN'),-        ("EM", '\EM'),-        ("SUB", '\SUB'),-        ("ESC", '\ESC'),-        ("FS", '\FS'),-        ("GS", '\GS'),-        ("RS", '\RS'),-        ("US", '\US'),-        ("SP", '\SP'),-        ("DEL", '\DEL')-        ]---- before calling lit_error, ensure that the current input is pointing to--- the position of the error in the buffer.  This is so that we can report--- a correct location to the user, but also so we can detect UTF-8 decoding--- errors if they occur.-lit_error :: AlexInput -> P a-lit_error i = do setInput i; lexError LexStringCharLit--getCharOrFail :: AlexInput -> P Char-getCharOrFail i =  do-  case alexGetChar' i of-        Nothing -> lexError LexStringCharLitEOF-        Just (c,i)  -> do setInput i; return c---- -------------------------------------------------------------------------------- QuasiQuote--lex_qquasiquote_tok :: Action-lex_qquasiquote_tok span buf len _buf2 = do-  let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False-  quoteStart <- getParsedLoc-  quote <- lex_quasiquote (psRealLoc quoteStart) ""-  end <- getParsedLoc-  return (L (mkPsSpan (psSpanStart span) end)-           (ITqQuasiQuote (qual,-                           quoter,-                           mkFastString (reverse quote),-                           mkPsSpan quoteStart end)))--lex_quasiquote_tok :: Action-lex_quasiquote_tok span buf len _buf2 = do-  let quoter = tail (lexemeToString buf (len - 1))-                -- 'tail' drops the initial '[',-                -- while the -1 drops the trailing '|'-  quoteStart <- getParsedLoc-  quote <- lex_quasiquote (psRealLoc quoteStart) ""-  end <- getParsedLoc-  return (L (mkPsSpan (psSpanStart span) end)-           (ITquasiQuote (mkFastString quoter,-                          mkFastString (reverse quote),-                          mkPsSpan quoteStart end)))--lex_quasiquote :: RealSrcLoc -> String -> P String-lex_quasiquote start s = do-  i <- getInput-  case alexGetChar' i of-    Nothing -> quasiquote_error start--    -- NB: The string "|]" terminates the quasiquote,-    -- with absolutely no escaping. See the extensive-    -- discussion on #5348 for why there is no-    -- escape handling.-    Just ('|',i)-        | Just (']',i) <- alexGetChar' i-        -> do { setInput i; return s }--    Just (c, i) -> do-         setInput i; lex_quasiquote start (c : s)--quasiquote_error :: RealSrcLoc -> P a-quasiquote_error start = do-  (AI end buf) <- getInput-  reportLexError start (psRealLoc end) buf-    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k))---- -------------------------------------------------------------------------------- Unicode Smart Quote detection (#21843)--isDoubleSmartQuote :: Char -> Bool-isDoubleSmartQuote '“' = True-isDoubleSmartQuote '”' = True-isDoubleSmartQuote _ = False--isSingleSmartQuote :: Char -> Bool-isSingleSmartQuote '‘' = True-isSingleSmartQuote '’' = True-isSingleSmartQuote _ = False--isSmartQuote :: AlexAccPred ExtsBitmap-isSmartQuote _ _ _ (AI _ buf) = let c = prevChar buf ' ' in isSingleSmartQuote c || isDoubleSmartQuote c--smart_quote_error_message :: Char -> PsLoc -> MsgEnvelope PsMessage-smart_quote_error_message c loc =-  let (correct_char, correct_char_name) =-         if isSingleSmartQuote c then ('\'', "Single Quote") else ('"', "Quotation Mark")-      err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (mkPsSpan loc loc)) $-              PsErrUnicodeCharLooksLike c correct_char correct_char_name in-    err--smart_quote_error :: Action-smart_quote_error span buf _len _buf2 = do-  let c = currentChar buf-  addFatalError (smart_quote_error_message c (psSpanStart span))--add_smart_quote_error :: Char -> PsLoc -> P a-add_smart_quote_error c loc = addFatalError (smart_quote_error_message c loc)--add_nonfatal_smart_quote_error :: Char -> PsLoc -> P ()-add_nonfatal_smart_quote_error c loc = addError (smart_quote_error_message c loc)--advance_to_smart_quote_character :: P ()-advance_to_smart_quote_character  = do-  i <- getInput-  case alexGetChar' i of-    Just (c, _) | isDoubleSmartQuote c -> return ()-    Just (_, i2) -> do setInput i2; advance_to_smart_quote_character-    Nothing -> return () -- should never get here---- -------------------------------------------------------------------------------- Warnings--warnTab :: Action-warnTab srcspan _buf _len _buf2 = do-    addTabWarning (psRealSpan srcspan)-    lexToken--warnThen :: PsMessage -> Action -> Action-warnThen warning action srcspan buf len buf2 = do-    addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning-    action srcspan buf len buf2---- -------------------------------------------------------------------------------- The Parse Monad---- | Do we want to generate ';' layout tokens? In some cases we just want to--- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates--- alternatives (unlike a `case` expression where we need ';' to as a separator--- between alternatives).-type GenSemic = Bool--generateSemic, dontGenerateSemic :: GenSemic-generateSemic     = True-dontGenerateSemic = False--data LayoutContext-  = NoLayout-  | Layout !Int !GenSemic-  deriving Show---- | The result of running a parser.-newtype ParseResult a = PR (# (# PState, a #) | PState #)---- | The parser has consumed a (possibly empty) prefix of the input and produced--- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal--- errors.------ The carried parsing state can be used to resume parsing.-pattern POk :: PState -> a -> ParseResult a-pattern POk s a = PR (# (# s , a #) | #)---- | The parser has consumed a (possibly empty) prefix of the input and failed.------ The carried parsing state can be used to resume parsing. It is the state--- right before failure, including the fatal parse error. 'getPsMessages' and--- 'getPsErrorMessages' must return a non-empty bag of errors.-pattern PFailed :: PState -> ParseResult a-pattern PFailed s = PR (# | s #)--{-# COMPLETE POk, PFailed #-}---- | Test whether a 'WarningFlag' is set-warnopt :: WarningFlag -> ParserOpts -> Bool-warnopt f options = f `EnumSet.member` pWarningFlags options---- | Parser options.------ See 'mkParserOpts' to construct this.-data ParserOpts = ParserOpts-  { 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-pWarningFlags opts = diag_warning_flags (pDiagOpts opts)---- | Haddock comment as produced by the lexer. These are accumulated in 'PState'--- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the--- 'HsDocString's spans over the contents of the docstring - i.e. it does not--- include the decorator ("-- |", "{-|" etc.)-data HdkComment-  = HdkCommentNext HsDocString-  | HdkCommentPrev HsDocString-  | HdkCommentNamed String HsDocString-  | HdkCommentSection Int HsDocString-  deriving Show--data PState = PState {-        buffer     :: StringBuffer,-        options    :: ParserOpts,-        warnings   :: Messages PsMessage,-        errors     :: Messages PsMessage,-        tab_first  :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file-        tab_count  :: !Word,             -- number of tab warnings in the file-        last_tk    :: Strict.Maybe (PsLocated Token), -- last non-comment token-        prev_loc   :: PsSpan,      -- pos of previous token, including comments,-        prev_loc2  :: PsSpan,      -- pos of two back token, including comments,-                                   -- see Note [PsSpan in Comments]-        last_loc   :: PsSpan,      -- pos of current token-        last_len   :: !Int,        -- len of current token-        loc        :: PsLoc,       -- current loc (end of prev token + 1)-        context    :: [LayoutContext],-        lex_state  :: [Int],-        srcfiles   :: [FastString],-        -- Used in the alternative layout rule:-        -- These tokens are the next ones to be sent out. They are-        -- just blindly emitted, without the rule looking at them again:-        alr_pending_implicit_tokens :: [PsLocated Token],-        -- This is the next token to be considered or, if it is Nothing,-        -- we need to get the next token from the input stream:-        alr_next_token :: Maybe (PsLocated Token),-        -- This is what we consider to be the location of the last token-        -- emitted:-        alr_last_loc :: PsSpan,-        -- The stack of layout contexts:-        alr_context :: [ALRContext],-        -- Are we expecting a '{'? If it's Just, then the ALRLayout tells-        -- us what sort of layout the '{' will open:-        alr_expecting_ocurly :: Maybe ALRLayout,-        -- Have we just had the '}' for a let block? If so, than an 'in'-        -- token doesn't need to close anything:-        alr_justClosedExplicitLetBlock :: Bool,--        -- The next three are used to implement Annotations giving the-        -- locations of 'noise' tokens in the source, so that users of-        -- the GHC API can do source to source conversions.-        -- See Note [exact print annotations] in GHC.Parser.Annotation-        eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token-        header_comments :: Strict.Maybe [LEpaComment],-        comment_q :: [LEpaComment],--        -- Haddock comments accumulated in ascending order of their location-        -- (BufPos). We use OrdList to get O(1) snoc.-        ---        -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock-        hdk_comments :: OrdList (PsLocated HdkComment)-     }-        -- last_loc and last_len are used when generating error messages,-        -- and in pushCurrentContext only.  Sigh, if only Happy passed the-        -- current token to happyError, we could at least get rid of last_len.-        -- Getting rid of last_loc would require finding another way to-        -- implement pushCurrentContext (which is only called from one place).--        -- AZ question: setLastToken which sets last_loc and last_len-        -- is called when processing AlexToken, immediately prior to-        -- calling the action in the token.  So from the perspective-        -- of the action, it is the *current* token.  Do I understand-        -- correctly?--data ALRContext = ALRNoLayout Bool{- does it contain commas? -}-                              Bool{- is it a 'let' block? -}-                | ALRLayout ALRLayout Int-data ALRLayout = ALRLayoutLet-               | ALRLayoutWhere-               | ALRLayoutOf-               | ALRLayoutDo---- | The parsing monad, isomorphic to @StateT PState Maybe@.-newtype P a = P { unP :: PState -> ParseResult a }--instance Functor P where-  fmap = liftM--instance Applicative P where-  pure = returnP-  (<*>) = ap--instance Monad P where-  (>>=) = thenP--returnP :: a -> P a-returnP a = a `seq` (P $ \s -> POk s a)--thenP :: P a -> (a -> P b) -> P b-(P m) `thenP` k = P $ \ s ->-        case m s of-                POk s1 a         -> (unP (k a)) s1-                PFailed s1 -> PFailed s1--failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a-failMsgP f = do-  pState <- getPState-  addFatalError (f (mkSrcSpanPs (last_loc pState)))--failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a-failLocMsgP loc1 loc2 f =-  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))--getPState :: P PState-getPState = P $ \s -> POk s s--getExts :: P ExtsBitmap-getExts = P $ \s -> POk s (pExtsBitmap . options $ s)--setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()-setExts f = P $ \s -> POk s {-  options =-    let p = options s-    in  p { pExtsBitmap = f (pExtsBitmap p) }-  } ()--setSrcLoc :: RealSrcLoc -> P ()-setSrcLoc new_loc =-  P $ \s@(PState{ loc = PsLoc _ buf_loc }) ->-  POk s{ loc = PsLoc new_loc buf_loc } ()--getRealSrcLoc :: P RealSrcLoc-getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc)--getParsedLoc :: P PsLoc-getParsedLoc  = P $ \s@(PState{ loc=loc }) -> POk s loc--addSrcFile :: FastString -> P ()-addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()--setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()-setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } ()--setLastToken :: PsSpan -> Int -> P ()-setLastToken loc len = P $ \s -> POk s {-  last_loc=loc,-  last_len=len-  } ()--setLastTk :: PsLocated Token -> P ()-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk-                                       , prev_loc = l-                                       , prev_loc2 = prev_loc s} ()--setLastComment :: PsLocated Token -> P ()-setLastComment (L l _) = P $ \s -> POk s { prev_loc = l-                                         , prev_loc2 = prev_loc s} ()--getLastTk :: P (Strict.Maybe (PsLocated Token))-getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk---- see Note [PsSpan in Comments]-getLastLocComment :: P PsSpan-getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc---- see Note [PsSpan in Comments]-getLastLocEof :: P PsSpan-getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2--getLastLoc :: P PsSpan-getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc--data AlexInput = AI !PsLoc !StringBuffer--{--Note [Unicode in Alex]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Although newer versions of Alex support unicode, this grammar is processed with-the old style '--latin1' behaviour. This means that when implementing the-functions--    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)-    alexInputPrevChar :: AlexInput -> Char--which Alex uses to take apart our 'AlexInput', we must--  * return a latin1 character in the 'Word8' that 'alexGetByte' expects-  * return a latin1 character in 'alexInputPrevChar'.--We handle this in 'adjustChar' by squishing entire classes of unicode-characters into single bytes.--}--{-# INLINE adjustChar #-}-adjustChar :: Char -> Word8-adjustChar c = fromIntegral $ ord adj_c-  where non_graphic     = '\x00'-        upper           = '\x01'-        lower           = '\x02'-        digit           = '\x03'-        symbol          = '\x04'-        space           = '\x05'-        other_graphic   = '\x06'-        uniidchar       = '\x07'--        adj_c-          | c <= '\x07' = non_graphic-          | c <= '\x7f' = c-          -- Alex doesn't handle Unicode, so when Unicode-          -- character is encountered we output these values-          -- with the actual character value hidden in the state.-          | otherwise =-                -- NB: The logic behind these definitions is also reflected-                -- in "GHC.Utils.Lexeme"-                -- Any changes here should likely be reflected there.--                case generalCategory c of-                  UppercaseLetter       -> upper-                  LowercaseLetter       -> lower-                  TitlecaseLetter       -> upper-                  ModifierLetter        -> uniidchar -- see #10196-                  OtherLetter           -> lower -- see #1103-                  NonSpacingMark        -> uniidchar -- see #7650-                  SpacingCombiningMark  -> other_graphic-                  EnclosingMark         -> other_graphic-                  DecimalNumber         -> digit-                  LetterNumber          -> digit-                  OtherNumber           -> digit -- see #4373-                  ConnectorPunctuation  -> symbol-                  DashPunctuation       -> symbol-                  OpenPunctuation       -> other_graphic-                  ClosePunctuation      -> other_graphic-                  InitialQuote          -> other_graphic-                  FinalQuote            -> other_graphic-                  OtherPunctuation      -> symbol-                  MathSymbol            -> symbol-                  CurrencySymbol        -> symbol-                  ModifierSymbol        -> symbol-                  OtherSymbol           -> symbol-                  Space                 -> space-                  _other                -> non_graphic---- Getting the previous 'Char' isn't enough here - we need to convert it into--- the same format that 'alexGetByte' would have produced.------ See Note [Unicode in Alex] and #13986.-alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))-  where pc = prevChar buf '\n'---- backwards compatibility for Alex 2.x-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar inp = case alexGetByte inp of-                    Nothing    -> Nothing-                    Just (b,i) -> c `seq` Just (c,i)-                       where c = chr $ fromIntegral b---- See Note [Unicode in Alex]-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)-alexGetByte (AI loc s)-  | atEnd s   = Nothing-  | otherwise = byte `seq` loc' `seq` s' `seq`-                --trace (show (ord c)) $-                Just (byte, (AI loc' s'))-  where (c,s') = nextChar s-        loc'   = advancePsLoc loc c-        byte   = adjustChar c--{-# INLINE alexGetChar' #-}--- This version does not squash unicode characters, it is used when--- lexing strings.-alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar' (AI loc s)-  | atEnd s   = Nothing-  | otherwise = c `seq` loc' `seq` s' `seq`-                --trace (show (ord c)) $-                Just (c, (AI loc' s'))-  where (c,s') = nextChar s-        loc'   = advancePsLoc loc c--getInput :: P AlexInput-getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)--setInput :: AlexInput -> P ()-setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()--nextIsEOF :: P Bool-nextIsEOF = do-  AI _ s <- getInput-  return $ atEnd s--pushLexState :: Int -> P ()-pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()--popLexState :: P Int-popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls--getLexState :: P Int-getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls--popNextToken :: P (Maybe (PsLocated Token))-popNextToken-    = P $ \s@PState{ alr_next_token = m } ->-              POk (s {alr_next_token = Nothing}) m--activeContext :: P Bool-activeContext = do-  ctxt <- getALRContext-  expc <- getAlrExpectingOCurly-  impt <- implicitTokenPending-  case (ctxt,expc) of-    ([],Nothing) -> return impt-    _other       -> return True--resetAlrLastLoc :: FastString -> P ()-resetAlrLastLoc file =-  P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) ->-  POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } ()--setAlrLastLoc :: PsSpan -> P ()-setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()--getAlrLastLoc :: P PsSpan-getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l--getALRContext :: P [ALRContext]-getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs--setALRContext :: [ALRContext] -> P ()-setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()--getJustClosedExplicitLetBlock :: P Bool-getJustClosedExplicitLetBlock- = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b--setJustClosedExplicitLetBlock :: Bool -> P ()-setJustClosedExplicitLetBlock b- = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()--setNextToken :: PsLocated Token -> P ()-setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()--implicitTokenPending :: P Bool-implicitTokenPending-    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->-              case ts of-              [] -> POk s False-              _  -> POk s True--popPendingImplicitToken :: P (Maybe (PsLocated Token))-popPendingImplicitToken-    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->-              case ts of-              [] -> POk s Nothing-              (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)--setPendingImplicitTokens :: [PsLocated Token] -> P ()-setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()--getAlrExpectingOCurly :: P (Maybe ALRLayout)-getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b--setAlrExpectingOCurly :: Maybe ALRLayout -> P ()-setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()---- | For reasons of efficiency, boolean parsing flags (eg, language extensions--- or whether we are currently in a @RULE@ pragma) are represented by a bitmap--- stored in a @Word64@.-type ExtsBitmap = Word64--xbit :: ExtBits -> ExtsBitmap-xbit = bit . fromEnum--xtest :: ExtBits -> ExtsBitmap -> Bool-xtest ext xmap = testBit xmap (fromEnum ext)--xset :: ExtBits -> ExtsBitmap -> ExtsBitmap-xset ext xmap = setBit xmap (fromEnum ext)--xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap-xunset ext xmap = clearBit xmap (fromEnum ext)---- | Various boolean flags, mostly language extensions, that impact lexing and--- parsing. Note that a handful of these can change during lexing/parsing.-data ExtBits-  -- Flags that are constant once parsing starts-  = FfiBit-  | InterruptibleFfiBit-  | CApiFfiBit-  | ArrowsBit-  | ThBit-  | ThQuotesBit-  | IpBit-  | OverloadedLabelsBit -- #x overloaded labels-  | ExplicitForallBit -- the 'forall' keyword-  | BangPatBit -- Tells the parser to understand bang-patterns-               -- (doesn't affect the lexer)-  | PatternSynonymsBit -- pattern synonyms-  | HaddockBit-- Lex and parse Haddock comments-  | MagicHashBit -- "#" in both functions and operators-  | RecursiveDoBit -- mdo-  | QualifiedDoBit -- .do and .mdo-  | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc-  | UnboxedParensBit -- (# and #)-  | DatatypeContextsBit-  | MonadComprehensionsBit-  | TransformComprehensionsBit-  | QqBit -- enable quasiquoting-  | RawTokenStreamBit -- producing a token stream with all comments included-  | AlternativeLayoutRuleBit-  | ALRTransitionalBit-  | RelaxedLayoutBit-  | NondecreasingIndentationBit-  | SafeHaskellBit-  | TraditionalRecordSyntaxBit-  | ExplicitNamespacesBit-  | LambdaCaseBit-  | BinaryLiteralsBit-  | NegativeLiteralsBit-  | HexFloatLiteralsBit-  | StaticPointersBit-  | NumericUnderscoresBit-  | StarIsTypeBit-  | BlockArgumentsBit-  | NPlusKPatternsBit-  | DoAndIfThenElseBit-  | MultiWayIfBit-  | GadtSyntaxBit-  | ImportQualifiedPostBit-  | LinearTypesBit-  | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]-  | OverloadedRecordDotBit-  | OverloadedRecordUpdateBit--  -- Flags that are updated once parsing starts-  | InRulePragBit-  | InNestedCommentBit -- See Note [Nested comment line pragmas]-  | UsePosPragsBit-    -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'-    -- update the internal position. Otherwise, those pragmas are lexed as-    -- tokens of their own.-  deriving Enum--{-# INLINE mkParserOpts #-}-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--  -> Bool-  -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update-  -- the internal position kept by the parser. Otherwise, those pragmas are-  -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.--  -> ParserOpts--- ^ Given exactly the information needed, set up the 'ParserOpts'-mkParserOpts extensionFlags diag_opts supported-  safeImports isHaddock rawTokStream usePosPrags =-    ParserOpts {-      pDiagOpts      = diag_opts-    , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits-    , pSupportedExts = supported-    }-  where-    safeHaskellBit = SafeHaskellBit `setBitIf` safeImports-    langExtBits =-          FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface-      .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI-      .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI-      .|. ArrowsBit                   `xoptBit` LangExt.Arrows-      .|. ThBit                       `xoptBit` LangExt.TemplateHaskell-      .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes-      .|. QqBit                       `xoptBit` LangExt.QuasiQuotes-      .|. IpBit                       `xoptBit` LangExt.ImplicitParams-      .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels-      .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll-      .|. BangPatBit                  `xoptBit` LangExt.BangPatterns-      .|. MagicHashBit                `xoptBit` LangExt.MagicHash-      .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo-      .|. QualifiedDoBit              `xoptBit` LangExt.QualifiedDo-      .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax-      .|. UnboxedParensBit            `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums]-      .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts-      .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp-      .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions-      .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule-      .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional-      .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout-      .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation-      .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax-      .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces-      .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase-      .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals-      .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals-      .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals-      .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms-      .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers-      .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores-      .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType-      .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments-      .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns-      .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse-      .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf-      .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax-      .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost-      .|. LinearTypesBit              `xoptBit` LangExt.LinearTypes-      .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]-      .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot-      .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).-    optBits =-          HaddockBit        `setBitIf` isHaddock-      .|. RawTokenStreamBit `setBitIf` rawTokStream-      .|. UsePosPragsBit    `setBitIf` usePosPrags--    xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags-    xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags)--    orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts--    setBitIf :: ExtBits -> Bool -> ExtsBitmap-    b `setBitIf` cond | cond      = xbit b-                      | otherwise = 0--disableHaddock :: ParserOpts -> ParserOpts-disableHaddock opts = upd_bitmap (xunset HaddockBit)-  where-    upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }----- | Set parser options for parsing OPTIONS pragmas-initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState-initPragState options buf loc = (initParserState options buf loc)-   { lex_state = [bol, option_prags, 0]-   }---- | Creates a parse state from a 'ParserOpts' value-initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState-initParserState options buf loc =-  PState {-      buffer        = buf,-      options       = options,-      errors        = emptyMessages,-      warnings      = emptyMessages,-      tab_first     = Strict.Nothing,-      tab_count     = 0,-      last_tk       = Strict.Nothing,-      prev_loc      = mkPsSpan init_loc init_loc,-      prev_loc2     = mkPsSpan init_loc init_loc,-      last_loc      = mkPsSpan init_loc init_loc,-      last_len      = 0,-      loc           = init_loc,-      context       = [],-      lex_state     = [bol, 0],-      srcfiles      = [],-      alr_pending_implicit_tokens = [],-      alr_next_token = Nothing,-      alr_last_loc = PsSpan (alrInitialLoc (fsLit "<no file>")) (BufSpan (BufPos 0) (BufPos 0)),-      alr_context = [],-      alr_expecting_ocurly = Nothing,-      alr_justClosedExplicitLetBlock = False,-      eof_pos = Strict.Nothing,-      header_comments = Strict.Nothing,-      comment_q = [],-      hdk_comments = nilOL-    }-  where init_loc = PsLoc loc (BufPos 0)---- | An mtl-style class for monads that support parsing-related operations.--- For example, sometimes we make a second pass over the parsing results to validate,--- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume--- input but can report parsing errors, check for extension bits, and accumulate--- parsing annotations. Both P and PV are instances of MonadP.------ MonadP grants us convenient overloading. The other option is to have separate operations--- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.----class Monad m => MonadP m where-  -- | Add a non-fatal error. Use this when the parser can produce a result-  --   despite the error.-  ---  --   For example, when GHC encounters a @forall@ in a type,-  --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@-  --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to-  --   the accumulator.-  ---  --   Control flow wise, non-fatal errors act like warnings: they are added-  --   to the accumulator and parsing continues. This allows GHC to report-  --   more than one parse error per file.-  ---  addError :: MsgEnvelope PsMessage -> m ()--  -- | Add a warning to the accumulator.-  --   Use 'getPsMessages' to get the accumulated warnings.-  addWarning :: MsgEnvelope PsMessage -> m ()--  -- | Add a fatal error. This will be the last error reported by the parser, and-  --   the parser will not produce any result, ending in a 'PFailed' state.-  addFatalError :: MsgEnvelope PsMessage -> m a--  -- | Check if a given flag is currently set in the bitmap.-  getBit :: ExtBits -> m Bool-  -- | Go through the @comment_q@ in @PState@ and remove all comments-  -- that belong within the given span-  allocateCommentsP :: RealSrcSpan -> m EpAnnComments-  -- | Go through the @comment_q@ in @PState@ and remove all comments-  -- that come before or within the given span-  allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments-  -- | Go through the @comment_q@ in @PState@ and remove all comments-  -- that come after the given span-  allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments--instance MonadP P where-  addError err-   = P $ \s -> POk s { errors = err `addMessage` errors s} ()--  -- If the warning is meant to be suppressed, GHC will assign-  -- a `SevIgnore` severity and the message will be discarded,-  -- so we can simply add it no matter what.-  addWarning w-   = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) ()--  addFatalError err =-    addError err >> P PFailed--  getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)-                         in b `seq` POk s b-  allocateCommentsP ss = P $ \s ->-    let (comment_q', newAnns) = allocateComments ss (comment_q s) in-      POk s {-         comment_q = comment_q'-       } (EpaComments newAnns)-  allocatePriorCommentsP ss = P $ \s ->-    let (header_comments', comment_q', newAnns)-             = allocatePriorComments ss (comment_q s) (header_comments s) in-      POk s {-         header_comments = header_comments',-         comment_q = comment_q'-       } (EpaComments newAnns)-  allocateFinalCommentsP ss = P $ \s ->-    let (header_comments', comment_q', newAnns)-             = allocateFinalComments ss (comment_q s) (header_comments s) in-      POk s {-         header_comments = header_comments',-         comment_q = comment_q'-       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)--getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-getCommentsFor (RealSrcSpan l _) = allocateCommentsP l-getCommentsFor _ = return emptyComments--getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l-getPriorCommentsFor _ = return emptyComments--getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l-getFinalCommentsFor _ = return emptyComments--getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))-getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos--addPsMessage :: SrcSpan -> PsMessage -> P ()-addPsMessage srcspan msg = do-  diag_opts <- (pDiagOpts . options) <$> getPState-  addWarning (mkPlainMsgEnvelope diag_opts srcspan msg)--addTabWarning :: RealSrcSpan -> P ()-addTabWarning srcspan- = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->-       let tf' = tf <|> Strict.Just srcspan-           tc' = tc + 1-           s' = if warnopt Opt_WarnTabs o-                then s{tab_first = tf', tab_count = tc'}-                else s-       in POk s' ()---- | Get a bag of the errors that have been accumulated so far.---   Does not take -Werror into account.-getPsErrorMessages :: PState -> Messages PsMessage-getPsErrorMessages p = errors p---- | Get the warnings and errors accumulated so far.---   Does not take -Werror into account.-getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage)-getPsMessages p =-  let ws = warnings p-      diag_opts = pDiagOpts (options p)-      -- we add the tabulation warning on the fly because-      -- we count the number of occurrences of tab characters-      ws' = case tab_first p of-        Strict.Nothing -> ws-        Strict.Just tf ->-          let msg = mkPlainMsgEnvelope diag_opts-                          (RealSrcSpan tf Strict.Nothing)-                          (PsWarnTab (tab_count p))-          in msg `addMessage` ws-  in (ws', errors p)--getContext :: P [LayoutContext]-getContext = P $ \s@PState{context=ctx} -> POk s ctx--setContext :: [LayoutContext] -> P ()-setContext ctx = P $ \s -> POk s{context=ctx} ()--popContext :: P ()-popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,-                              last_len = len, last_loc = last_loc }) ->-  case ctx of-        (_:tl) ->-          POk s{ context = tl } ()-        []     ->-          unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s---- Push a new layout context at the indentation of the last token read.-pushCurrentContext :: GenSemic -> P ()-pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->-    POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} ()---- This is only used at the outer level of a module when the 'module' keyword is--- missing.-pushModuleContext :: P ()-pushModuleContext = pushCurrentContext generateSemic--getOffside :: P (Ordering, Bool)-getOffside = P $ \s@PState{last_loc=loc, context=stk} ->-                let offs = srcSpanStartCol (psRealSpan loc) in-                let ord = case stk of-                            Layout n gen_semic : _ ->-                              --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $-                              (compare offs n, gen_semic)-                            _ ->-                              (GT, dontGenerateSemic)-                in POk s ord---- ------------------------------------------------------------------------------ Construct a parse error--srcParseErr-  :: ParserOpts-  -> StringBuffer       -- current buffer (placed just after the last token)-  -> Int                -- length of the previous token-  -> SrcSpan-  -> MsgEnvelope PsMessage-srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details)-  where-   token = lexemeToString (offsetBytes (-len) buf) len-   pattern_ = decodePrevNChars 8 buf-   last100 = decodePrevNChars 100 buf-   doInLast100 = "do" `isInfixOf` last100-   mdoInLast100 = "mdo" `isInfixOf` last100-   th_enabled = ThQuotesBit `xtest` pExtsBitmap options-   ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options-   details = PsErrParseDetails {-       ped_th_enabled      = th_enabled-     , ped_do_in_last_100  = doInLast100-     , ped_mdo_in_last_100 = mdoInLast100-     , ped_pat_syn_enabled = ps_enabled-     , ped_pattern_parsed  = pattern_ == "pattern "-     }---- Report a parse failure, giving the span of the previous token as--- the location of the error.  This is the entry point for errors--- detected during parsing.-srcParseFail :: P a-srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,-                            last_loc = last_loc } ->-    unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s---- A lexical error is reported at a particular position in the source file,--- not over a token range.-lexError :: LexErr -> P a-lexError e = do-  loc <- getRealSrcLoc-  (AI end buf) <- getInput-  reportLexError loc (psRealLoc end) buf-    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k)---- -------------------------------------------------------------------------------- This is the top-level function: called from the parser each time a--- new token is to be read from the input.--lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a--lexer queueComments cont = do-  alr <- getBit AlternativeLayoutRuleBit-  let lexTokenFun = if alr then lexTokenAlr else lexToken-  (L span tok) <- lexTokenFun-  --trace ("token: " ++ show tok) $ do--  if (queueComments && isComment tok)-    then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont-    else cont (L (mkSrcSpanPs span) tok)---- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging.-lexerDbg queueComments cont = lexer queueComments contDbg-  where-    contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok)--lexTokenAlr :: P (PsLocated Token)-lexTokenAlr = do mPending <- popPendingImplicitToken-                 t <- case mPending of-                      Nothing ->-                          do mNext <- popNextToken-                             t <- case mNext of-                                  Nothing -> lexToken-                                  Just next -> return next-                             alternativeLayoutRuleToken t-                      Just t ->-                          return t-                 setAlrLastLoc (getLoc t)-                 case unLoc t of-                     ITwhere  -> setAlrExpectingOCurly (Just ALRLayoutWhere)-                     ITlet    -> setAlrExpectingOCurly (Just ALRLayoutLet)-                     ITof     -> setAlrExpectingOCurly (Just ALRLayoutOf)-                     ITlcase  -> setAlrExpectingOCurly (Just ALRLayoutOf)-                     ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf)-                     ITdo  _  -> setAlrExpectingOCurly (Just ALRLayoutDo)-                     ITmdo _  -> setAlrExpectingOCurly (Just ALRLayoutDo)-                     ITrec    -> setAlrExpectingOCurly (Just ALRLayoutDo)-                     _        -> return ()-                 return t--alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)-alternativeLayoutRuleToken t-    = do context <- getALRContext-         lastLoc <- getAlrLastLoc-         mExpectingOCurly <- getAlrExpectingOCurly-         transitional <- getBit ALRTransitionalBit-         justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock-         setJustClosedExplicitLetBlock False-         let thisLoc = getLoc t-             thisCol = srcSpanStartCol (psRealSpan thisLoc)-             newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc)-         case (unLoc t, context, mExpectingOCurly) of-             -- This case handles a GHC extension to the original H98-             -- layout rule...-             (ITocurly, _, Just alrLayout) ->-                 do setAlrExpectingOCurly Nothing-                    let isLet = case alrLayout of-                                ALRLayoutLet -> True-                                _ -> False-                    setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)-                    return t-             -- ...and makes this case unnecessary-             {--             -- I think our implicit open-curly handling is slightly-             -- different to John's, in how it interacts with newlines-             -- and "in"-             (ITocurly, _, Just _) ->-                 do setAlrExpectingOCurly Nothing-                    setNextToken t-                    lexTokenAlr-             -}-             (_, ALRLayout _ col : _ls, Just expectingOCurly)-              | (thisCol > col) ||-                (thisCol == col &&-                 isNonDecreasingIndentation expectingOCurly) ->-                 do setAlrExpectingOCurly Nothing-                    setALRContext (ALRLayout expectingOCurly thisCol : context)-                    setNextToken t-                    return (L thisLoc ITvocurly)-              | otherwise ->-                 do setAlrExpectingOCurly Nothing-                    setPendingImplicitTokens [L lastLoc ITvccurly]-                    setNextToken t-                    return (L lastLoc ITvocurly)-             (_, _, Just expectingOCurly) ->-                 do setAlrExpectingOCurly Nothing-                    setALRContext (ALRLayout expectingOCurly thisCol : context)-                    setNextToken t-                    return (L thisLoc ITvocurly)-             -- We do the [] cases earlier than in the spec, as we-             -- have an actual EOF token-             (ITeof, ALRLayout _ _ : ls, _) ->-                 do setALRContext ls-                    setNextToken t-                    return (L thisLoc ITvccurly)-             (ITeof, _, _) ->-                 return t-             -- the other ITeof case omitted; general case below covers it-             (ITin, _, _)-              | justClosedExplicitLetBlock ->-                 return t-             (ITin, ALRLayout ALRLayoutLet _ : ls, _)-              | newLine ->-                 do setPendingImplicitTokens [t]-                    setALRContext ls-                    return (L thisLoc ITvccurly)-             -- This next case is to handle a transitional issue:-             (ITwhere, ALRLayout _ col : ls, _)-              | newLine && thisCol == col && transitional ->-                 do addPsMessage-                      (mkSrcSpanPs thisLoc)-                      (PsWarnTransitionalLayout TransLayout_Where)-                    setALRContext ls-                    setNextToken t-                    -- Note that we use lastLoc, as we may need to close-                    -- more layouts, or give a semicolon-                    return (L lastLoc ITvccurly)-             -- This next case is to handle a transitional issue:-             (ITvbar, ALRLayout _ col : ls, _)-              | newLine && thisCol == col && transitional ->-                 do addPsMessage-                      (mkSrcSpanPs thisLoc)-                      (PsWarnTransitionalLayout TransLayout_Pipe)-                    setALRContext ls-                    setNextToken t-                    -- Note that we use lastLoc, as we may need to close-                    -- more layouts, or give a semicolon-                    return (L lastLoc ITvccurly)-             (_, ALRLayout _ col : ls, _)-              | newLine && thisCol == col ->-                 do setNextToken t-                    let loc = psSpanStart thisLoc-                        zeroWidthLoc = mkPsSpan loc loc-                    return (L zeroWidthLoc ITsemi)-              | newLine && thisCol < col ->-                 do setALRContext ls-                    setNextToken t-                    -- Note that we use lastLoc, as we may need to close-                    -- more layouts, or give a semicolon-                    return (L lastLoc ITvccurly)-             -- We need to handle close before open, as 'then' is both-             -- an open and a close-             (u, _, _)-              | isALRclose u ->-                 case context of-                 ALRLayout _ _ : ls ->-                     do setALRContext ls-                        setNextToken t-                        return (L thisLoc ITvccurly)-                 ALRNoLayout _ isLet : ls ->-                     do let ls' = if isALRopen u-                                     then ALRNoLayout (containsCommas u) False : ls-                                     else ls-                        setALRContext ls'-                        when isLet $ setJustClosedExplicitLetBlock True-                        return t-                 [] ->-                     do let ls = if isALRopen u-                                    then [ALRNoLayout (containsCommas u) False]-                                    else []-                        setALRContext ls-                        -- XXX This is an error in John's code, but-                        -- it looks reachable to me at first glance-                        return t-             (u, _, _)-              | isALRopen u ->-                 do setALRContext (ALRNoLayout (containsCommas u) False : context)-                    return t-             (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->-                 do setALRContext ls-                    setPendingImplicitTokens [t]-                    return (L thisLoc ITvccurly)-             (ITin, ALRLayout _ _ : ls, _) ->-                 do setALRContext ls-                    setNextToken t-                    return (L thisLoc ITvccurly)-             -- the other ITin case omitted; general case below covers it-             (ITcomma, ALRLayout _ _ : ls, _)-              | topNoLayoutContainsCommas ls ->-                 do setALRContext ls-                    setNextToken t-                    return (L thisLoc ITvccurly)-             (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->-                 do setALRContext ls-                    setPendingImplicitTokens [t]-                    return (L thisLoc ITvccurly)-             -- the other ITwhere case omitted; general case below covers it-             (_, _, _) -> return t--isALRopen :: Token -> Bool-isALRopen ITcase          = True-isALRopen ITif            = True-isALRopen ITthen          = True-isALRopen IToparen        = True-isALRopen ITobrack        = True-isALRopen ITocurly        = True--- GHC Extensions:-isALRopen IToubxparen     = True-isALRopen _               = False--isALRclose :: Token -> Bool-isALRclose ITof     = True-isALRclose ITthen   = True-isALRclose ITelse   = True-isALRclose ITcparen = True-isALRclose ITcbrack = True-isALRclose ITccurly = True--- GHC Extensions:-isALRclose ITcubxparen = True-isALRclose _        = False--isNonDecreasingIndentation :: ALRLayout -> Bool-isNonDecreasingIndentation ALRLayoutDo = True-isNonDecreasingIndentation _           = False--containsCommas :: Token -> Bool-containsCommas IToparen = True-containsCommas ITobrack = True--- John doesn't have {} as containing commas, but records contain them,--- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs--- (defaultInstallDirs).-containsCommas ITocurly = True--- GHC Extensions:-containsCommas IToubxparen = True-containsCommas _        = False--topNoLayoutContainsCommas :: [ALRContext] -> Bool-topNoLayoutContainsCommas [] = False-topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls-topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b--lexToken :: P (PsLocated Token)-lexToken = do-  inp@(AI loc1 buf) <- getInput-  sc <- getLexState-  exts <- getExts-  case alexScanUser exts inp sc of-    AlexEOF -> do-        let span = mkPsSpan loc1 loc1-        lt <- getLastLocEof-        setEofPos (psRealSpan span) (psRealSpan lt)-        setLastToken span 0-        return (L span ITeof)-    AlexError (AI loc2 buf) ->-        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf-          (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k)-    AlexSkip inp2 _ -> do-        setInput inp2-        lexToken-    AlexToken inp2@(AI end buf2) _ t -> do-        setInput inp2-        let span = mkPsSpan loc1 end-        let bytes = byteDiff buf buf2-        span `seq` setLastToken span bytes-        lt <- t span buf bytes buf2-        let lt' = unLoc lt-        if (isComment lt') then setLastComment lt else setLastTk lt-        return lt--reportLexError :: RealSrcLoc-               -> RealSrcLoc-               -> StringBuffer-               -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)-               -> P a-reportLexError loc1 loc2 buf f-  | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)-  | otherwise =-  let c = fst (nextChar buf)-  in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#-     then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)-     else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))--lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]-lexTokenStream opts buf loc = unP go initState{ options = opts' }-    where-    new_exts  =   xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens-                $ xset RawTokenStreamBit -- include comments-                $ pExtsBitmap opts-    opts'     = opts { pExtsBitmap = new_exts }-    initState = initParserState opts' buf loc-    go = do-      ltok <- lexer False return-      case ltok of-        L _ ITeof -> return []-        _ -> liftM (ltok:) go--linePrags = Map.singleton "line" linePrag--fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),-                                 ("options_ghc", lex_string_prag IToptions_prag),-                                 ("options_haddock", lex_string_prag_comment ITdocOptions),-                                 ("language", token ITlanguage_prag),-                                 ("include", lex_string_prag ITinclude_prag)])--ignoredPrags = Map.fromList (map ignored pragmas)-               where ignored opt = (opt, nested_comment)-                     impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]-                     options_pragmas = map ("options_" ++) impls-                     -- CFILES is a hugs-only thing.-                     pragmas = options_pragmas ++ ["cfiles", "contract"]--oneWordPrags = Map.fromList [-     ("rules", rulePrag),-     ("inline",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),-     ("inlinable",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),-     ("inlineable",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),-                                    -- Spelling variant-     ("notinline",-         strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),-     ("opaque", strtoken (\s -> ITopaque_prag (SourceText s))),-     ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),-     ("source", strtoken (\s -> ITsource_prag (SourceText s))),-     ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),-     ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),-     ("scc", strtoken (\s -> ITscc_prag (SourceText s))),-     ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),-     ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),-     ("ann", strtoken (\s -> ITann_prag (SourceText s))),-     ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),-     ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),-     ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),-     ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),-     ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),-     ("ctype", strtoken (\s -> ITctype (SourceText s))),-     ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),-     ("column", columnPrag)-     ]--twoWordPrags = Map.fromList [-     ("inline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),-     ("notinline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),-     ("specialize inline",-         strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),-     ("specialize notinline",-         strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))-     ]--dispatch_pragmas :: Map String Action -> Action-dispatch_pragmas prags span buf len buf2 =-  case Map.lookup (clean_pragma (lexemeToString buf len)) prags of-    Just found -> found span buf len buf2-    Nothing -> lexError LexUnknownPragma--known_pragma :: Map String Action -> AlexAccPred ExtsBitmap-known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)- = isKnown && nextCharIsNot curbuf pragmaNameChar-    where l = lexemeToString startbuf (byteDiff startbuf curbuf)-          isKnown = isJust $ Map.lookup (clean_pragma l) prags-          pragmaNameChar c = isAlphaNum c || c == '_'--clean_pragma :: String -> String-clean_pragma prag = canon_ws (map toLower (unprefix prag))-                    where unprefix prag' = case stripPrefix "{-#" prag' of-                                             Just rest -> rest-                                             Nothing -> prag'-                          canonical prag' = case prag' of-                                              "noinline" -> "notinline"-                                              "specialise" -> "specialize"-                                              "constructorlike" -> "conlike"-                                              _ -> prag'-                          canon_ws s = unwords (map canonical (words s))--warn_unknown_prag :: Map String Action -> Action-warn_unknown_prag prags span buf len buf2 = do-  let uppercase    = map toUpper-      unknown_prag = uppercase (clean_pragma (lexemeToString buf len))-      suggestions  = map uppercase (Map.keys prags)-  addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $-    PsWarnUnrecognisedPragma unknown_prag suggestions-  nested_comment span buf len buf2--{--%************************************************************************-%*                                                                      *-        Helper functions for generating annotations in the parser-%*                                                                      *-%************************************************************************--}----- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate--- 'AddEpAnn' values for the opening and closing bordering on the start--- and end of the span-mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing))-  where-    f = srcSpanFile ss-    sl = srcSpanStartLine ss-    sc = srcSpanStartCol ss-    el = srcSpanEndLine ss-    ec = srcSpanEndCol ss-    lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))-    lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)--queueComment :: RealLocated Token -> P()-queueComment c = P $ \s -> POk s {-  comment_q = commentToAnnotation c : comment_q s-  } ()--allocateComments-  :: RealSrcSpan-  -> [LEpaComment]-  -> ([LEpaComment], [LEpaComment])-allocateComments ss comment_q =-  let-    (before,rest)  = break (\(L l _) -> isRealSubspanOf (anchor l) ss) comment_q-    (middle,after) = break (\(L l _) -> not (isRealSubspanOf (anchor l) ss)) rest-    comment_q' = before ++ after-    newAnns = middle-  in-    (comment_q', reverse newAnns)---- Comments appearing without a line-break before the first--- declaration are associated with the declaration-splitPriorComments-  :: RealSrcSpan-  -> [LEpaComment]-  -> ([LEpaComment], [LEpaComment])-splitPriorComments ss prior_comments =-  let-    -- True if there is only one line between the earlier and later span-    cmp later earlier-         = srcSpanStartLine later - srcSpanEndLine earlier == 1--    go decl _ [] = ([],decl)-    go decl r (c@(L l _):cs) = if cmp r (anchor l)-                              then go (c:decl) (anchor l) cs-                              else (reverse (c:cs), decl)-  in-    go [] ss prior_comments--allocatePriorComments-  :: RealSrcSpan-  -> [LEpaComment]-  -> Strict.Maybe [LEpaComment]-  -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])-allocatePriorComments ss comment_q mheader_comments =-  let-    cmp (L l _) = anchor l <= ss-    (newAnns,after) = partition cmp comment_q-    comment_q'= after-    (prior_comments, decl_comments)-        = case mheader_comments of-           Strict.Nothing -> (reverse newAnns, [])-           _ -> splitPriorComments ss newAnns+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds #-}+++{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Parser.Lexer (+   Token(..), lexer, lexerDbg,+   ParserOpts(..), mkParserOpts,+   PState (..), initParserState, initPragState,+   P(..), ParseResult(POk, PFailed),+   allocateComments, allocatePriorComments, allocateFinalComments,+   MonadP(..), getBit,+   getRealSrcLoc, getPState,+   failMsgP, failLocMsgP, srcParseFail,+   getPsErrorMessages, getPsMessages,+   popContext, pushModuleContext, setLastToken, setSrcLoc,+   activeContext, nextIsEOF,+   getLexState, popLexState, pushLexState,+   ExtBits(..),+   xtest, xunset, xset,+   disableHaddock,+   lexTokenStream,+   mkParensEpToks,+   mkParensLocs,+   getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,+   getEofPos,+   commentToAnnotation,+   HdkComment(..),+   warnopt,+   addPsMessage+  ) where++import GHC.Prelude+import qualified GHC.Data.Strict as Strict++-- base+import Control.Monad+import Control.Applicative+import Data.Char+import Data.List (stripPrefix, isInfixOf, partition)+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Word+import Debug.Trace (trace)++import GHC.Data.EnumSet as EnumSet++-- ghc-boot+import qualified GHC.LanguageExtensions as LangExt++-- bytestring+import Data.ByteString (ByteString)++-- containers+import Data.Map (Map)+import qualified Data.Map as Map++-- compiler+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.StringBuffer+import GHC.Data.FastString+import GHC.Types.Error+import GHC.Types.Unique.FM+import GHC.Data.Maybe+import GHC.Data.OrdList+import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair )++import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..))+import GHC.Hs.Doc++import GHC.Parser.CharClass++import GHC.Parser.Annotation+import GHC.Driver.Flags+import GHC.Parser.Errors.Basic+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Parser.Lexer.Interface+import qualified GHC.Parser.Lexer.String as Lexer.String+import GHC.Parser.String+}++-- -----------------------------------------------------------------------------+-- Alex "Character set macros"++-- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme"+-- Any changes here should likely be reflected there.+$unispace    = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$nl          = [\n\r\f]+$space       = [\ $unispace]+$whitechar   = [$nl \t \v $space]+$white_no_nl = $whitechar # \n -- TODO #8424+$tab         = \t++$ascdigit  = 0-9+$unidigit  = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$decdigit  = $ascdigit -- exactly $ascdigit, no more no less.+$digit     = [$ascdigit $unidigit]++$special   = [\(\)\,\;\[\]\`\{\}]+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]+$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']++$unilarge  = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$asclarge  = [A-Z]+$large     = [$asclarge $unilarge]++$unismall  = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$ascsmall  = [a-z]+$small     = [$ascsmall $unismall \_]++$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$idchar    = [$small $large $digit $uniidchar \']++$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$graphic   = [$small $large $symbol $digit $idchar $special $unigraphic \"\']+$charesc   = [a b f n r t v \\ \" \' \&]++$binit     = 0-1+$octit     = 0-7+$hexit     = [$decdigit A-F a-f]++$pragmachar = [$small $large $digit $uniidchar ]++$docsym    = [\| \^ \* \$]+++-- -----------------------------------------------------------------------------+-- Alex "Regular expression macros"++@varid     = $small $idchar*          -- variable identifiers+@conid     = $large $idchar*          -- constructor identifiers++@varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol+@consym    = \: $symbol*              -- constructor (operator) symbol++-- See Note [Lexing NumericUnderscores extension] and #14473+@numspc       = _*                   -- numeric spacer (#14473)+@decimal      = $decdigit(@numspc $decdigit)*+@binary       = $binit(@numspc $binit)*+@octal        = $octit(@numspc $octit)*+@hexadecimal  = $hexit(@numspc $hexit)*+@exponent     = @numspc [eE] [\-\+]? @decimal+@bin_exponent = @numspc [pP] [\-\+]? @decimal++@binarylit      = 0[bB] @numspc @binary+@octallit       = 0[oO] @numspc @octal+@hexadecimallit = 0[xX] @numspc @hexadecimal++@qual = (@conid \.)++@qvarid = @qual @varid+@qconid = @qual @conid+@qvarsym = @qual @varsym+@qconsym = @qual @consym++-- QualifiedDo needs to parse "M.do" not as a variable, so as to keep the+-- layout rules.+@qdo    = @qual "do"+@qmdo   = @qual "mdo"++@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent+@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent++@gap = \\ $whitechar+ \\+@cntrl = $asclarge | \@ | \[ | \\ | \] | \^ | \_+@ascii = \^ @cntrl | "NUL" | "SOH" | "STX" | "ETX" | "EOT" | "ENQ" | "ACK"+       | "BEL" | "BS" | "HT" | "LF" | "VT" | "FF" | "CR" | "SO" | "SI" | "DLE"+       | "DC1" | "DC2" | "DC3" | "DC4" | "NAK" | "SYN" | "ETB" | "CAN"+       | "EM" | "SUB" | "ESC" | "FS" | "GS" | "RS" | "US" | "SP" | "DEL"+-- N.B. ideally, we would do `@escape # \\ \&` instead of duplicating in @escapechar,+-- which is what the Haskell Report says, but this isn't valid Alex syntax, as only+-- character sets can be subtracted, not strings+@escape     = \\ ( $charesc      | @ascii | @decimal | o @octal | x @hexadecimal )+@escapechar = \\ ( $charesc # \& | @ascii | @decimal | o @octal | x @hexadecimal )+@stringchar = ($graphic # [\\ \"]) | $space | @escape     | @gap+@char       = ($graphic # [\\ \']) | $space | @escapechar++-- normal signed numerical literals can only be explicitly negative,+-- not explicitly positive (contrast @exponent)+@negative = \-+++-- -----------------------------------------------------------------------------+-- Alex "Identifier"++haskell :-+++-- -----------------------------------------------------------------------------+-- Alex "Rules"++-- everywhere: skip whitespace+($white_no_nl # \t)+ ;+$tab          { warnTab }++-- Everywhere: deal with nested comments.  We explicitly rule out+-- pragmas, "{-#", so that we don't accidentally treat them as comments.+-- (this can happen even though pragmas will normally take precedence due to+-- longest-match, because pragmas aren't valid in every state, but comments+-- are). We also rule out nested Haddock comments, if the -haddock flag is+-- set.++"{-" / { isNormalComment } { nested_comment }++-- Single-line comments are a bit tricky.  Haskell 98 says that two or+-- more dashes followed by a symbol should be parsed as a varsym, so we+-- have to exclude those.++-- Since Haddock comments aren't valid in every state, we need to rule them+-- out here.++-- The following two rules match comments that begin with two dashes, but+-- continue with a different character. The rules test that this character+-- is not a symbol (in which case we'd have a varsym), and that it's not a+-- space followed by a Haddock comment symbol (docsym) (in which case we'd+-- have a Haddock comment). The rules then munch the rest of the line.++"-- " ~$docsym .* { lineCommentToken }+"--" [^$symbol \ ] .* { lineCommentToken }++-- Next, match Haddock comments if no -haddock flag++"-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { lineCommentToken }++-- Now, when we've matched comments that begin with 2 dashes and continue+-- with a different character, we need to match comments that begin with three+-- or more dashes (which clearly can't be Haddock comments). We only need to+-- make sure that the first non-dash character isn't a symbol, and munch the+-- rest of the line.++"---"\-* ~$symbol .* { lineCommentToken }++-- Since the previous rules all match dashes followed by at least one+-- character, we also need to match a whole line filled with just dashes.++"--"\-* / { atEOL } { lineCommentToken }++-- We need this rule since none of the other single line comment rules+-- actually match this case.++"-- " / { atEOL } { lineCommentToken }++-- Everywhere: check for smart quotes--they are not allowed outside of strings+$unigraphic / { isSmartQuote } { smart_quote_error }++-- 'bol' state: beginning of a line.  Slurp up all the whitespace (including+-- blank lines) until we find a non-whitespace character, then do layout+-- processing.+--+-- One slight wibble here: what if the line begins with {-#? In+-- theory, we have to lex the pragma to see if it's one we recognise,+-- and if it is, then we backtrack and do_bol, otherwise we treat it+-- as a nested comment.  We don't bother with this: if the line begins+-- with {-#, then we'll assume it's a pragma we know about and go for do_bol.+<bol> {+  \n                                    ;+  ^\# line                              { begin line_prag1 }+  ^\# / { followedByDigit }             { begin line_prag1 }+  ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently+  ^\# \! .* \n                          ; -- #!, for scripts  -- gcc+  ^\  \# \! .* \n                       ; --  #!, for scripts -- clang; See #6132+  ()                                    { do_bol }+}++-- after a layout keyword (let, where, do, of), we begin a new layout+-- context if the curly brace is missing.+-- Careful! This stuff is quite delicate.+<layout, layout_do, layout_if> {+  \{ / { notFollowedBy '-' }            { hopefully_open_brace }+        -- we might encounter {-# here, but {- has been handled already+  \n                                    ;+  ^\# (line)?                           { begin line_prag1 }+}++-- after an 'if', a vertical bar starts a layout context for MultiWayIf+<layout_if> {+  \| / { notFollowedBySymbol }          { new_layout_context True dontGenerateSemic ITvbar }+  ()                                    { pop }+}++-- do is treated in a subtly different way, see new_layout_context+<layout>    ()                          { new_layout_context True  generateSemic ITvocurly }+<layout_do> ()                          { new_layout_context False generateSemic ITvocurly }++-- after a new layout context which was found to be to the left of the+-- previous context, we have generated a '{' token, and we now need to+-- generate a matching '}' token.+<layout_left>  ()                       { do_layout_left }++<0,option_prags> \n                     { begin bol }++"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }+                                { dispatch_pragmas linePrags }++-- single-line line pragmas, of the form+--    # <line> "<file>" <extra-stuff> \n+<line_prag1> {+  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag1a }+  ()                                           { failLinePrag1 }+}+<line_prag1a> .*                               { popLinePrag1 }++-- Haskell-style line pragmas, of the form+--    {-# LINE <line> "<file>" #-}+<line_prag2> {+  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag2a }+}+<line_prag2a> "#-}"|"-}"                       { pop }+   -- NOTE: accept -} at the end of a LINE pragma, for compatibility+   -- with older versions of GHC which generated these.++-- Haskell-style column pragmas, of the form+--    {-# COLUMN <column> #-}+<column_prag> @decimal $whitechar* "#-}" { setColumn }++<0,option_prags> {+  "{-#" $whitechar* $pragmachar++        $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }+                                 { dispatch_pragmas twoWordPrags }++  "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }+                                 { dispatch_pragmas oneWordPrags }++  -- We ignore all these pragmas, but don't generate a warning for them+  "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }+                                 { dispatch_pragmas ignoredPrags }++  -- ToDo: should only be valid inside a pragma:+  "#-}"                          { endPrag }+}++<option_prags> {+  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }+                                   { dispatch_pragmas fileHeaderPrags }+}++<0> {+  -- In the "0" mode we ignore these pragmas+  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }+                     { nested_comment }+}++<0,option_prags> {++-- This code would eagerly accept and hence discard, e.g., "LANGUAGE MagicHash".+--  "{-#" $whitechar* $pragmachar++--        $whitechar+ $pragmachar++--        { warn_unknown_prag twoWordPrags }++  "{-#" $whitechar* $pragmachar++        { warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) }++  "{-#" { warn_unknown_prag Map.empty }+}++-- '0' state: ordinary lexemes++-- Haddock comments++"-- " $docsym      / { ifExtension HaddockBit } { multiline_doc_comment }+"{-" \ ? $docsym   / { ifExtension HaddockBit } { nested_doc_comment }++-- "special" symbols++<0> {++  -- Don't check ThQuotesBit here as the renamer can produce a better+  -- error message than the lexer (see the thQuotesEnabled check in rnBracket).+  "[|"  { token (ITopenExpQuote NoE NormalSyntax) }+  "[||" { token (ITopenTExpQuote NoE) }+  "|]"  { token (ITcloseQuote NormalSyntax) }+  "||]" { token ITcloseTExpQuote }++  -- Check ThQuotesBit here as to not steal syntax.+  "[e|"       / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }+  "[e||"      / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) }+  "[p|"       / { ifExtension ThQuotesBit } { token ITopenPatQuote }+  "[d|"       / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote }+  "[t|"       / { ifExtension ThQuotesBit } { token ITopenTypQuote }++  "[" @varid "|"  / { ifExtension QqBit }   { lex_quasiquote_tok }++  -- qualified quasi-quote (#5555)+  "[" @qvarid "|"  / { ifExtension QqBit }  { lex_qquasiquote_tok }++  $unigraphic -- ⟦+    / { ifCurrentChar '⟦' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ThQuotesBit }+    { token (ITopenExpQuote NoE UnicodeSyntax) }+  $unigraphic -- ⟧+    / { ifCurrentChar '⟧' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ThQuotesBit }+    { token (ITcloseQuote UnicodeSyntax) }+}++<0> {+  "(|"+    / { ifExtension ArrowsBit `alexAndPred`+        notFollowedBySymbol }+    { special (IToparenbar NormalSyntax) }+  "|)"+    / { ifExtension ArrowsBit }+    { special (ITcparenbar NormalSyntax) }++  $unigraphic -- ⦇+    / { ifCurrentChar '⦇' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ArrowsBit }+    { special (IToparenbar UnicodeSyntax) }+  $unigraphic -- ⦈+    / { ifCurrentChar '⦈' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ArrowsBit }+    { special (ITcparenbar UnicodeSyntax) }+}++<0> {+  \? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid }+}++<0> {+  "#" $idchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid_src ITlabelvarid }+  "#" \" @stringchar* \" / { ifExtension OverloadedLabelsBit } { tok_quoted_label }+}++<0> {+  "(#" / { ifExtension UnboxedParensBit }+         { token IToubxparen }+  "#)" / { ifExtension UnboxedParensBit }+         { token ITcubxparen }+}++<0,option_prags> {+  \(                                    { special IToparen }+  \)                                    { special ITcparen }+  \[                                    { special ITobrack }+  \]                                    { special ITcbrack }+  \,                                    { special ITcomma }+  \;                                    { special ITsemi }+  \`                                    { special ITbackquote }++  \{                                    { open_brace }+  \}                                    { close_brace }+}++<0,option_prags> {+  @qdo                                      { qdo_token ITdo }+  @qmdo    / { ifExtension RecursiveDoBit } { qdo_token ITmdo }+  @qvarid                       { idtoken qvarid }+  @qconid                       { idtoken qconid }+  @varid                        { varid }+  @conid                        { idtoken conid }+}++<0> {+  @qvarid "#"+      / { ifExtension MagicHashBit } { idtoken qvarid }+  @qconid "#"+      / { ifExtension MagicHashBit } { idtoken qconid }+  @varid "#"+       / { ifExtension MagicHashBit } { varid }+  @conid "#"+       / { ifExtension MagicHashBit } { idtoken conid }+}++-- ToDo: - move `var` and (sym) into lexical syntax?+--       - remove backquote from $special?+<0> {+  @qvarsym                                         { idtoken qvarsym }+  @qconsym                                         { idtoken qconsym }+  @varsym                                          { with_op_ws varsym }+  @consym                                          { with_op_ws consym }+}++-- For the normal boxed literals we need to be careful+-- when trying to be close to Haskell98++-- Note [Lexing NumericUnderscores extension] (#14473)+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- NumericUnderscores extension allows underscores in numeric literals.+-- Multiple underscores are represented with @numspc macro.+-- To be simpler, we have only the definitions with underscores.+-- And then we have a separate function (tok_integral and tok_frac)+-- that validates the literals.+-- If extensions are not enabled, check that there are no underscores.+--+<0> {+  -- Normal integral literals (:: Num a => a, from Integer)+  @decimal                                                      { tok_num positive 0 0 decimal }+  @binarylit                / { ifExtension BinaryLiteralsBit } { tok_num positive 2 2 binary }+  @octallit                                                     { tok_num positive 2 2 octal }+  @hexadecimallit                                               { tok_num positive 2 2 hexadecimal }+  @negative @decimal        / { negLitPred }                    { tok_num negative 1 1 decimal }+  @negative @binarylit      / { negLitPred `alexAndPred`+                                ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary }+  @negative @octallit       / { negLitPred }                    { tok_num negative 3 3 octal }+  @negative @hexadecimallit / { negLitPred }                    { tok_num negative 3 3 hexadecimal }++  -- Normal rational literals (:: Fractional a => a, from Rational)+  @floating_point                                                            { tok_frac 0 tok_float }+  @negative @floating_point            / { negLitPred }                      { tok_frac 0 tok_float }+  0[xX] @numspc @hex_floating_point    / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }+  @negative 0[xX] @numspc @hex_floating_point+                                       / { ifExtension HexFloatLiteralsBit `alexAndPred`+                                           negLitPred }                      { tok_frac 0 tok_hex_float }+}++<0> {+  -- Unboxed ints (:: Int#) and words (:: Word#)+  -- It's simpler (and faster?) to give separate cases to the negatives,+  -- especially considering octal/hexadecimal prefixes.+  @decimal                     \# / { ifExtension MagicHashBit }        { tok_primint positive 0 1 decimal }+  @binarylit                   \# / { ifExtension MagicHashBit `alexAndPred`+                                      ifExtension BinaryLiteralsBit }   { tok_primint positive 2 3 binary }+  @octallit                    \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 octal }+  @hexadecimallit              \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 hexadecimal }+  @negative @decimal           \# / { negHashLitPred MagicHashBit }     { tok_primint negative 1 2 decimal }+  @negative @binarylit         \# / { negHashLitPred MagicHashBit `alexAndPred`+                                      ifExtension BinaryLiteralsBit }   { tok_primint negative 3 4 binary }+  @negative @octallit          \# / { negHashLitPred MagicHashBit }     { tok_primint negative 3 4 octal }+  @negative @hexadecimallit    \# / { negHashLitPred MagicHashBit }     { tok_primint negative 3 4 hexadecimal }++  @decimal                  \# \# / { ifExtension MagicHashBit }        { tok_primword 0 2 decimal }+  @binarylit                \# \# / { ifExtension MagicHashBit `alexAndPred`+                                      ifExtension BinaryLiteralsBit }   { tok_primword 2 4 binary }+  @octallit                 \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 octal }+  @hexadecimallit           \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 hexadecimal }++  @decimal                  \# $idchar+  / { ifExtension ExtendedLiteralsBit } { tok_prim_num_ext positive 0 decimal }+  @binarylit                \# $idchar+  / { ifExtension ExtendedLiteralsBit `alexAndPred`+                                             ifExtension BinaryLiteralsBit }   { tok_prim_num_ext positive 2 binary }+  @octallit                 \# $idchar+  / { ifExtension ExtendedLiteralsBit } { tok_prim_num_ext positive 2 octal }+  @hexadecimallit           \# $idchar+  / { ifExtension ExtendedLiteralsBit } { tok_prim_num_ext positive 2 hexadecimal }+  @negative @decimal        \# $idchar+  / { negHashLitPred ExtendedLiteralsBit } { tok_prim_num_ext negative 1 decimal }+  @negative @binarylit      \# $idchar+  / { negHashLitPred ExtendedLiteralsBit `alexAndPred`+                                             ifExtension BinaryLiteralsBit }   { tok_prim_num_ext negative 3 binary }+  @negative @octallit       \# $idchar+  / { negHashLitPred ExtendedLiteralsBit } { tok_prim_num_ext negative 3 octal }+  @negative @hexadecimallit \# $idchar+  / { negHashLitPred ExtendedLiteralsBit } { tok_prim_num_ext negative 3 hexadecimal }+++  -- Unboxed floats and doubles (:: Float#, :: Double#)+  -- prim_{float,double} work with signed literals+  @floating_point                  \# / { ifExtension MagicHashBit }        { tok_frac 1 tok_primfloat }+  @floating_point               \# \# / { ifExtension MagicHashBit }        { tok_frac 2 tok_primdouble }+  @negative @floating_point        \# / { negHashLitPred MagicHashBit }     { tok_frac 1 tok_primfloat }+  @negative @floating_point     \# \# / { negHashLitPred MagicHashBit }     { tok_frac 2 tok_primdouble }+  0[xX] @numspc @hex_floating_point \# / { ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit } { tok_frac 1 tok_prim_hex_float }+  0[xX] @numspc @hex_floating_point \# \# / { ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit } { tok_frac 2 tok_prim_hex_double }+  @negative 0[xX] @numspc @hex_floating_point \# / { ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit } { tok_frac 1 tok_prim_hex_float }+  @negative 0[xX] @numspc @hex_floating_point \# \# / { ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit } { tok_frac 2 tok_prim_hex_double }++}++<0> {+  \"\"\" / { ifExtension MultilineStringsBit }         { tok_string_multi }+  \" @stringchar* \"                                   { tok_string }+  \" @stringchar* \" \# / { ifExtension MagicHashBit } { tok_string }+  \' @char        \'                                   { tok_char }+  \' @char        \' \# / { ifExtension MagicHashBit } { tok_char }++  -- Check for smart quotes and throw better errors than a plain lexical error (#21843)+  \'              \\ $unigraphic / { isSmartQuote } { smart_quote_error }+  \" @stringchar* \\ $unigraphic / { isSmartQuote } { smart_quote_error }+  -- See Note [Bare smart quote error]+  -- The valid string rule will take precedence because it'll match more+  -- characters than this rule, so this rule will only fire if the string+  -- could not be lexed correctly+  \" @stringchar*    $unigraphic / { isSmartQuote } { smart_quote_error }+}++<0> {+  \'\' { token ITtyQuote }++  -- The normal character match takes precedence over this because it matches+  -- more characters. However, if that pattern didn't match, then this quote+  -- could be a quoted identifier, like 'x. Here, just return ITsimpleQuote,+  -- as the parser will lex the varid separately.+  \' / ($graphic # \\ | " ") { token ITsimpleQuote }+}++-- Note [Whitespace-sensitive operator parsing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In accord with GHC Proposal #229 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst+-- we classify operator occurrences into four categories:+--+--     a ! b   -- a loose infix occurrence+--     a!b     -- a tight infix occurrence+--     a !b    -- a prefix occurrence+--     a! b    -- a suffix occurrence+--+-- The rules are a bit more elaborate than simply checking for whitespace, in+-- order to accommodate the following use cases:+--+--     f (!a) = ...    -- prefix occurrence+--     g (a !)         -- loose infix occurrence+--     g (! a)         -- loose infix occurrence+--+-- The precise rules are as follows:+--+--  * Identifiers, literals, and opening brackets (, (#, (|, [, [|, [||, [p|,+--    [e|, [t|, {, ⟦, ⦇, are considered "opening tokens". The function+--    followedByOpeningToken tests whether the next token is an opening token.+--+--  * Identifiers, literals, and closing brackets ), #), |), ], |], }, ⟧, ⦈,+--    are considered "closing tokens". The function precededByClosingToken tests+--    whether the previous token is a closing token.+--+--  * Whitespace, comments, separators, and other tokens, are considered+--    neither opening nor closing.+--+--  * Any unqualified operator occurrence is classified as prefix, suffix, or+--    tight/loose infix, based on preceding and following tokens:+--+--       precededByClosingToken | followedByOpeningToken | Occurrence+--      ------------------------+------------------------+------------+--       False                  | True                   | prefix+--       True                   | False                  | suffix+--       True                   | True                   | tight infix+--       False                  | False                  | loose infix+--      ------------------------+------------------------+------------+--+-- A loose infix occurrence is always considered an operator. Other types of+-- occurrences may be assigned a special per-operator meaning override:+--+--   Operator |  Occurrence   | Token returned+--  ----------+---------------+------------------------------------------+--    !       |  prefix       | ITbang+--            |               |   strictness annotation or bang pattern,+--            |               |   e.g.  f !x = rhs, data T = MkT !a+--            |  not prefix   | ITvarsym "!"+--            |               |   ordinary operator or type operator,+--            |               |   e.g.  xs ! 3, (! x), Int ! Bool+--  ----------+---------------+------------------------------------------+--    ~       |  prefix       | ITtilde+--            |               |   laziness annotation or lazy pattern,+--            |               |   e.g.  f ~x = rhs, data T = MkT ~a+--            |  not prefix   | ITvarsym "~"+--            |               |   ordinary operator or type operator,+--            |               |   e.g.  xs ~ 3, (~ x), Int ~ Bool+--  ----------+---------------+------------------------------------------+--    .       |  prefix       | ITproj True+--            |               |   field projection,+--            |               |   e.g.  .x+--            |  tight infix  | ITproj False+--            |               |   field projection,+--            |               |   e.g. r.x+--            |  suffix       | ITdot+--            |               |   function composition,+--            |               |   e.g. f. g+--            |  loose infix  | ITdot+--            |               |   function composition,+--            |               |   e.g.  f . g+--  ----------+---------------+------------------------------------------+--    $  $$   |  prefix       | ITdollar, ITdollardollar+--            |               |   untyped or typed Template Haskell splice,+--            |               |   e.g.  $(f x), $$(f x), $$"str"+--            |  not prefix   | ITvarsym "$", ITvarsym "$$"+--            |               |   ordinary operator or type operator,+--            |               |   e.g.  f $ g x, a $$ b+--  ----------+---------------+------------------------------------------+--    @       |  prefix       | ITtypeApp+--            |               |   type application, e.g.  fmap @Maybe+--            |  tight infix  | ITat+--            |               |   as-pattern, e.g.  f p@(a,b) = rhs+--            |  suffix       | parse error+--            |               |   e.g. f p@ x = rhs+--            |  loose infix  | ITvarsym "@"+--            |               |   ordinary operator or type operator,+--            |               |   e.g.  f @ g, (f @)+--  ----------+---------------+------------------------------------------+--+-- Also, some of these overrides are guarded behind language extensions.+-- According to the specification, we must determine the occurrence based on+-- surrounding *tokens* (see the proposal for the exact rules). However, in+-- the implementation we cheat a little and do the classification based on+-- characters, for reasons of both simplicity and efficiency (see+-- 'followedByOpeningToken' and 'precededByClosingToken')+--+-- When an operator is subject to a meaning override, it is mapped to special+-- token: ITbang, ITtilde, ITat, ITdollar, ITdollardollar. Otherwise, it is+-- returned as ITvarsym.+--+-- For example, this is how we process the (!):+--+--    precededByClosingToken | followedByOpeningToken | Token+--   ------------------------+------------------------+-------------+--    False                  | True                   | ITbang+--    True                   | False                  | ITvarsym "!"+--    True                   | True                   | ITvarsym "!"+--    False                  | False                  | ITvarsym "!"+--   ------------------------+------------------------+-------------+--+-- And this is how we process the (@):+--+--    precededByClosingToken | followedByOpeningToken | Token+--   ------------------------+------------------------+-------------+--    False                  | True                   | ITtypeApp+--    True                   | False                  | parse error+--    True                   | True                   | ITat+--    False                  | False                  | ITvarsym "@"+--   ------------------------+------------------------+-------------++-- -----------------------------------------------------------------------------+-- Alex "Haskell code fragment bottom"++{++-- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing].+data OpWs+  = OpWsPrefix         -- a !b+  | OpWsSuffix         -- a! b+  | OpWsTightInfix     -- a!b+  | OpWsLooseInfix     -- a ! b+  deriving Show++-- -----------------------------------------------------------------------------+-- The token type++data Token+  = ITas                        -- Haskell keywords+  | ITcase+  | ITclass+  | ITdata+  | ITdefault+  | ITderiving+  | ITdo (Maybe FastString)+  | ITelse+  | IThiding+  | ITforeign+  | ITif+  | ITimport+  | ITin+  | ITinfix+  | ITinfixl+  | ITinfixr+  | ITinstance+  | ITlet+  | ITmodule+  | ITnewtype+  | ITof+  | ITqualified+  | ITthen+  | ITtype+  | ITwhere++  | ITforall            IsUnicodeSyntax -- GHC extension keywords+  | ITexport+  | ITlabel+  | ITdynamic+  | ITsafe+  | ITinterruptible+  | ITunsafe+  | ITstdcallconv+  | ITccallconv+  | ITcapiconv+  | ITprimcallconv+  | ITjavascriptcallconv+  | ITmdo (Maybe FastString)+  | ITfamily+  | ITrole+  | ITgroup+  | ITby+  | ITusing+  | ITpattern+  | ITstatic+  | ITstock+  | ITanyclass+  | ITvia++  -- Backpack tokens+  | ITunit+  | ITsignature+  | ITdependency+  | ITrequires++  -- Pragmas, see Note [Pragma source text] in "GHC.Types.SourceText"+  | ITinline_prag       SourceText InlineSpec RuleMatchInfo+  | ITopaque_prag       SourceText+  | ITspec_prag         SourceText                -- SPECIALISE+  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)+  | ITsource_prag       SourceText+  | ITrules_prag        SourceText+  | ITwarning_prag      SourceText+  | ITdeprecated_prag   SourceText+  | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'+  | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'+  | ITscc_prag          SourceText+  | ITunpack_prag       SourceText+  | ITnounpack_prag     SourceText+  | ITann_prag          SourceText+  | ITcomplete_prag     SourceText+  | ITclose_prag+  | IToptions_prag String+  | ITinclude_prag String+  | ITlanguage_prag+  | ITminimal_prag      SourceText+  | IToverlappable_prag SourceText  -- instance overlap mode+  | IToverlapping_prag  SourceText  -- instance overlap mode+  | IToverlaps_prag     SourceText  -- instance overlap mode+  | ITincoherent_prag   SourceText  -- instance overlap mode+  | ITctype             SourceText+  | ITcomment_line_prag         -- See Note [Nested comment line pragmas]++  | ITdotdot                    -- reserved symbols+  | ITcolon+  | ITdcolon            IsUnicodeSyntax+  | ITequal+  | ITlam+  | ITlcase+  | ITlcases+  | ITvbar+  | ITlarrow            IsUnicodeSyntax+  | ITrarrow            IsUnicodeSyntax+  | ITdarrow            IsUnicodeSyntax+  | ITlolly       -- The (⊸) arrow (for LinearTypes)+  | ITminus       -- See Note [Minus tokens]+  | ITprefixminus -- See Note [Minus tokens]+  | ITbang     -- Prefix (!) only, e.g. f !x = rhs+  | ITtilde    -- Prefix (~) only, e.g. f ~x = rhs+  | ITat       -- Tight infix (@) only, e.g. f x@pat = rhs+  | ITtypeApp  -- Prefix (@) only, e.g. f @t+  | ITpercent  -- Prefix (%) only, e.g. a %1 -> b+  | ITstar              IsUnicodeSyntax+  | ITdot+  | ITproj Bool -- Extension: OverloadedRecordDotBit++  | ITbiglam                    -- GHC-extension symbols++  | ITocurly                    -- special symbols+  | ITccurly+  | ITvocurly+  | ITvccurly+  | ITobrack+  | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays+  | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays+  | ITcbrack+  | IToparen+  | ITcparen+  | IToubxparen+  | ITcubxparen+  | ITsemi+  | ITcomma+  | ITunderscore+  | ITbackquote+  | ITsimpleQuote               --  '++  | ITvarid   FastString        -- identifiers+  | ITconid   FastString+  | ITvarsym  FastString+  | ITconsym  FastString+  | ITqvarid  (FastString,FastString)+  | ITqconid  (FastString,FastString)+  | ITqvarsym (FastString,FastString)+  | ITqconsym (FastString,FastString)++  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x+  | ITlabelvarid SourceText FastString   -- Overloaded label: #x+                                         -- The SourceText is required because we can+                                         -- have a string literal as a label+                                         -- Note [Literal source text] in "GHC.Types.SourceText"++  | ITchar     SourceText Char       -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITstring   SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITstringMulti SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITinteger  IntegralLit           -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITrational FractionalLit++  | ITprimchar   SourceText Char     -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimint    SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimword   SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimint8   SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimint16  SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimint32  SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimint64  SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimword8  SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimword16 SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimword32 SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimword64 SourceText Integer  -- Note [Literal source text] in "GHC.Types.SourceText"+  | ITprimfloat  FractionalLit+  | ITprimdouble FractionalLit++  -- Template Haskell extension tokens+  | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|+  | ITopenPatQuote                      --  [p|+  | ITopenDecQuote                      --  [d|+  | ITopenTypQuote                      --  [t|+  | ITcloseQuote IsUnicodeSyntax        --  |]+  | ITopenTExpQuote HasE                --  [|| or [e||+  | ITcloseTExpQuote                    --  ||]+  | ITdollar                            --  prefix $+  | ITdollardollar                      --  prefix $$+  | ITtyQuote                           --  ''+  | ITquasiQuote (FastString, PsSpan, FastString, PsSpan)+    -- ITquasiQuote(quoter, quoter_loc, quote, quote_loc)+    -- represents a quasi-quote of the form+    -- [quoter| quote |]+  | 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+  | IToparenbar  IsUnicodeSyntax -- ^ @(|@+  | ITcparenbar  IsUnicodeSyntax -- ^ @|)@+  | ITlarrowtail IsUnicodeSyntax -- ^ @-<@+  | ITrarrowtail IsUnicodeSyntax -- ^ @>-@+  | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@+  | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@++  | ITunknown String             -- ^ Used when the lexer can't make sense of it+  | ITeof                        -- ^ end of file token++  -- Documentation annotations. See Note [PsSpan in Comments]+  | ITdocComment   HsDocString PsSpan -- ^ The HsDocString contains more details about what+                                      -- this is and how to pretty print it+  | ITdocOptions   String      PsSpan -- ^ doc options (prune, ignore-exports, etc)+  | ITlineComment  String      PsSpan -- ^ comment starting by "--"+  | ITblockComment String      PsSpan -- ^ comment in {- -}++  deriving Show++instance Outputable Token where+  ppr x = text (show x)++{- Note [PsSpan in Comments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When using the Api Annotations to exact print a modified AST, managing+the space before a comment is important.  The PsSpan in the comment+token allows this to happen, and this location is tracked in prev_loc+in PState.  This only tracks physical tokens, so is not updated for+zero-width ones.++We also use this to track the space before the end-of-file marker.+-}++{- Note [Minus tokens]+~~~~~~~~~~~~~~~~~~~~~~+A minus sign can be used in prefix form (-x) and infix form (a - b).++When LexicalNegation is on:+  * ITprefixminus  represents the prefix form+  * ITvarsym "-"   represents the infix form+  * ITminus        is not used++When LexicalNegation is off:+  * ITminus        represents all forms+  * ITprefixminus  is not used+  * ITvarsym "-"   is not used+-}++{- Note [Why not LexicalNegationBit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One might wonder why we define NoLexicalNegationBit instead of+LexicalNegationBit. The problem lies in the following line in reservedSymsFM:++    ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit)++We want to generate ITminus only when LexicalNegation is off. How would one+do it if we had LexicalNegationBit? I (int-index) tried to use bitwise+complement:++    ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit))++This did not work, so I opted for NoLexicalNegationBit instead.+-}+++-- the bitmap provided as the third component indicates whether the+-- corresponding extension keyword is valid under the extension options+-- provided to the compiler; if the extension corresponding to *any* of the+-- bits set in the bitmap is enabled, the keyword is valid (this setup+-- facilitates using a keyword in two different extensions that can be+-- activated independently)+--+reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap)+reservedWordsFM = listToUFM $+    map (\(x, y, z) -> (mkFastString x, (y, z)))+        [( "_",              ITunderscore,    0 ),+         ( "as",             ITas,            0 ),+         ( "case",           ITcase,          0 ),+         ( "cases",          ITlcases,        xbit LambdaCaseBit ),+         ( "class",          ITclass,         0 ),+         ( "data",           ITdata,          0 ),+         ( "default",        ITdefault,       0 ),+         ( "deriving",       ITderiving,      0 ),+         ( "do",             ITdo Nothing,    0 ),+         ( "else",           ITelse,          0 ),+         ( "hiding",         IThiding,        0 ),+         ( "if",             ITif,            0 ),+         ( "import",         ITimport,        0 ),+         ( "in",             ITin,            0 ),+         ( "infix",          ITinfix,         0 ),+         ( "infixl",         ITinfixl,        0 ),+         ( "infixr",         ITinfixr,        0 ),+         ( "instance",       ITinstance,      0 ),+         ( "let",            ITlet,           0 ),+         ( "module",         ITmodule,        0 ),+         ( "newtype",        ITnewtype,       0 ),+         ( "of",             ITof,            0 ),+         ( "qualified",      ITqualified,     0 ),+         ( "then",           ITthen,          0 ),+         ( "type",           ITtype,          0 ),+         ( "where",          ITwhere,         0 ),++         ( "forall",         ITforall NormalSyntax, 0),+         ( "mdo",            ITmdo Nothing,   xbit RecursiveDoBit),+             -- See Note [Lexing type pseudo-keywords]+         ( "family",         ITfamily,        0 ),+         ( "role",           ITrole,          0 ),+         ( "pattern",        ITpattern,       xbit PatternSynonymsBit),+         ( "static",         ITstatic,        xbit StaticPointersBit ),+         ( "stock",          ITstock,         0 ),+         ( "anyclass",       ITanyclass,      0 ),+         ( "via",            ITvia,           0 ),+         ( "group",          ITgroup,         xbit TransformComprehensionsBit),+         ( "by",             ITby,            xbit TransformComprehensionsBit),+         ( "using",          ITusing,         xbit TransformComprehensionsBit),++         ( "foreign",        ITforeign,       xbit FfiBit),+         ( "export",         ITexport,        xbit FfiBit),+         ( "label",          ITlabel,         xbit FfiBit),+         ( "dynamic",        ITdynamic,       xbit FfiBit),+         ( "safe",           ITsafe,          xbit FfiBit .|.+                                              xbit SafeHaskellBit),+         ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),+         ( "unsafe",         ITunsafe,        xbit FfiBit),+         ( "stdcall",        ITstdcallconv,   xbit FfiBit),+         ( "ccall",          ITccallconv,     xbit FfiBit),+         ( "capi",           ITcapiconv,      xbit CApiFfiBit),+         ( "prim",           ITprimcallconv,  xbit FfiBit),+         ( "javascript",     ITjavascriptcallconv, xbit FfiBit),++         ( "unit",           ITunit,          0 ),+         ( "dependency",     ITdependency,       0 ),+         ( "signature",      ITsignature,     0 ),++         ( "rec",            ITrec,           xbit ArrowsBit .|.+                                              xbit RecursiveDoBit),+         ( "proc",           ITproc,          xbit ArrowsBit),+         ( "splice",         ITsplice,        xbit LevelImportsBit),+         ( "quote",          ITquote,         xbit LevelImportsBit)+     ]++{-----------------------------------+Note [Lexing type pseudo-keywords]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++One might think that we wish to treat 'family' and 'role' as regular old+varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.+But, there is no need to do so. These pseudo-keywords are not stolen syntax:+they are only used after the keyword 'type' at the top-level, where varids are+not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that+type families and role annotations are never declared without their extensions+on. In fact, by unconditionally lexing these pseudo-keywords as special, we+can get better error messages.++Also, note that these are included in the `varid` production in the parser --+a key detail to make all this work.+-------------------------------------}++reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap)+reservedSymsFM = listToUFM $+    map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))+      [ ("..",  ITdotdot,                   NormalSyntax,  0 )+        -- (:) is a reserved op, meaning only list cons+       ,(":",   ITcolon,                    NormalSyntax,  0 )+       ,("::",  ITdcolon NormalSyntax,      NormalSyntax,  0 )+       ,("=",   ITequal,                    NormalSyntax,  0 )+       ,("\\",  ITlam,                      NormalSyntax,  0 )+       ,("|",   ITvbar,                     NormalSyntax,  0 )+       ,("<-",  ITlarrow NormalSyntax,      NormalSyntax,  0 )+       ,("->",  ITrarrow NormalSyntax,      NormalSyntax,  0 )+       ,("=>",  ITdarrow NormalSyntax,      NormalSyntax,  0 )+       ,("-",   ITminus,                    NormalSyntax,  xbit NoLexicalNegationBit)++       ,("*",   ITstar NormalSyntax,        NormalSyntax,  xbit StarIsTypeBit)++       ,("-<",  ITlarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)+       ,(">-",  ITrarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)+       ,("-<<", ITLarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)+       ,(">>-", ITRarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)++       ,("∷",   ITdcolon UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("⇒",   ITdarrow UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("∀",   ITforall UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("→",   ITrarrow UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("←",   ITlarrow UnicodeSyntax,     UnicodeSyntax, 0 )++       ,("⊸",   ITlolly, UnicodeSyntax, 0)++       ,("⤙",   ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)+       ,("⤚",   ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)+       ,("⤛",   ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)+       ,("⤜",   ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)++       ,("★",   ITstar UnicodeSyntax,       UnicodeSyntax, xbit StarIsTypeBit)++        -- ToDo: ideally, → and ∷ should be "specials", so that they cannot+        -- form part of a large operator.  This would let us have a better+        -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).+       ]++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token)++special :: Token -> Action+special tok span _buf _len _buf2 = return (L span tok)++token, layout_token :: Token -> Action+token t span _buf _len _buf2 = return (L span t)+layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t)++idtoken :: (StringBuffer -> Int -> Token) -> Action+idtoken f span buf len _buf2 = return (L span $! (f buf len))++qdo_token :: (Maybe FastString -> Token) -> Action+qdo_token con span buf len _buf2 = do+    maybe_layout token+    return (L span $! token)+  where+    !token = con $! Just $! fst $! splitQualName buf len False++skip_one_varid :: (FastString -> Token) -> Action+skip_one_varid f span buf len _buf2+  = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))++skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action+skip_one_varid_src f span buf len _buf2+  = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1))+                        (lexemeToFastString (stepOn buf) (len-1)))++skip_two_varid :: (FastString -> Token) -> Action+skip_two_varid f span buf len _buf2+  = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))++strtoken :: (String -> Token) -> Action+strtoken f span buf len _buf2 =+  return (L span $! (f $! lexemeToString buf len))++fstrtoken :: (FastString -> Token) -> Action+fstrtoken f span buf len _buf2 =+  return (L span $! (f $! lexemeToFastString buf len))++begin :: Int -> Action+begin code _span _str _len _buf2 = do pushLexState code; lexToken++pop :: Action+pop _span _buf _len _buf2 =+  do _ <- popLexState+     lexToken+-- See Note [Nested comment line pragmas]+failLinePrag1 :: Action+failLinePrag1 span _buf _len _buf2 = do+  b <- getBit InNestedCommentBit+  if b then return (L span ITcomment_line_prag)+       else lexError LexErrorInPragma++-- See Note [Nested comment line pragmas]+popLinePrag1 :: Action+popLinePrag1 span _buf _len _buf2 = do+  b <- getBit InNestedCommentBit+  if b then return (L span ITcomment_line_prag) else do+    _ <- popLexState+    lexToken++hopefully_open_brace :: Action+hopefully_open_brace span buf len buf2+ = do relaxed <- getBit RelaxedLayoutBit+      ctx <- getContext+      (AI l _) <- getInput+      let offset = srcLocCol (psRealLoc l)+          isOK = relaxed ||+                 case ctx of+                 Layout prev_off _ : _ -> prev_off < offset+                 _                     -> True+      if isOK then pop_and open_brace span buf len buf2+              else addFatalError $+                     mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock++pop_and :: Action -> Action+pop_and act span buf len buf2 =+  do _ <- popLexState+     act span buf len buf2++-- See Note [Whitespace-sensitive operator parsing]+followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap+followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf+precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf++-- The input is the buffer *after* the token.+followedByOpeningToken' :: StringBuffer -> Bool+followedByOpeningToken' buf+  | atEnd buf = False+  | otherwise =+      case nextChar buf of+        ('{', buf') -> nextCharIsNot buf' (== '-')+        ('(', _) -> True+        ('[', _) -> True+        ('\"', _) -> True+        ('\'', _) -> True+        ('_', _) -> True+        ('⟦', _) -> True+        ('⦇', _) -> True+        (c, _) -> isAlphaNum c++-- The input is the buffer *before* the token.+precededByClosingToken' :: StringBuffer -> Bool+precededByClosingToken' buf =+  case prevChar buf '\n' of+    '}' -> decodePrevNChars 1 buf /= "-"+    ')' -> True+    ']' -> True+    '\"' -> True+    '\'' -> True+    '_' -> True+    '⟧' -> True+    '⦈' -> True+    c -> isAlphaNum c++get_op_ws :: StringBuffer -> StringBuffer -> OpWs+get_op_ws buf1 buf2 =+    mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2)+  where+    mk_op_ws False True  = OpWsPrefix+    mk_op_ws True  False = OpWsSuffix+    mk_op_ws True  True  = OpWsTightInfix+    mk_op_ws False False = OpWsLooseInfix++{-# INLINE with_op_ws #-}+with_op_ws :: (OpWs -> Action) -> Action+with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2++{-# INLINE nextCharIs #-}+nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool+nextCharIs buf p = not (atEnd buf) && p (currentChar buf)++{-# INLINE nextCharIsNot #-}+nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool+nextCharIsNot buf p = not (nextCharIs buf p)++notFollowedBy :: Char -> AlexAccPred ExtsBitmap+notFollowedBy char _ _ _ (AI _ buf)+  = nextCharIsNot buf (== char)++notFollowedBySymbol :: AlexAccPred ExtsBitmap+notFollowedBySymbol _ _ _ (AI _ buf)+  = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")++followedByDigit :: AlexAccPred ExtsBitmap+followedByDigit _ _ _ (AI _ buf)+  = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))++ifCurrentChar :: Char -> AlexAccPred ExtsBitmap+ifCurrentChar char _ (AI _ buf) _ _+  = nextCharIs buf (== char)++-- We must reject doc comments as being ordinary comments everywhere.+-- In some cases the doc comment will be selected as the lexeme due to+-- maximal munch, but not always, because the nested comment rule is+-- valid in all states, but the doc-comment rules are only valid in+-- the non-layout states.+isNormalComment :: AlexAccPred ExtsBitmap+isNormalComment bits _ _ (AI _ buf)+  | HaddockBit `xtest` bits = notFollowedByDocOrPragma+  | otherwise               = nextCharIsNot buf (== '#')+  where+    notFollowedByDocOrPragma+       = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))++afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool+afterOptionalSpace buf p+    = if nextCharIs buf (== ' ')+      then p (snd (nextChar buf))+      else p buf++atEOL :: AlexAccPred ExtsBitmap+atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'++-- Check if we should parse a negative literal (e.g. -123) as a single token.+negLitPred :: AlexAccPred ExtsBitmap+negLitPred =+    prefix_minus `alexAndPred`+    (negative_literals `alexOrPred` lexical_negation)+  where+    negative_literals = ifExtension NegativeLiteralsBit++    lexical_negation  =+      -- See Note [Why not LexicalNegationBit]+      alexNotPred (ifExtension NoLexicalNegationBit)++    prefix_minus =+      -- Note [prefix_minus in negLitPred and negHashLitPred]+      alexNotPred precededByClosingToken++-- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token.+negHashLitPred :: ExtBits -> AlexAccPred ExtsBitmap+negHashLitPred ext = prefix_minus `alexAndPred` magic_hash+  where+    magic_hash = ifExtension ext -- Either MagicHashBit or ExtendedLiteralsBit+    prefix_minus =+      -- Note [prefix_minus in negLitPred and negHashLitPred]+      alexNotPred precededByClosingToken++{- Note [prefix_minus in negLitPred and negHashLitPred]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to parse -1 as a single token, but x-1 as three tokens.+So in negLitPred (and negHashLitPred) we require that we have a prefix+occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing]+for a detailed definition of a prefix occurrence.++The condition for a prefix occurrence of an operator is:++  not precededByClosingToken && followedByOpeningToken++but we don't check followedByOpeningToken when parsing a negative literal.+It holds simply because we immediately lex a literal after the minus.+-}++ifExtension :: ExtBits -> AlexAccPred ExtsBitmap+ifExtension extBits bits _ _ _ = extBits `xtest` bits++alexNotPred p userState in1 len in2+  = not (p userState in1 len in2)++alexOrPred p1 p2 userState in1 len in2+  = p1 userState in1 len in2 || p2 userState in1 len in2++multiline_doc_comment :: Action+multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker+  where+    worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input+      where+        go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of+            Just ('\n', input')+              | checkNextLine -> case checkIfCommentLine input' of+                Just input@(AI next_start _) ->  go next_start "" (locatedLine : prevLines) input -- Start a new line+                Nothing -> endComment+              | otherwise -> endComment+            Just (c, input) -> go start_loc (c:curLine) prevLines input+            Nothing -> endComment+          where+            lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc+            locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine)+            commentLines = NE.reverse $ locatedLine :| prevLines+            endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span++    -- Check if the next line of input belongs to this doc comment as well.+    -- A doc comment continues onto the next line when the following+    -- conditions are met:+    --   * The line starts with "--"+    --   * The line doesn't start with "---".+    --   * The line doesn't start with "-- $", because that would be the+    --     start of a /new/ named haddock chunk (#10398).+    checkIfCommentLine :: AlexInput -> Maybe AlexInput+    checkIfCommentLine input = check (dropNonNewlineSpace input)+      where+        check input = do+          ('-', input) <- alexGetChar' input+          ('-', input) <- alexGetChar' input+          (c, after_c) <- alexGetChar' input+          case c of+            '-' -> Nothing+            ' ' -> case alexGetChar' after_c of+                     Just ('$', _) -> Nothing+                     _ -> Just input+            _   -> Just input++        dropNonNewlineSpace input = case alexGetChar' input of+          Just (c, input')+            | isSpace c && c /= '\n' -> dropNonNewlineSpace input'+            | otherwise -> input+          Nothing -> input++lineCommentToken :: Action+lineCommentToken span buf len buf2 = do+  b <- getBit RawTokenStreamBit+  if b then do+         lt <- getLastLocIncludingComments+         strtoken (\s -> ITlineComment s lt) span buf len buf2+       else lexToken+++{-+  nested comments require traversing by hand, they can't be parsed+  using regular expressions.+-}+nested_comment :: Action+nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do+  l <- getLastLocIncludingComments+  let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span+  input <- getInput+  -- Include decorator in comment+  let start_decorator = reverse $ lexemeToString buf len+  nested_comment_logic endComment start_decorator input span++nested_doc_comment :: Action+nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker+  where+    worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span))+      where+        endComment input lcomment+          = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span++        dropTrailingDec [] = []+        dropTrailingDec "-}" = ""+        dropTrailingDec (x:xs) = x:dropTrailingDec xs++{-# INLINE nested_comment_logic #-}+-- | Includes the trailing '-}' decorators+-- drop the last two elements with the callback if you don't want them to be included+nested_comment_logic+  :: (AlexInput -> Located String -> P (PsLocated Token))  -- ^ Continuation that gets the rest of the input and the lexed comment+  -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment+  -> AlexInput+  -> PsSpan+  -> P (PsLocated Token)+nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input+  where+    go commentAcc 0 input@(AI end_loc _) = do+      let comment = reverse commentAcc+          cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc+          lcomment = L cspan comment+      endComment input lcomment+    go commentAcc n input = case alexGetChar' input of+      Nothing -> errBrace input (psRealSpan span)+      Just ('-',input) -> case alexGetChar' input of+        Nothing  -> errBrace input (psRealSpan span)+        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'+        Just (_,_)          -> go ('-':commentAcc) n input+      Just ('\123',input) -> case alexGetChar' input of  -- '{' char+        Nothing  -> errBrace input (psRealSpan span)+        Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input+        Just (_,_)       -> go ('\123':commentAcc) n input+      -- See Note [Nested comment line pragmas]+      Just ('\n',input) -> case alexGetChar' input of+        Nothing  -> errBrace input (psRealSpan span)+        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input+                           go (parsedAcc ++ '\n':commentAcc) n input+        Just (_,_)   -> go ('\n':commentAcc) n input+      Just (c,input) -> go (c:commentAcc) n input++-- See Note [Nested comment line pragmas]+parseNestedPragma :: AlexInput -> P (String,AlexInput)+parseNestedPragma input@(AI _ buf) = do+  origInput <- getInput+  setInput input+  setExts (.|. xbit InNestedCommentBit)+  pushLexState bol+  lt <- lexToken+  _ <- popLexState+  setExts (.&. complement (xbit InNestedCommentBit))+  postInput@(AI _ postBuf) <- getInput+  setInput origInput+  case unLoc lt of+    ITcomment_line_prag -> do+      let bytes = byteDiff buf postBuf+          diff  = lexemeToString buf bytes+      return (reverse diff, postInput)+    lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))++{-+Note [Nested comment line pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to ignore cpp-preprocessor-generated #line pragmas if they were inside+nested comments.++Now, when parsing a nested comment, if we encounter a line starting with '#' we+call parseNestedPragma, which executes the following:+1. Save the current lexer input (loc, buf) for later+2. Set the current lexer input to the beginning of the line starting with '#'+3. Turn the 'InNestedComment' extension on+4. Push the 'bol' lexer state+5. Lex a token. Due to (2), (3), and (4), this should always lex a single line+   or less and return the ITcomment_line_prag token. This may set source line+   and file location if a #line pragma is successfully parsed+6. Restore lexer input and state to what they were before we did all this+7. Return control to the function parsing a nested comment, informing it of+   what the lexer parsed++Regarding (5) above:+Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)+checks if the 'InNestedComment' extension is set. If it is, that function will+return control to parseNestedPragma by returning the ITcomment_line_prag token.++See #314 for more background on the bug this fixes.+-}++{-# INLINE withLexedDocType #-}+withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))+                 -> P (PsLocated Token)+withLexedDocType lexDocComment = do+  input@(AI _ buf) <- getInput+  l <- getLastLocIncludingComments+  case prevChar buf ' ' of+    -- The `Bool` argument to lexDocComment signals whether or not the next+    -- line of input might also belong to this doc comment.+    '|' -> lexDocComment input (mkHdkCommentNext l) True+    '^' -> lexDocComment input (mkHdkCommentPrev l) True+    '$' -> case lexDocName input of+       Nothing -> do setInput input; lexToken -- eof reached, lex it normally+       Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True+    '*' -> lexDocSection l 1 input+    _ -> panic "withLexedDocType: Bad doc type"+ where+    lexDocSection l n input = case alexGetChar' input of+      Just ('*', input) -> lexDocSection l (n+1) input+      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection l n) False+      Nothing -> do setInput input; lexToken -- eof reached, lex it normally++    lexDocName :: AlexInput -> Maybe (String, AlexInput)+    lexDocName = go ""+      where+        go acc input = case alexGetChar' input of+          Just (c, input')+            | isSpace c -> Just (reverse acc, input)+            | otherwise -> go (c:acc) input'+          Nothing -> Nothing++mkHdkCommentNext, mkHdkCommentPrev  :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)+mkHdkCommentNext loc mkDS =  (HdkCommentNext ds,ITdocComment ds loc)+  where ds = mkDS HsDocStringNext+mkHdkCommentPrev loc mkDS =  (HdkCommentPrev ds,ITdocComment ds loc)+  where ds = mkDS HsDocStringPrevious++mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)+mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc)+  where ds = mkDS (HsDocStringNamed name)++mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)+mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)+  where ds = mkDS (HsDocStringGroup n)++-- RULES pragmas turn on the forall and '.' keywords, and we turn them+-- off again at the end of the pragma.+rulePrag :: Action+rulePrag span buf len _buf2 = do+  setExts (.|. xbit InRulePragBit)+  let !src = lexemeToFastString buf len+  return (L span (ITrules_prag (SourceText src)))++-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead+-- of updating the position in 'PState'+linePrag :: Action+linePrag span buf len buf2 = do+  usePosPrags <- getBit UsePosPragsBit+  if usePosPrags+    then begin line_prag2 span buf len buf2+    else let !src = lexemeToFastString buf len+         in return (L span (ITline_prag (SourceText src)))++-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead+-- of updating the position in 'PState'+columnPrag :: Action+columnPrag span buf len buf2 = do+  usePosPrags <- getBit UsePosPragsBit+  if usePosPrags+    then begin column_prag span buf len buf2+    else let !src = lexemeToFastString buf len+         in return (L span (ITcolumn_prag (SourceText src)))++endPrag :: Action+endPrag span _buf _len _buf2 = do+  setExts (.&. complement (xbit InRulePragBit))+  return (L span ITclose_prag)++-- docCommentEnd+-------------------------------------------------------------------------------+-- This function is quite tricky. We can't just return a new token, we also+-- need to update the state of the parser. Why? Because the token is longer+-- than what was lexed by Alex, and the lexToken function doesn't know this, so+-- it writes the wrong token length to the parser state. This function is+-- called afterwards, so it can just update the state.++{-# INLINE commentEnd #-}+commentEnd :: P (PsLocated Token)+           -> AlexInput+           -> (Maybe HdkComment, Token)+           -> StringBuffer+           -> PsSpan+           -> P (PsLocated Token)+commentEnd cont input (m_hdk_comment, hdk_token) buf span = do+  setInput input+  let (AI loc nextBuf) = input+      span' = mkPsSpan (psSpanStart span) loc+      last_len = byteDiff buf nextBuf+  span `seq` setLastToken span' last_len+  whenIsJust m_hdk_comment $ \hdk_comment ->+    P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) ()+  b <- getBit RawTokenStreamBit+  if b then return (L span' hdk_token)+       else cont++{-# INLINE docCommentEnd #-}+docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer ->+                 PsSpan -> P (PsLocated Token)+docCommentEnd input (hdk_comment, tok) buf span+  = commentEnd lexToken input (Just hdk_comment, tok) buf span++errBrace :: AlexInput -> RealSrcSpan -> P a+errBrace (AI end _) span =+  failLocMsgP (realSrcSpanStart span)+              (psRealLoc end)+              (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF))++open_brace, close_brace :: Action+open_brace span _str _len _buf2 = do+  ctx <- getContext+  setContext (NoLayout:ctx)+  return (L span ITocurly)+close_brace span _str _len _buf2 = do+  popContext+  return (L span ITccurly)++qvarid, qconid :: StringBuffer -> Int -> Token+qvarid buf len = ITqvarid $! splitQualName buf len False+qconid buf len = ITqconid $! splitQualName buf len False++splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)+-- takes a StringBuffer and a length, and returns the module name+-- and identifier parts of a qualified name.  Splits at the *last* dot,+-- because of hierarchical module names.+--+-- Throws an error if the name is not qualified.+splitQualName orig_buf len parens = split orig_buf orig_buf+  where+    split buf dot_buf+        | orig_buf `byteDiff` buf >= len  = done dot_buf+        | c == '.'                        = found_dot buf'+        | otherwise                       = split buf' dot_buf+      where+       (c,buf') = nextChar buf++    -- careful, we might get names like M....+    -- so, if the character after the dot is not upper-case, this is+    -- the end of the qualifier part.+    found_dot buf -- buf points after the '.'+        | isUpper c    = split buf' buf+        | otherwise    = done buf+      where+       (c,buf') = nextChar buf++    done dot_buf+        | qual_size < 1 = error "splitQualName got an unqualified named"+        | otherwise =+        (lexemeToFastString orig_buf (qual_size - 1),+         if parens -- Prelude.(+)+            then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)+            else lexemeToFastString dot_buf (len - qual_size))+      where+        qual_size = orig_buf `byteDiff` dot_buf++varid :: Action+varid span buf len _buf2 =+  case lookupUFM reservedWordsFM fs of+    Just (ITcase, _) -> do+      lastTk <- getLastTk+      keyword <- case lastTk of+        Strict.Just (L _ ITlam) -> do+          lambdaCase <- getBit LambdaCaseBit+          unless lambdaCase $ do+            pState <- getPState+            addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase+          return ITlcase+        _ -> return ITcase+      maybe_layout keyword+      return $ L span keyword+    Just (ITlcases, _) -> do+      lastTk <- getLastTk+      lambdaCase <- getBit LambdaCaseBit+      token <- case lastTk of+        Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases+        _ -> return $ ITvarid fs+      maybe_layout token+      return $ L span token+    Just (keyword, 0) -> do+      maybe_layout keyword+      return $ L span keyword+    Just (keyword, i) -> do+      exts <- getExts+      if exts .&. i /= 0+        then do+          maybe_layout keyword+          return $ L span keyword+        else+          return $ L span $ ITvarid fs+    Nothing ->+      return $ L span $ ITvarid fs+  where+    !fs = lexemeToFastString buf len++conid :: StringBuffer -> Int -> Token+conid buf len = ITconid $! lexemeToFastString buf len++qvarsym, qconsym :: StringBuffer -> Int -> Token+qvarsym buf len = ITqvarsym $! splitQualName buf len False+qconsym buf len = ITqconsym $! splitQualName buf len False+++errSuffixAt :: PsSpan -> P a+errSuffixAt span = do+    input <- getInput+    failLocMsgP start (go input start) (\srcSpan -> mkPlainErrorMsgEnvelope srcSpan $ PsErrSuffixAT)+  where+    start = psRealLoc (psSpanStart span)+    go inp loc+      | Just (c, i) <- alexGetChar inp+      , let next = advanceSrcLoc loc c =+          if c == ' '+          then go i next+          else next+      | otherwise = loc++-- See Note [Whitespace-sensitive operator parsing]+varsym :: OpWs -> Action+varsym opws@OpWsPrefix = sym $ \span exts s ->+  let warnExtConflict errtok =+        do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)+           ; return (ITvarsym s) }+  in+  if | s == fsLit "@" ->+         return ITtypeApp  -- regardless of TypeApplications for better error messages+     | s == fsLit "%" ->+         if xtest LinearTypesBit exts+         then return ITpercent+         else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent+     | s == fsLit "$" ->+         if xtest ThQuotesBit exts+         then return ITdollar+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar+     | s == fsLit "$$" ->+         if xtest ThQuotesBit exts+         then return ITdollardollar+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar+     | s == fsLit "-" ->+         return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus+                              -- and don't hit this code path. See Note [Minus tokens]+     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts ->+         return (ITproj True) -- e.g. '(.x)'+     | s == fsLit "." -> return ITdot+     | s == fsLit "!" -> return ITbang+     | s == fsLit "~" -> return ITtilde+     | otherwise ->+         do { warnOperatorWhitespace opws span s+            ; return (ITvarsym s) }+varsym opws@OpWsSuffix = sym $ \span _ s ->+  if | s == fsLit "@" -> errSuffixAt span+     | s == fsLit "." -> return ITdot+     | otherwise ->+         do { warnOperatorWhitespace opws span s+            ; return (ITvarsym s) }+varsym opws@OpWsTightInfix = sym $ \span exts s ->+  if | s == fsLit "@" -> return ITat+     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)+     | s == fsLit "." -> return ITdot+     | otherwise ->+         do { warnOperatorWhitespace opws span s+            ; return (ITvarsym s) }+varsym OpWsLooseInfix = sym $ \_ _ s ->+  if | s == fsLit "."+     -> return ITdot+     | otherwise+     -> return $ ITvarsym s++consym :: OpWs -> Action+consym opws = sym $ \span _exts s ->+  do { warnOperatorWhitespace opws span s+     ; return (ITconsym s) }++warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P ()+warnOperatorWhitespace opws span s =+  whenIsJust (check_unusual_opws opws) $ \opws' ->+    addPsMessage+      (mkSrcSpanPs span)+      (PsWarnOperatorWhitespace s opws')++-- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix).+-- This determines if -Woperator-whitespace is triggered.+check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence+check_unusual_opws opws =+  case opws of+    OpWsPrefix     -> Just OperatorWhitespaceOccurrence_Prefix+    OpWsSuffix     -> Just OperatorWhitespaceOccurrence_Suffix+    OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix+    OpWsLooseInfix -> Nothing++sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action+sym con span buf len _buf2 =+  case lookupUFM reservedSymsFM fs of+    Just (keyword, NormalSyntax, 0) ->+      return $ L span keyword+    Just (keyword, NormalSyntax, i) -> do+      exts <- getExts+      if exts .&. i /= 0+        then return $ L span keyword+        else L span <$!> con span exts fs+    Just (keyword, UnicodeSyntax, 0) -> do+      exts <- getExts+      if xtest UnicodeSyntaxBit exts+        then return $ L span keyword+        else L span <$!> con span exts fs+    Just (keyword, UnicodeSyntax, i) -> do+      exts <- getExts+      if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts+        then return $ L span keyword+        else L span <$!> con span exts fs+    Nothing -> do+      exts <- getExts+      L span <$!> con span exts fs+  where+    !fs = lexemeToFastString buf len++-- Variations on the integral numeric literal.+tok_integral+  :: (SourceText -> Integer -> Token) -- ^ token constructor+  -> (Integer -> Integer)             -- ^ value transformation (e.g. negate)+  -> Int                              -- ^ Offset of the unsigned value (e.g. 1 when we parsed "-", 2 for "0x", etc.)+  -> Int                              -- ^ Number of non-numeric characters parsed (e.g. 6 in "-12#Int8")+  -> (Integer, (Char -> Int))         -- ^ (radix, char_to_int parsing function)+  -> Action+tok_integral mk_token transval offset translen (radix,char_to_int) span buf len _buf2 = do+  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473+  let src = lexemeToFastString buf len+  when ((not numericUnderscores) && ('_' `elem` unpackFS src)) $ do+    pState <- getPState+    let msg = PsErrNumUnderscores NumUnderscore_Integral+    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg+  return $ L span $ mk_token (SourceText src)+       $! transval $ parseUnsignedInteger+       (offsetBytes offset buf) (subtract translen len) radix char_to_int++-- | Helper to parse ExtendedLiterals (e.g. -0x10#Word32)+--+-- This function finds the offset of the "#" character and checks that the+-- suffix is valid. Then it calls tok_integral with the appropriate suffix+-- length taken into account.+tok_prim_num_ext+  :: (Integer -> Integer)             -- ^ value transformation (e.g. negate)+  -> Int                              -- ^ Offset of the unsigned value (e.g. 1 when we parsed "-", 2 for "0x", etc.)+  -> (Integer, (Char -> Int))         -- ^ (radix, char_to_int parsing function)+  -> Action+tok_prim_num_ext transval offset (radix,char_to_int) span buf len buf2 = do+  let !suffix_offset = findHashOffset buf + 1+  let !suffix_len    = len - suffix_offset+  let !suffix        = lexemeToFastString (offsetBytes suffix_offset buf) suffix_len++  mk_token <- if+    | suffix == fsLit "Word"   -> pure ITprimword+    | suffix == fsLit "Word8"  -> pure ITprimword8+    | suffix == fsLit "Word16" -> pure ITprimword16+    | suffix == fsLit "Word32" -> pure ITprimword32+    | suffix == fsLit "Word64" -> pure ITprimword64+    | suffix == fsLit "Int"    -> pure ITprimint+    | suffix == fsLit "Int8"   -> pure ITprimint8+    | suffix == fsLit "Int16"  -> pure ITprimint16+    | suffix == fsLit "Int32"  -> pure ITprimint32+    | suffix == fsLit "Int64"  -> pure ITprimint64+    | otherwise                -> srcParseFail++  let !translen      = suffix_len+offset+1+  tok_integral mk_token transval offset translen (radix,char_to_int) span buf len buf2++++tok_num :: (Integer -> Integer)+        -> Int -> Int+        -> (Integer, (Char->Int)) -> Action+tok_num = tok_integral $ \case+    st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True)+    st@(SourceText _)       -> itint st (const False)+    st@NoSourceText         -> itint st (< 0)+  where+    itint :: SourceText -> (Integer -> Bool) -> Integer -> Token+    itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val)++tok_primint :: (Integer -> Integer)+            -> Int -> Int+            -> (Integer, (Char->Int)) -> Action+tok_primint = tok_integral ITprimint+++tok_primword :: Int -> Int+             -> (Integer, (Char->Int)) -> Action+tok_primword = tok_integral ITprimword positive++positive, negative :: (Integer -> Integer)+positive = id+negative = negate++binary, octal, decimal, hexadecimal :: (Integer, Char -> Int)+binary      = (2,octDecDigit)+octal       = (8,octDecDigit)+decimal     = (10,octDecDigit)+hexadecimal = (16,hexDigit)++-- readSignificandExponentPair can understand negative rationals, exponents, everything.+tok_frac :: Int -> (String -> Token) -> Action+tok_frac drop f span buf len _buf2 = do+  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473+  let src = lexemeToString buf (len-drop)+  when ((not numericUnderscores) && ('_' `elem` src)) $ do+    pState <- getPState+    let msg = PsErrNumUnderscores NumUnderscore_Float+    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg+  return (L span $! (f $! src))++tok_float, tok_primfloat, tok_primdouble, tok_prim_hex_float, tok_prim_hex_double :: String -> Token+tok_float        str = ITrational   $! readFractionalLit str+tok_hex_float    str = ITrational   $! readHexFractionalLit str+tok_primfloat    str = ITprimfloat  $! readFractionalLit str+tok_primdouble   str = ITprimdouble $! readFractionalLit str+tok_prim_hex_float  str = ITprimfloat $! readHexFractionalLit str+tok_prim_hex_double str = ITprimdouble $! readHexFractionalLit str++readFractionalLit, readHexFractionalLit :: String -> FractionalLit+readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2+readFractionalLit = readFractionalLitX readSignificandExponentPair Base10++readFractionalLitX :: (String -> (Integer, Integer))+                   -> FractionalExponentBase+                   -> String -> FractionalLit+readFractionalLitX readStr b str =+  mkSourceFractionalLit str is_neg i e b+  where+    is_neg = case str of+                    '-' : _ -> True+                    _      -> False+    (i, e) = readStr str++-- -----------------------------------------------------------------------------+-- Layout processing++-- we're at the first token on a line, insert layout tokens if necessary+do_bol :: Action+do_bol span _str _len _buf2 = do+        -- See Note [Nested comment line pragmas]+        b <- getBit InNestedCommentBit+        if b then return (L span ITcomment_line_prag) else do+          (pos, gen_semic) <- getOffside+          case pos of+              LT -> do+                  --trace "layout: inserting '}'" $ do+                  popContext+                  -- do NOT pop the lex state, we might have a ';' to insert+                  return (L span ITvccurly)+              EQ | gen_semic -> do+                  --trace "layout: inserting ';'" $ do+                  _ <- popLexState+                  return (L span ITsemi)+              _ -> do+                  _ <- popLexState+                  lexToken++-- certain keywords put us in the "layout" state, where we might+-- add an opening curly brace.+maybe_layout :: Token -> P ()+maybe_layout t = do -- If the alternative layout rule is enabled then+                    -- we never create an implicit layout context here.+                    -- Layout is handled XXX instead.+                    -- The code for closing implicit contexts, or+                    -- inserting implicit semi-colons, is therefore+                    -- irrelevant as it only applies in an implicit+                    -- context.+                    alr <- getBit AlternativeLayoutRuleBit+                    unless alr $ f t+    where f (ITdo _)    = pushLexState layout_do+          f (ITmdo _)   = pushLexState layout_do+          f ITof        = pushLexState layout+          f ITlcase     = pushLexState layout+          f ITlcases    = pushLexState layout+          f ITlet       = pushLexState layout+          f ITwhere     = pushLexState layout+          f ITrec       = pushLexState layout+          f ITif        = pushLexState layout_if+          f _           = return ()++-- Pushing a new implicit layout context.  If the indentation of the+-- next token is not greater than the previous layout context, then+-- Haskell 98 says that the new layout context should be empty; that is+-- the lexer must generate {}.+--+-- We are slightly more lenient than this: when the new context is started+-- by a 'do', then we allow the new context to be at the same indentation as+-- the previous context.  This is what the 'strict' argument is for.+new_layout_context :: Bool -> Bool -> Token -> Action+new_layout_context strict gen_semic tok span _buf len _buf2 = do+    _ <- popLexState+    (AI l _) <- getInput+    let offset = srcLocCol (psRealLoc l) - len+    ctx <- getContext+    nondecreasing <- getBit NondecreasingIndentationBit+    let strict' = strict || not nondecreasing+    case ctx of+        Layout prev_off _ : _  |+           (strict'     && prev_off >= offset  ||+            not strict' && prev_off > offset) -> do+                -- token is indented to the left of the previous context.+                -- we must generate a {} sequence now.+                pushLexState layout_left+                return (L span tok)+        _ -> do setContext (Layout offset gen_semic : ctx)+                return (L span tok)++do_layout_left :: Action+do_layout_left span _buf _len _buf2 = do+    _ <- popLexState+    pushLexState bol  -- we must be at the start of a line+    return (L span ITvccurly)++-- -----------------------------------------------------------------------------+-- LINE pragmas++setLineAndFile :: Int -> Action+setLineAndFile code (PsSpan span _) buf len _buf2 = do+  let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark+      linenumLen = length $ head $ words src+      linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit+      file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src+          -- skip everything through first quotation mark to get to the filename+        where go ('\\':c:cs) = c : go cs+              go (c:cs)      = c : go cs+              go []          = []+              -- decode escapes in the filename.  e.g. on Windows+              -- when our filenames have backslashes in, gcc seems to+              -- escape the backslashes.  One symptom of not doing this+              -- is that filenames in error messages look a bit strange:+              --   C:\\foo\bar.hs+              -- only the first backslash is doubled, because we apply+              -- System.FilePath.normalise before printing out+              -- filenames and it does not remove duplicate+              -- backslashes after the drive letter (should it?).+  resetAlrLastLoc file+  setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))+      -- subtract one: the line number refers to the *following* line+  addSrcFile file+  _ <- popLexState+  pushLexState code+  lexToken++setColumn :: Action+setColumn (PsSpan span _) buf len _buf2 = do+  let column =+        case reads (lexemeToString buf len) of+          [(column, _)] -> column+          _ -> error "setColumn: expected integer" -- shouldn't happen+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)+                          (fromIntegral (column :: Integer)))+  _ <- popLexState+  lexToken++alrInitialLoc :: FastString -> RealSrcSpan+alrInitialLoc file = mkRealSrcSpan loc loc+    where -- This is a hack to ensure that the first line in a file+          -- looks like it is after the initial location:+          loc = mkRealSrcLoc file (-1) (-1)++-- -----------------------------------------------------------------------------+-- Options, includes and language pragmas.+++lex_string_prag :: (String -> Token) -> Action+lex_string_prag mkTok = lex_string_prag_comment mkTok'+  where+    mkTok' s _ = mkTok s++lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action+lex_string_prag_comment mkTok span _buf _len _buf2+    = do input <- getInput+         start <- getParsedLoc+         l <- getLastLocIncludingComments+         tok <- go l [] input+         end <- getParsedLoc+         return (L (mkPsSpan start end) tok)+    where go l acc input+              = if isString input "#-}"+                   then do setInput input+                           return (mkTok (reverse acc) l)+                   else case alexGetChar input of+                          Just (c,i) -> go l (c:acc) i+                          Nothing -> err input+          isString _ [] = True+          isString i (x:xs)+              = case alexGetChar i of+                  Just (c,i') | c == x    -> isString i' xs+                  _other -> False+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span))+                                       (psRealLoc end)+                                       (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF)++-- -----------------------------------------------------------------------------+-- Strings & Chars++tok_string :: Action+tok_string span buf len _buf2 = do+  s <- lex_chars ("\"", "\"") span buf (if endsInHash then len - 1 else len)++  if endsInHash+    then do+      when (any (> '\xFF') s) $ do+        pState <- getPState+        let msg = PsErrPrimStringInvalidChar+        let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg+        addError err+      pure $ L span (ITprimstring src (unsafeMkByteString s))+    else+      pure $ L span (ITstring src (mkFastString s))+  where+    src = SourceText $ lexemeToFastString buf len+    endsInHash = currentChar (offsetBytes (len - 1) buf) == '#'++{- Note [Lexing multiline strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ideally, we would lex multiline strings completely with Alex syntax, like+normal strings. However, we can't because:++    1. The multiline string should all be one lexical token, not multiple+    2. We need to allow bare quotes, which can't be done with one regex++Instead, we'll lex them with a hybrid solution in tok_string_multi by manually+invoking lex states. This allows us to get the performance of native Alex+syntax as much as possible, and just gluing the pieces together outside of+Alex.++Implemented in string_multi_content in GHC/Parser/Lexer/String.x+-}++-- | See Note [Lexing multiline strings]+tok_string_multi :: Action+tok_string_multi startSpan startBuf _len _buf2 = do+  -- advance to the end of the multiline string+  let startLoc = psSpanStart startSpan+  let i@(AI _ contentStartBuf) =+        case lexDelim $ AI startLoc startBuf of+          Just i -> i+          Nothing -> panic "tok_string_multi did not start with a delimiter"+  (AI _ contentEndBuf, i'@(AI endLoc endBuf)) <- goContent i++  -- build the values pertaining to the entire multiline string, including delimiters+  let span = mkPsSpan startLoc endLoc+  let len = byteDiff startBuf endBuf+  let src = SourceText $ lexemeToFastString startBuf len++  -- load the content of the multiline string+  let contentLen = byteDiff contentStartBuf contentEndBuf+  s <-+    either (throwStringLexError (AI startLoc startBuf)) pure $+      lexMultilineString contentLen contentStartBuf++  setInput i'+  pure $ L span $ ITstringMulti src (mkFastString s)+  where+    goContent i0 =+      case Lexer.String.alexScan i0 Lexer.String.string_multi_content of+        Lexer.String.AlexToken i1 len _+          | Just i2 <- lexDelim i1 -> pure (i1, i2)+          | isEOF i1 -> checkSmartQuotes >> setInput i1 >> lexError LexError+          -- Can happen if no patterns match, e.g. an unterminated gap+          | len == 0  -> setInput i1 >> lexError LexError+          | otherwise -> goContent i1+        Lexer.String.AlexSkip i1 _ -> goContent i1+        _ -> setInput i0 >> lexError LexError++    lexDelim =+      let go 0 i = Just i+          go n i =+            case alexGetChar' i of+              Just ('"', i') -> go (n - 1) i'+              _ -> Nothing+       in go (3 :: Int)++    -- See Note [Bare smart quote error]+    checkSmartQuotes = do+      let findSmartQuote i0@(AI loc _) =+            case alexGetChar' i0 of+              Just ('\\', i1) | Just (_, i2) <- alexGetChar' i1 -> findSmartQuote i2+              Just (c, i1)+                | isDoubleSmartQuote c -> Just (c, loc)+                | otherwise -> findSmartQuote i1+              _ -> Nothing+      case findSmartQuote (AI (psSpanStart startSpan) startBuf) of+        Just (c, loc) -> throwSmartQuoteError c loc+        Nothing -> pure ()++lex_chars :: (String, String) -> PsSpan -> StringBuffer -> Int -> P String+lex_chars (startDelim, endDelim) span buf len =+  either (throwStringLexError i0) pure $+    lexString contentLen contentBuf+  where+    i0@(AI _ contentBuf) = advanceInputBytes (length startDelim) $ AI (psSpanStart span) buf++    -- assumes delimiters are ASCII, with 1 byte per Char+    contentLen = len - length startDelim - length endDelim++throwStringLexError :: AlexInput -> StringLexError -> P a+throwStringLexError i (StringLexError e pos) = setInput (advanceInputTo pos i) >> lexError e+++tok_quoted_label :: Action+tok_quoted_label span buf len _buf2 = do+  s <- lex_chars ("#\"", "\"") span buf len+  pure $ L span (ITlabelvarid src (mkFastString s))+  where+    -- skip leading '#'+    src = SourceText . mkFastString . drop 1 $ lexemeToString buf len+++tok_char :: Action+tok_char span buf len _buf2 = do+  c <- lex_chars ("'", "'") span buf (if endsInHash then len - 1 else len) >>= \case+    [c] -> pure c+    s -> panic $ "tok_char expected exactly one character, got: " ++ show s+  pure . L span $+    if endsInHash+      then ITprimchar src c+      else ITchar src c+  where+    src = SourceText $ lexemeToFastString buf len+    endsInHash = currentChar (offsetBytes (len - 1) buf) == '#'+++-- -----------------------------------------------------------------------------+-- QuasiQuote++lex_qquasiquote_tok :: Action+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)))++lex_quasiquote_tok :: Action+lex_quasiquote_tok span buf len _buf2 = do+  let quoter = tail (lexemeToString buf (len - 1))+                -- 'tail' drops the initial '[',+                -- while the -1 drops the trailing '|'+  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)))++lex_quasiquote :: RealSrcLoc -> String -> P String+lex_quasiquote start s = do+  i <- getInput+  case alexGetChar' i of+    Nothing -> quasiquote_error start++    -- NB: The string "|]" terminates the quasiquote,+    -- with absolutely no escaping. See the extensive+    -- discussion on #5348 for why there is no+    -- escape handling.+    Just ('|',i)+        | Just (']',i) <- alexGetChar' i+        -> do { setInput i; return s }++    Just (c, i) -> do+         setInput i; lex_quasiquote start (c : s)++quasiquote_error :: RealSrcLoc -> P a+quasiquote_error start = do+  (AI end buf) <- getInput+  reportLexError start (psRealLoc end) buf+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k))++-- -----------------------------------------------------------------------------+-- Unicode Smart Quote detection (#21843)++isSmartQuote :: AlexAccPred ExtsBitmap+isSmartQuote _ _ _ (AI _ buf) = let c = prevChar buf ' ' in isSingleSmartQuote c || isDoubleSmartQuote c++throwSmartQuoteError :: Char -> PsLoc -> P a+throwSmartQuoteError c loc = addFatalError err+  where+    err =+      mkPlainErrorMsgEnvelope (mkSrcSpanPs (mkPsSpan loc loc)) $+        PsErrUnicodeCharLooksLike c correct_char correct_char_name+    (correct_char, correct_char_name) =+      if isSingleSmartQuote c+        then ('\'', "Single Quote")+        else ('"', "Quotation Mark")++-- | Throw a smart quote error, where the smart quote was the last character lexed+smart_quote_error :: Action+smart_quote_error span _ _ buf2 = do+  let c = prevChar buf2 (panic "smart_quote_error unexpectedly called on beginning of input")+  throwSmartQuoteError c (psSpanStart span)++-- Note [Bare smart quote error]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A smart quote inside of a string is allowed, but if a complete valid string+-- couldn't be lexed, we want to see if there's a smart quote that the user+-- thought ended the string, but in fact didn't.++-- -----------------------------------------------------------------------------+-- Warnings++warnTab :: Action+warnTab srcspan _buf _len _buf2 = do+    addTabWarning (psRealSpan srcspan)+    lexToken++warnThen :: PsMessage -> Action -> Action+warnThen warning action srcspan buf len buf2 = do+    addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning+    action srcspan buf len buf2++-- -----------------------------------------------------------------------------+-- The Parse Monad++-- | Do we want to generate ';' layout tokens? In some cases we just want to+-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates+-- alternatives (unlike a `case` expression where we need ';' to as a separator+-- between alternatives).+type GenSemic = Bool++generateSemic, dontGenerateSemic :: GenSemic+generateSemic     = True+dontGenerateSemic = False++data LayoutContext+  = NoLayout+  | Layout !Int !GenSemic+  deriving Show++-- | The result of running a parser.+newtype ParseResult a = PR (# (# PState, a #) | PState #)++-- | The parser has consumed a (possibly empty) prefix of the input and produced+-- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal+-- errors.+--+-- The carried parsing state can be used to resume parsing.+pattern POk :: PState -> a -> ParseResult a+pattern POk s a = PR (# (# s , a #) | #)++-- | The parser has consumed a (possibly empty) prefix of the input and failed.+--+-- The carried parsing state can be used to resume parsing. It is the state+-- right before failure, including the fatal parse error. 'getPsMessages' and+-- 'getPsErrorMessages' must return a non-empty bag of errors.+pattern PFailed :: PState -> ParseResult a+pattern PFailed s = PR (# | s #)++{-# COMPLETE POk, PFailed #-}++-- | Test whether a 'WarningFlag' is set+warnopt :: WarningFlag -> ParserOpts -> Bool+warnopt f options = f `EnumSet.member` pWarningFlags options++-- | Parser options.+--+-- See 'mkParserOpts' to construct this.+data ParserOpts = ParserOpts+  { pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions+  , pDiagOpts       :: !DiagOpts+    -- ^ Options to construct diagnostic messages.+  }++pWarningFlags :: ParserOpts -> EnumSet WarningFlag+pWarningFlags opts = diag_warning_flags (pDiagOpts opts)++-- | Haddock comment as produced by the lexer. These are accumulated in 'PState'+-- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the+-- 'HsDocString's spans over the contents of the docstring - i.e. it does not+-- include the decorator ("-- |", "{-|" etc.)+data HdkComment+  = HdkCommentNext HsDocString+  | HdkCommentPrev HsDocString+  | HdkCommentNamed String HsDocString+  | HdkCommentSection Int HsDocString+  deriving Show++data PState = PState {+        buffer     :: StringBuffer,+        options    :: ParserOpts,+        warnings   :: Messages PsMessage,+        errors     :: Messages PsMessage,+        tab_first  :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file+        tab_count  :: !Word,             -- number of tab warnings in the file+        last_tk    :: Strict.Maybe (PsLocated Token), -- last non-comment token+        prev_loc   :: PsSpan,      -- pos of previous non-virtual token, including comments,+        last_loc   :: PsSpan,      -- pos of current token+        last_len   :: !Int,        -- len of current token+        loc        :: PsLoc,       -- current loc (end of prev token + 1)+        context    :: [LayoutContext],+        lex_state  :: [Int],+        srcfiles   :: [FastString],+        -- Used in the alternative layout rule:+        -- These tokens are the next ones to be sent out. They are+        -- just blindly emitted, without the rule looking at them again:+        alr_pending_implicit_tokens :: [PsLocated Token],+        -- This is the next token to be considered or, if it is Nothing,+        -- we need to get the next token from the input stream:+        alr_next_token :: Maybe (PsLocated Token),+        -- This is what we consider to be the location of the last token+        -- emitted:+        alr_last_loc :: PsSpan,+        -- The stack of layout contexts:+        alr_context :: [ALRContext],+        -- Are we expecting a '{'? If it's Just, then the ALRLayout tells+        -- us what sort of layout the '{' will open:+        alr_expecting_ocurly :: Maybe ALRLayout,+        -- Have we just had the '}' for a let block? If so, than an 'in'+        -- token doesn't need to close anything:+        alr_justClosedExplicitLetBlock :: Bool,++        -- The next three are used to implement Annotations giving the+        -- locations of 'noise' tokens in the source, so that users of+        -- the GHC API can do source to source conversions.+        -- See Note [exact print annotations] in GHC.Parser.Annotation+        eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token+        header_comments :: Strict.Maybe [LEpaComment],+        comment_q :: [LEpaComment],++        -- Haddock comments accumulated in ascending order of their location+        -- (BufPos). We use OrdList to get O(1) snoc.+        --+        -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock+        hdk_comments :: OrdList (PsLocated HdkComment)+     }+        -- last_loc and last_len are used when generating error messages,+        -- and in pushCurrentContext only.  Sigh, if only Happy passed the+        -- current token to happyError, we could at least get rid of last_len.+        -- Getting rid of last_loc would require finding another way to+        -- implement pushCurrentContext (which is only called from one place).++        -- AZ question: setLastToken which sets last_loc and last_len+        -- is called when processing AlexToken, immediately prior to+        -- calling the action in the token.  So from the perspective+        -- of the action, it is the *current* token.  Do I understand+        -- correctly?++data ALRContext = ALRNoLayout Bool{- does it contain commas? -}+                              Bool{- is it a 'let' block? -}+                | ALRLayout ALRLayout Int+data ALRLayout = ALRLayoutLet+               | ALRLayoutWhere+               | ALRLayoutOf+               | ALRLayoutDo++-- | The parsing monad, isomorphic to @StateT PState Maybe@.+newtype P a = P { unP :: PState -> ParseResult a }++instance Functor P where+  fmap = liftM++instance Applicative P where+  pure = returnP+  (<*>) = ap++instance Monad P where+  (>>=) = thenP++returnP :: a -> P a+returnP a = a `seq` (P $ \s -> POk s a)++thenP :: P a -> (a -> P b) -> P b+(P m) `thenP` k = P $ \ s ->+        case m s of+                POk s1 a         -> (unP (k a)) s1+                PFailed s1 -> PFailed s1++failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a+failMsgP f = do+  pState <- getPState+  addFatalError (f (mkSrcSpanPs (last_loc pState)))++failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a+failLocMsgP loc1 loc2 f =+  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))++getPState :: P PState+getPState = P $ \s -> POk s s++getExts :: P ExtsBitmap+getExts = P $ \s -> POk s (pExtsBitmap . options $ s)++setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()+setExts f = P $ \s -> POk s {+  options =+    let p = options s+    in  p { pExtsBitmap = f (pExtsBitmap p) }+  } ()++setSrcLoc :: RealSrcLoc -> P ()+setSrcLoc new_loc =+  P $ \s@(PState{ loc = PsLoc _ buf_loc }) ->+  POk s{ loc = PsLoc new_loc buf_loc } ()++getRealSrcLoc :: P RealSrcLoc+getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc)++getParsedLoc :: P PsLoc+getParsedLoc  = P $ \s@(PState{ loc=loc }) -> POk s loc++addSrcFile :: FastString -> P ()+addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()++setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()+setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } ()++setLastToken :: PsSpan -> Int -> P ()+setLastToken loc len = P $ \s -> POk s {+  last_loc=loc,+  last_len=len+  } ()++setLastTk :: PsLocated Token -> P ()+setLastTk tk@(L l _) = P $ \s ->+  if isPointRealSpan (psRealSpan l)+    then POk s { last_tk = Strict.Just tk } ()+    else POk s { last_tk = Strict.Just tk+               , prev_loc = l } ()++setLastComment :: PsLocated Token -> P ()+setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } ()++getLastTk :: P (Strict.Maybe (PsLocated Token))+getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk++-- see Note [PsSpan in Comments]+getLastLocIncludingComments :: P PsSpan+getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc++getLastLoc :: P PsSpan+getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc++{-# INLINE alexGetChar' #-}+-- This version does not squash unicode characters, it is used when+-- lexing strings.+alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar' (AI loc s)+  | atEnd s   = Nothing+  | otherwise = c `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (c, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advancePsLoc loc c++-- | Advance the given input N bytes.+advanceInputBytes :: Int -> AlexInput -> AlexInput+advanceInputBytes n i0@(AI _ buf0) = advanceInputTo (cur buf0 + n) i0++-- | Advance the given input to the given position.+advanceInputTo :: Int -> AlexInput -> AlexInput+advanceInputTo pos = go+  where+    go i@(AI _ buf)+      | cur buf >= pos = i+      | Just (_, i') <- alexGetChar' i = go i'+      | otherwise = i -- reached the end, just return the last input++getInput :: P AlexInput+getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)++setInput :: AlexInput -> P ()+setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()++nextIsEOF :: P Bool+nextIsEOF = isEOF <$> getInput++isEOF :: AlexInput -> Bool+isEOF (AI _ buf) = atEnd buf++pushLexState :: Int -> P ()+pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()++popLexState :: P Int+popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls++getLexState :: P Int+getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls++popNextToken :: P (Maybe (PsLocated Token))+popNextToken+    = P $ \s@PState{ alr_next_token = m } ->+              POk (s {alr_next_token = Nothing}) m++activeContext :: P Bool+activeContext = do+  ctxt <- getALRContext+  expc <- getAlrExpectingOCurly+  impt <- implicitTokenPending+  case (ctxt,expc) of+    ([],Nothing) -> return impt+    _other       -> return True++resetAlrLastLoc :: FastString -> P ()+resetAlrLastLoc file =+  P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) ->+  POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } ()++setAlrLastLoc :: PsSpan -> P ()+setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()++getAlrLastLoc :: P PsSpan+getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l++getALRContext :: P [ALRContext]+getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs++setALRContext :: [ALRContext] -> P ()+setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()++getJustClosedExplicitLetBlock :: P Bool+getJustClosedExplicitLetBlock+ = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b++setJustClosedExplicitLetBlock :: Bool -> P ()+setJustClosedExplicitLetBlock b+ = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()++setNextToken :: PsLocated Token -> P ()+setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()++implicitTokenPending :: P Bool+implicitTokenPending+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->+              case ts of+              [] -> POk s False+              _  -> POk s True++popPendingImplicitToken :: P (Maybe (PsLocated Token))+popPendingImplicitToken+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->+              case ts of+              [] -> POk s Nothing+              (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)++setPendingImplicitTokens :: [PsLocated Token] -> P ()+setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()++getAlrExpectingOCurly :: P (Maybe ALRLayout)+getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b++setAlrExpectingOCurly :: Maybe ALRLayout -> P ()+setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()++-- | For reasons of efficiency, boolean parsing flags (eg, language extensions+-- or whether we are currently in a @RULE@ pragma) are represented by a bitmap+-- stored in a @Word64@.+type ExtsBitmap = Word64++xbit :: ExtBits -> ExtsBitmap+xbit = bit . fromEnum++xtest :: ExtBits -> ExtsBitmap -> Bool+xtest ext xmap = testBit xmap (fromEnum ext)++xset :: ExtBits -> ExtsBitmap -> ExtsBitmap+xset ext xmap = setBit xmap (fromEnum ext)++xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap+xunset ext xmap = clearBit xmap (fromEnum ext)++-- | Various boolean flags, mostly language extensions, that impact lexing and+-- parsing. Note that a handful of these can change during lexing/parsing.+data ExtBits+  -- Flags that are constant once parsing starts+  = FfiBit+  | InterruptibleFfiBit+  | CApiFfiBit+  | ArrowsBit+  | ThBit+  | ThQuotesBit+  | IpBit+  | OverloadedLabelsBit -- #x overloaded labels+  | ExplicitForallBit -- the 'forall' keyword+  | BangPatBit -- Tells the parser to understand bang-patterns+               -- (doesn't affect the lexer)+  | PatternSynonymsBit -- pattern synonyms+  | HaddockBit-- Lex and parse Haddock comments+  | MagicHashBit -- "#" in both functions and operators+  | RecursiveDoBit -- mdo+  | QualifiedDoBit -- .do and .mdo+  | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc+  | UnboxedParensBit -- (# and #)+  | DatatypeContextsBit+  | MonadComprehensionsBit+  | TransformComprehensionsBit+  | QqBit -- enable quasiquoting+  | RawTokenStreamBit -- producing a token stream with all comments included+  | AlternativeLayoutRuleBit+  | ALRTransitionalBit+  | RelaxedLayoutBit+  | NondecreasingIndentationBit+  | SafeHaskellBit+  | TraditionalRecordSyntaxBit+  | ExplicitNamespacesBit+  | LambdaCaseBit+  | BinaryLiteralsBit+  | NegativeLiteralsBit+  | HexFloatLiteralsBit+  | StaticPointersBit+  | NumericUnderscoresBit+  | StarIsTypeBit+  | BlockArgumentsBit+  | NPlusKPatternsBit+  | DoAndIfThenElseBit+  | MultiWayIfBit+  | GadtSyntaxBit+  | ImportQualifiedPostBit+  | LinearTypesBit+  | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]+  | OverloadedRecordDotBit+  | OverloadedRecordUpdateBit+  | OrPatternsBit+  | ExtendedLiteralsBit+  | ListTuplePunsBit+  | ViewPatternsBit+  | RequiredTypeArgumentsBit+  | MultilineStringsBit+  | LevelImportsBit++  -- Flags that are updated once parsing starts+  | InRulePragBit+  | InNestedCommentBit -- See Note [Nested comment line pragmas]+  | UsePosPragsBit+    -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'+    -- update the internal position. Otherwise, those pragmas are lexed as+    -- tokens of their own.+  deriving Enum++{-# INLINE mkParserOpts #-}+mkParserOpts+  :: EnumSet LangExt.Extension  -- ^ permitted language extensions enabled+  -> DiagOpts                   -- ^ diagnostic options+  -> Bool                       -- ^ are safe imports on?+  -> Bool                       -- ^ keeping Haddock comment tokens+  -> Bool                       -- ^ keep regular comment tokens++  -> Bool+  -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update+  -- the internal position kept by the parser. Otherwise, those pragmas are+  -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.++  -> ParserOpts+-- ^ Given exactly the information needed, set up the 'ParserOpts'+mkParserOpts extensionFlags diag_opts+  safeImports isHaddock rawTokStream usePosPrags =+    ParserOpts {+      pDiagOpts      = diag_opts+    , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits+    }+  where+    safeHaskellBit = SafeHaskellBit `setBitIf` safeImports+    langExtBits =+          FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface+      .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI+      .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI+      .|. ArrowsBit                   `xoptBit` LangExt.Arrows+      .|. ThBit                       `xoptBit` LangExt.TemplateHaskell+      .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes+      .|. QqBit                       `xoptBit` LangExt.QuasiQuotes+      .|. IpBit                       `xoptBit` LangExt.ImplicitParams+      .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels+      .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll+      .|. BangPatBit                  `xoptBit` LangExt.BangPatterns+      .|. MagicHashBit                `xoptBit` LangExt.MagicHash+      .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo+      .|. QualifiedDoBit              `xoptBit` LangExt.QualifiedDo+      .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax+      .|. UnboxedParensBit            `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums]+      .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts+      .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp+      .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions+      .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule+      .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional+      .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout+      .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation+      .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax+      .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces+      .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase+      .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals+      .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals+      .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals+      .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms+      .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers+      .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores+      .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType+      .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments+      .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns+      .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse+      .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf+      .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax+      .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost+      .|. LinearTypesBit              `xoptBit` LangExt.LinearTypes+      .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]+      .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot+      .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).+      .|. OrPatternsBit               `xoptBit` LangExt.OrPatterns+      .|. ExtendedLiteralsBit         `xoptBit` LangExt.ExtendedLiterals+      .|. ListTuplePunsBit            `xoptBit` LangExt.ListTuplePuns+      .|. ViewPatternsBit             `xoptBit` LangExt.ViewPatterns+      .|. RequiredTypeArgumentsBit    `xoptBit` LangExt.RequiredTypeArguments+      .|. MultilineStringsBit         `xoptBit` LangExt.MultilineStrings+      .|. LevelImportsBit             `xoptBit` LangExt.ExplicitLevelImports+    optBits =+          HaddockBit        `setBitIf` isHaddock+      .|. RawTokenStreamBit `setBitIf` rawTokStream+      .|. UsePosPragsBit    `setBitIf` usePosPrags++    xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags+    xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags)++    orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts++    setBitIf :: ExtBits -> Bool -> ExtsBitmap+    b `setBitIf` cond | cond      = xbit b+                      | otherwise = 0++disableHaddock :: ParserOpts -> ParserOpts+disableHaddock opts = upd_bitmap (xunset HaddockBit)+  where+    upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }+++-- | Set parser options for parsing OPTIONS pragmas+initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initPragState options buf loc = (initParserState options buf loc)+   { lex_state = [bol, option_prags, 0]+   }++-- | Creates a parse state from a 'ParserOpts' value+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initParserState options buf loc =+  PState {+      buffer        = buf,+      options       = options,+      errors        = emptyMessages,+      warnings      = emptyMessages,+      tab_first     = Strict.Nothing,+      tab_count     = 0,+      last_tk       = Strict.Nothing,+      prev_loc      = mkPsSpan init_loc init_loc,+      last_loc      = mkPsSpan init_loc init_loc,+      last_len      = 0,+      loc           = init_loc,+      context       = [],+      lex_state     = [bol, 0],+      srcfiles      = [],+      alr_pending_implicit_tokens = [],+      alr_next_token = Nothing,+      alr_last_loc = PsSpan (alrInitialLoc (fsLit "<no file>")) (BufSpan (BufPos 0) (BufPos 0)),+      alr_context = [],+      alr_expecting_ocurly = Nothing,+      alr_justClosedExplicitLetBlock = False,+      eof_pos = Strict.Nothing,+      header_comments = Strict.Nothing,+      comment_q = [],+      hdk_comments = nilOL+    }+  where init_loc = PsLoc loc (BufPos 0)++-- | An mtl-style class for monads that support parsing-related operations.+-- For example, sometimes we make a second pass over the parsing results to validate,+-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume+-- input but can report parsing errors, check for extension bits, and accumulate+-- parsing annotations. Both P and PV are instances of MonadP.+--+-- MonadP grants us convenient overloading. The other option is to have separate operations+-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.+--+class Monad m => MonadP m where+  -- | Add a non-fatal error. Use this when the parser can produce a result+  --   despite the error.+  --+  --   For example, when GHC encounters a @forall@ in a type,+  --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@+  --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to+  --   the accumulator.+  --+  --   Control flow wise, non-fatal errors act like warnings: they are added+  --   to the accumulator and parsing continues. This allows GHC to report+  --   more than one parse error per file.+  --+  addError :: MsgEnvelope PsMessage -> m ()++  -- | Add a warning to the accumulator.+  --   Use 'getPsMessages' to get the accumulated warnings.+  addWarning :: MsgEnvelope PsMessage -> m ()++  -- | Add a fatal error. This will be the last error reported by the parser, and+  --   the parser will not produce any result, ending in a 'PFailed' state.+  addFatalError :: MsgEnvelope PsMessage -> m a++  -- | Get parser options+  getParserOpts :: m ParserOpts++  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that belong within the given span+  allocateCommentsP :: RealSrcSpan -> m EpAnnComments+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that come before or within the given span+  allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that come after the given span+  allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments++instance MonadP P where+  addError err+   = P $ \s -> POk s { errors = err `addMessage` errors s} ()++  -- If the warning is meant to be suppressed, GHC will assign+  -- a `SevIgnore` severity and the message will be discarded,+  -- so we can simply add it no matter what.+  addWarning w+   = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) ()++  addFatalError err =+    addError err >> P PFailed++  getParserOpts = P $ \s -> POk s $! options s++  allocateCommentsP ss = P $ \s ->+    if null (comment_q s) then POk s emptyComments else  -- fast path+    let (comment_q', newAnns) = allocateComments ss (comment_q s) in+      POk s {+         comment_q = comment_q'+       } (EpaComments newAnns)+  allocatePriorCommentsP ss = P $ \s ->+    let (header_comments', comment_q', newAnns)+             = allocatePriorComments ss (comment_q s) (header_comments s) in+      POk s {+         header_comments = header_comments',+         comment_q = comment_q'+       } (EpaComments newAnns)+  allocateFinalCommentsP ss = P $ \s ->+    let (header_comments', comment_q', newAnns)+             = allocateFinalComments ss (comment_q s) (header_comments s) in+      POk s {+         header_comments = header_comments',+         comment_q = comment_q'+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)++-- | Check if a given flag is currently set in the bitmap.+getBit :: MonadP m => ExtBits -> m Bool+getBit ext = (\opts -> ext `xtest` pExtsBitmap opts) <$> getParserOpts++getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getCommentsFor (RealSrcSpan l _) = allocateCommentsP l+getCommentsFor _ = return emptyComments++getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l+getPriorCommentsFor _ = return emptyComments++getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l+getFinalCommentsFor _ = return emptyComments++getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))+getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos++addPsMessage :: MonadP m => SrcSpan -> PsMessage -> m ()+addPsMessage srcspan msg = do+  diag_opts <- pDiagOpts <$> getParserOpts+  addWarning (mkPlainMsgEnvelope diag_opts srcspan msg)++addTabWarning :: RealSrcSpan -> P ()+addTabWarning srcspan+ = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->+       let tf' = tf <|> Strict.Just srcspan+           tc' = tc + 1+           s' = if warnopt Opt_WarnTabs o+                then s{tab_first = tf', tab_count = tc'}+                else s+       in POk s' ()++-- | Get a bag of the errors that have been accumulated so far.+--   Does not take -Werror into account.+getPsErrorMessages :: PState -> Messages PsMessage+getPsErrorMessages p = errors p++-- | Get the warnings and errors accumulated so far.+--   Does not take -Werror into account.+getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage)+getPsMessages p =+  let ws = warnings p+      diag_opts = pDiagOpts (options p)+      -- we add the tabulation warning on the fly because+      -- we count the number of occurrences of tab characters+      ws' = case tab_first p of+        Strict.Nothing -> ws+        Strict.Just tf ->+          let msg = mkPlainMsgEnvelope diag_opts+                          (RealSrcSpan tf Strict.Nothing)+                          (PsWarnTab (tab_count p))+          in msg `addMessage` ws+  in (ws', errors p)++getContext :: P [LayoutContext]+getContext = P $ \s@PState{context=ctx} -> POk s ctx++setContext :: [LayoutContext] -> P ()+setContext ctx = P $ \s -> POk s{context=ctx} ()++popContext :: P ()+popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,+                              last_len = len, last_loc = last_loc }) ->+  case ctx of+        (_:tl) ->+          POk s{ context = tl } ()+        []     ->+          unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s++-- Push a new layout context at the indentation of the last token read.+pushCurrentContext :: GenSemic -> P ()+pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->+    POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} ()++-- This is only used at the outer level of a module when the 'module' keyword is+-- missing.+pushModuleContext :: P ()+pushModuleContext = pushCurrentContext generateSemic++getOffside :: P (Ordering, Bool)+getOffside = P $ \s@PState{last_loc=loc, context=stk} ->+                let offs = srcSpanStartCol (psRealSpan loc) in+                let ord = case stk of+                            Layout n gen_semic : _ ->+                              --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $+                              (compare offs n, gen_semic)+                            _ ->+                              (GT, dontGenerateSemic)+                in POk s ord++-- ---------------------------------------------------------------------------+-- Construct a parse error++srcParseErr+  :: ParserOpts+  -> StringBuffer       -- current buffer (placed just after the last token)+  -> Int                -- length of the previous token+  -> SrcSpan+  -> MsgEnvelope PsMessage+srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details)+  where+   token = lexemeToString (offsetBytes (-len) buf) len+   pattern_ = decodePrevNChars 8 buf+   last100 = decodePrevNChars 100 buf+   doInLast100 = "do" `isInfixOf` last100+   mdoInLast100 = "mdo" `isInfixOf` last100+   th_enabled = ThQuotesBit `xtest` pExtsBitmap options+   ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options+   details = PsErrParseDetails {+       ped_th_enabled      = th_enabled+     , ped_do_in_last_100  = doInLast100+     , ped_mdo_in_last_100 = mdoInLast100+     , ped_pat_syn_enabled = ps_enabled+     , ped_pattern_parsed  = pattern_ == "pattern "+     }++-- Report a parse failure, giving the span of the previous token as+-- the location of the error.  This is the entry point for errors+-- detected during parsing.+srcParseFail :: P a+srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,+                            last_loc = last_loc } ->+    unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s++-- A lexical error is reported at a particular position in the source file,+-- not over a token range.+lexError :: LexErr -> P a+lexError e = do+  loc <- getRealSrcLoc+  (AI end buf) <- getInput+  reportLexError loc (psRealLoc end) buf+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k)++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a++lexer queueComments cont = do+  alr <- getBit AlternativeLayoutRuleBit+  let lexTokenFun = if alr then lexTokenAlr else lexToken+  (L span tok) <- lexTokenFun+  --trace ("token: " ++ show tok) $ do++  if (queueComments && isComment tok)+    then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont+    else cont (L (mkSrcSpanPs span) tok)++-- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging.+lexerDbg queueComments cont = lexer queueComments contDbg+  where+    contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok)++lexTokenAlr :: P (PsLocated Token)+lexTokenAlr = do mPending <- popPendingImplicitToken+                 t <- case mPending of+                      Nothing ->+                          do mNext <- popNextToken+                             t <- case mNext of+                                  Nothing -> lexToken+                                  Just next -> return next+                             alternativeLayoutRuleToken t+                      Just t ->+                          return t+                 setAlrLastLoc (getLoc t)+                 case unLoc t of+                     ITwhere  -> setAlrExpectingOCurly (Just ALRLayoutWhere)+                     ITlet    -> setAlrExpectingOCurly (Just ALRLayoutLet)+                     ITof     -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITlcase  -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITdo  _  -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     ITmdo _  -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     ITrec    -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     _        -> return ()+                 return t++alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)+alternativeLayoutRuleToken t+    = do context <- getALRContext+         lastLoc <- getAlrLastLoc+         mExpectingOCurly <- getAlrExpectingOCurly+         transitional <- getBit ALRTransitionalBit+         justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock+         setJustClosedExplicitLetBlock False+         let thisLoc = getLoc t+             thisCol = srcSpanStartCol (psRealSpan thisLoc)+             newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc)+         case (unLoc t, context, mExpectingOCurly) of+             -- This case handles a GHC extension to the original H98+             -- layout rule...+             (ITocurly, _, Just alrLayout) ->+                 do setAlrExpectingOCurly Nothing+                    let isLet = case alrLayout of+                                ALRLayoutLet -> True+                                _ -> False+                    setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)+                    return t+             -- ...and makes this case unnecessary+             {-+             -- I think our implicit open-curly handling is slightly+             -- different to John's, in how it interacts with newlines+             -- and "in"+             (ITocurly, _, Just _) ->+                 do setAlrExpectingOCurly Nothing+                    setNextToken t+                    lexTokenAlr+             -}+             (_, ALRLayout _ col : _ls, Just expectingOCurly)+              | (thisCol > col) ||+                (thisCol == col &&+                 isNonDecreasingIndentation expectingOCurly) ->+                 do setAlrExpectingOCurly Nothing+                    setALRContext (ALRLayout expectingOCurly thisCol : context)+                    setNextToken t+                    return (L thisLoc ITvocurly)+              | otherwise ->+                 do setAlrExpectingOCurly Nothing+                    setPendingImplicitTokens [L lastLoc ITvccurly]+                    setNextToken t+                    return (L lastLoc ITvocurly)+             (_, _, Just expectingOCurly) ->+                 do setAlrExpectingOCurly Nothing+                    setALRContext (ALRLayout expectingOCurly thisCol : context)+                    setNextToken t+                    return (L thisLoc ITvocurly)+             -- We do the [] cases earlier than in the spec, as we+             -- have an actual EOF token+             (ITeof, ALRLayout _ _ : ls, _) ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITvccurly)+             (ITeof, _, _) ->+                 return t+             -- the other ITeof case omitted; general case below covers it+             (ITin, _, _)+              | justClosedExplicitLetBlock ->+                 return t+             (ITin, ALRLayout ALRLayoutLet _ : ls, _)+              | newLine ->+                 do setPendingImplicitTokens [t]+                    setALRContext ls+                    return (L thisLoc ITvccurly)+             -- This next case is to handle a transitional issue:+             (ITwhere, ALRLayout _ col : ls, _)+              | newLine && thisCol == col && transitional ->+                 do addPsMessage+                      (mkSrcSpanPs thisLoc)+                      (PsWarnTransitionalLayout TransLayout_Where)+                    setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITvccurly)+             -- This next case is to handle a transitional issue:+             (ITvbar, ALRLayout _ col : ls, _)+              | newLine && thisCol == col && transitional ->+                 do addPsMessage+                      (mkSrcSpanPs thisLoc)+                      (PsWarnTransitionalLayout TransLayout_Pipe)+                    setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITvccurly)+             (_, ALRLayout _ col : ls, _)+              | newLine && thisCol == col ->+                 do setNextToken t+                    let loc = psSpanStart thisLoc+                        zeroWidthLoc = mkPsSpan loc loc+                    return (L zeroWidthLoc ITsemi)+              | newLine && thisCol < col ->+                 do setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITvccurly)+             -- We need to handle close before open, as 'then' is both+             -- an open and a close+             (u, _, _)+              | isALRclose u ->+                 case context of+                 ALRLayout _ _ : ls ->+                     do setALRContext ls+                        setNextToken t+                        return (L thisLoc ITvccurly)+                 ALRNoLayout _ isLet : ls ->+                     do let ls' = if isALRopen u+                                     then ALRNoLayout (containsCommas u) False : ls+                                     else ls+                        setALRContext ls'+                        when isLet $ setJustClosedExplicitLetBlock True+                        return t+                 [] ->+                     do let ls = if isALRopen u+                                    then [ALRNoLayout (containsCommas u) False]+                                    else []+                        setALRContext ls+                        -- XXX This is an error in John's code, but+                        -- it looks reachable to me at first glance+                        return t+             (u, _, _)+              | isALRopen u ->+                 do setALRContext (ALRNoLayout (containsCommas u) False : context)+                    return t+             (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->+                 do setALRContext ls+                    setPendingImplicitTokens [t]+                    return (L thisLoc ITvccurly)+             (ITin, ALRLayout _ _ : ls, _) ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITvccurly)+             -- the other ITin case omitted; general case below covers it+             (ITcomma, ALRLayout _ _ : ls, _)+              | topNoLayoutContainsCommas ls ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITvccurly)+             (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->+                 do setALRContext ls+                    setPendingImplicitTokens [t]+                    return (L thisLoc ITvccurly)+             -- the other ITwhere case omitted; general case below covers it+             (_, _, _) -> return t++isALRopen :: Token -> Bool+isALRopen ITcase          = True+isALRopen ITif            = True+isALRopen ITthen          = True+isALRopen IToparen        = True+isALRopen ITobrack        = True+isALRopen ITocurly        = True+-- GHC Extensions:+isALRopen IToubxparen     = True+isALRopen _               = False++isALRclose :: Token -> Bool+isALRclose ITof     = True+isALRclose ITthen   = True+isALRclose ITelse   = True+isALRclose ITcparen = True+isALRclose ITcbrack = True+isALRclose ITccurly = True+-- GHC Extensions:+isALRclose ITcubxparen = True+isALRclose _        = False++isNonDecreasingIndentation :: ALRLayout -> Bool+isNonDecreasingIndentation ALRLayoutDo = True+isNonDecreasingIndentation _           = False++containsCommas :: Token -> Bool+containsCommas IToparen = True+containsCommas ITobrack = True+-- John doesn't have {} as containing commas, but records contain them,+-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs+-- (defaultInstallDirs).+containsCommas ITocurly = True+-- GHC Extensions:+containsCommas IToubxparen = True+containsCommas _        = False++topNoLayoutContainsCommas :: [ALRContext] -> Bool+topNoLayoutContainsCommas [] = False+topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls+topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b++#ifdef MIN_TOOL_VERSION_alex+#if !MIN_TOOL_VERSION_alex(3,5,2)+-- If the generated alexScan/alexScanUser functions are called multiple times+-- in this file, alexScanUser gets broken out into a separate function and+-- increases memory usage. Make sure GHC inlines this function and optimizes it.+-- https://github.com/haskell/alex/pull/262++#endif+#endif++lexToken :: P (PsLocated Token)+lexToken = do+  inp@(AI loc1 buf) <- getInput+  sc <- getLexState+  exts <- getExts+  case alexScanUser exts inp sc of+    AlexEOF -> do+        let span = mkPsSpan loc1 loc1+        lc <- getLastLocIncludingComments+        setEofPos (psRealSpan span) (psRealSpan lc)+        setLastToken span 0+        return (L span ITeof)+    AlexError (AI loc2 buf) ->+        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf+          (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k)+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(AI end buf2) _ t -> do+        setInput inp2+        let span = mkPsSpan loc1 end+        let bytes = byteDiff buf buf2+        span `seq` setLastToken span bytes+        lt <- t span buf bytes buf2+        let lt' = unLoc lt+        if (isComment lt') then setLastComment lt else setLastTk lt+        return lt++reportLexError :: RealSrcLoc+               -> RealSrcLoc+               -> StringBuffer+               -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)+               -> P a+reportLexError loc1 loc2 buf f+  | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)+  | otherwise =+  let c = fst (nextChar buf)+  in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#+     then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)+     else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))++lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]+lexTokenStream opts buf loc = unP go initState{ options = opts' }+    where+    new_exts  =   xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens+                $ xset RawTokenStreamBit -- include comments+                $ pExtsBitmap opts+    opts'     = opts { pExtsBitmap = new_exts }+    initState = initParserState opts' buf loc+    go = do+      ltok <- lexer False return+      case ltok of+        L _ ITeof -> return []+        _ -> liftM (ltok:) go++linePrags = Map.singleton "line" linePrag++fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),+                                 ("options_ghc", lex_string_prag IToptions_prag),+                                 ("options_haddock", lex_string_prag_comment ITdocOptions),+                                 ("language", token ITlanguage_prag),+                                 ("include", lex_string_prag ITinclude_prag)])++ignoredPrags = Map.fromList (map ignored pragmas)+               where ignored opt = (opt, nested_comment)+                     impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]+                     options_pragmas = map ("options_" ++) impls+                     -- CFILES is a hugs-only thing.+                     pragmas = options_pragmas ++ ["cfiles", "contract"]++oneWordPrags = Map.fromList [+     ("rules", rulePrag),+     ("inline",+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),+     ("inlinable",+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),+     ("inlineable",+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),+                                    -- Spelling variant+     ("notinline",+         fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),+     ("opaque", fstrtoken (\s -> ITopaque_prag (SourceText s))),+     ("specialize", fstrtoken (\s -> ITspec_prag (SourceText s))),+     ("source", fstrtoken (\s -> ITsource_prag (SourceText s))),+     ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))),+     ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))),+     ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))),+     ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))),+     ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))),+     ("ann", fstrtoken (\s -> ITann_prag (SourceText s))),+     ("minimal", fstrtoken (\s -> ITminimal_prag (SourceText s))),+     ("overlaps", fstrtoken (\s -> IToverlaps_prag (SourceText s))),+     ("overlappable", fstrtoken (\s -> IToverlappable_prag (SourceText s))),+     ("overlapping", fstrtoken (\s -> IToverlapping_prag (SourceText s))),+     ("incoherent", fstrtoken (\s -> ITincoherent_prag (SourceText s))),+     ("ctype", fstrtoken (\s -> ITctype (SourceText s))),+     ("complete", fstrtoken (\s -> ITcomplete_prag (SourceText s))),+     ("column", columnPrag)+     ]++twoWordPrags = Map.fromList [+     ("inline conlike",+         fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),+     ("notinline conlike",+         fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),+     ("specialize inline",+         fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))),+     ("specialize notinline",+         fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False)))+     ]++dispatch_pragmas :: Map String Action -> Action+dispatch_pragmas prags span buf len buf2 =+  case Map.lookup (clean_pragma (lexemeToString buf len)) prags of+    Just found -> found span buf len buf2+    Nothing -> lexError LexUnknownPragma++known_pragma :: Map String Action -> AlexAccPred ExtsBitmap+known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)+ = isKnown && nextCharIsNot curbuf pragmaNameChar+    where l = lexemeToString startbuf (byteDiff startbuf curbuf)+          isKnown = isJust $ Map.lookup (clean_pragma l) prags+          pragmaNameChar c = isAlphaNum c || c == '_'++clean_pragma :: String -> String+clean_pragma prag = canon_ws (map toLower (unprefix prag))+                    where unprefix prag' = case stripPrefix "{-#" prag' of+                                             Just rest -> rest+                                             Nothing -> prag'+                          canonical prag' = case prag' of+                                              "noinline" -> "notinline"+                                              "specialise" -> "specialize"+                                              "constructorlike" -> "conlike"+                                              _ -> prag'+                          canon_ws s = unwords (map canonical (words s))++warn_unknown_prag :: Map String Action -> Action+warn_unknown_prag prags span buf len buf2 = do+  let uppercase    = map toUpper+      unknown_prag = uppercase (clean_pragma (lexemeToString buf len))+      suggestions  = map uppercase (Map.keys prags)+  addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $+    PsWarnUnrecognisedPragma unknown_prag suggestions+  nested_comment span buf len buf2++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************+-}++-- TODO:AZ: we should have only mkParensEpToks. Delee mkParensEpAnn, mkParensLocs++-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- 'EpToken' values for the opening and closing bordering on the start+-- and end of the span+mkParensEpToks :: RealSrcSpan -> (EpToken "(", EpToken ")")+mkParensEpToks ss = (EpTok (EpaSpan (RealSrcSpan lo Strict.Nothing)),+                    EpTok (EpaSpan (RealSrcSpan lc Strict.Nothing)))+  where+    f = srcSpanFile ss+    sl = srcSpanStartLine ss+    sc = srcSpanStartCol ss+    el = srcSpanEndLine ss+    ec = srcSpanEndCol ss+    lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))+    lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)+++-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- 'EpaLocation' values for the opening and closing bordering on the start+-- and end of the span+mkParensLocs :: RealSrcSpan -> (EpaLocation, EpaLocation)+mkParensLocs ss = (EpaSpan (RealSrcSpan lo Strict.Nothing),+                    EpaSpan (RealSrcSpan lc Strict.Nothing))+  where+    f = srcSpanFile ss+    sl = srcSpanStartLine ss+    sc = srcSpanStartCol ss+    el = srcSpanEndLine ss+    ec = srcSpanEndCol ss+    lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))+    lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)++queueComment :: RealLocated Token -> P()+queueComment c = P $ \s -> POk s {+  comment_q = commentToAnnotation c : comment_q s+  } ()++allocateComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> ([LEpaComment], [LEpaComment])+allocateComments ss comment_q =+  let+    (before,rest)  = break (\(L l _) -> isRealSubspanOf (epaLocationRealSrcSpan l) ss) comment_q+    (middle,after) = break (\(L l _) -> not (isRealSubspanOf (epaLocationRealSrcSpan l) ss)) rest+    comment_q' = before ++ after+    newAnns = middle+  in+    (comment_q', reverse newAnns)++-- Comments appearing without a line-break before the first+-- declaration are associated with the declaration+splitPriorComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> ([LEpaComment], [LEpaComment])+splitPriorComments ss prior_comments =+  let+    -- True if there is only one line between the earlier and later span,+    -- And the token preceding the comment is on a different line+    cmp :: RealSrcSpan -> LEpaComment -> Bool+    cmp later (L l c)+         = srcSpanStartLine later - srcSpanEndLine (epaLocationRealSrcSpan l) == 1+          && srcSpanEndLine (ac_prior_tok c) /= srcSpanStartLine (epaLocationRealSrcSpan l)++    go :: [LEpaComment] -> RealSrcSpan -> [LEpaComment]+       -> ([LEpaComment], [LEpaComment])+    go decl_comments _ [] = ([],decl_comments)+    go decl_comments r (c@(L l _):cs) = if cmp r c+                              then go (c:decl_comments) (epaLocationRealSrcSpan l) cs+                              else (reverse (c:cs), decl_comments)+  in+    go [] ss prior_comments++allocatePriorComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> Strict.Maybe [LEpaComment]+  -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])+allocatePriorComments ss comment_q mheader_comments =+  let+    cmp (L l _) = epaLocationRealSrcSpan l <= ss+    (newAnns,after) = partition cmp comment_q+    comment_q'= after+    (prior_comments, decl_comments) = splitPriorComments ss newAnns   in     case mheader_comments of       Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments)
+ compiler/GHC/Parser/Lexer/Interface.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE MagicHash #-}++{- |+This module defines the types and functions necessary for an Alex-generated+lexer.++https://haskell-alex.readthedocs.io/en/latest/api.html#+-}+module GHC.Parser.Lexer.Interface (+  AlexInput (..),+  alexGetByte,+  alexInputPrevChar,++  -- * Helpers+  alexGetChar,+  adjustChar,+) where++import GHC.Prelude++import Data.Char (GeneralCategory (..), generalCategory, ord)+import Data.Word (Word8)+import GHC.Data.StringBuffer (StringBuffer, atEnd, nextChar, prevChar)+import GHC.Exts+import GHC.Types.SrcLoc (PsLoc, advancePsLoc)++data AlexInput = AI !PsLoc !StringBuffer deriving (Show)++-- See Note [Unicode in Alex]+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (AI loc s)+  | atEnd s   = Nothing+  | otherwise = byte `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (byte, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advancePsLoc loc c+        byte   = adjustChar c++-- Getting the previous 'Char' isn't enough here - we need to convert it into+-- the same format that 'alexGetByte' would have produced.+--+-- See Note [Unicode in Alex] and #13986.+alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc))+  where pc = prevChar buf '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = unsafeChr $ fromIntegral b++unsafeChr :: Int -> Char+unsafeChr (I# c) = GHC.Exts.C# (GHC.Exts.chr# c)++{-+Note [Unicode in Alex]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Although newer versions of Alex support unicode, this grammar is processed with+the old style '--latin1' behaviour. This means that when implementing the+functions++    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)+    alexInputPrevChar :: AlexInput -> Char++which Alex uses to take apart our 'AlexInput', we must++  * return a latin1 character in the 'Word8' that 'alexGetByte' expects+  * return a latin1 character in 'alexInputPrevChar'.++We handle this in 'adjustChar' by squishing entire classes of unicode+characters into single bytes.+-}++{-# INLINE adjustChar #-}+adjustChar :: Char -> Word8+adjustChar c = adj_c+  where non_graphic     = 0x00+        upper           = 0x01+        lower           = 0x02+        digit           = 0x03+        symbol          = 0x04+        space           = 0x05+        other_graphic   = 0x06+        uniidchar       = 0x07++        adj_c+          | c <= '\x07' = non_graphic+          | c <= '\x7f' = fromIntegral (ord c)+          -- Alex doesn't handle Unicode, so when Unicode+          -- character is encountered we output these values+          -- with the actual character value hidden in the state.+          | otherwise =+                -- NB: The logic behind these definitions is also reflected+                -- in "GHC.Utils.Lexeme"+                -- Any changes here should likely be reflected there.++                case generalCategory c of+                  UppercaseLetter       -> upper+                  LowercaseLetter       -> lower+                  TitlecaseLetter       -> upper+                  ModifierLetter        -> uniidchar -- see #10196+                  OtherLetter           -> lower -- see #1103+                  NonSpacingMark        -> uniidchar -- see #7650+                  SpacingCombiningMark  -> other_graphic+                  EnclosingMark         -> other_graphic+                  DecimalNumber         -> digit+                  LetterNumber          -> digit+                  OtherNumber           -> digit -- see #4373+                  ConnectorPunctuation  -> symbol+                  DashPunctuation       -> symbol+                  OpenPunctuation       -> other_graphic+                  ClosePunctuation      -> other_graphic+                  InitialQuote          -> other_graphic+                  FinalQuote            -> other_graphic+                  OtherPunctuation      -> symbol+                  MathSymbol            -> symbol+                  CurrencySymbol        -> symbol+                  ModifierSymbol        -> symbol+                  OtherSymbol           -> symbol+                  Space                 -> space+                  _other                -> non_graphic
+ compiler/GHC/Parser/Lexer/String.x view
@@ -0,0 +1,96 @@+{+{- |+This module defines lex states for strings.++This needs to be separate from the normal lexer because the normal lexer+automatically includes rules like skipping whitespace or lexing comments,+which we don't want in these contexts.+-}+module GHC.Parser.Lexer.String (+  AlexReturn (..),+  alexScan,+  string_multi_content,+) where++import GHC.Prelude++import GHC.Parser.Lexer.Interface+import GHC.Utils.Panic (panic)+}++-- -----------------------------------------------------------------------------+-- Alex "Character set macros"+-- Copied from GHC/Parser/Lexer.x++$unispace    = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$nl          = [\n\r\f]+$space       = [\ $unispace]+$whitechar   = [$nl \t \v $space]+$tab         = \t++$ascdigit  = 0-9+$unidigit  = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$decdigit  = $ascdigit -- exactly $ascdigit, no more no less.+$digit     = [$ascdigit $unidigit]++$special   = [\(\)\,\;\[\]\`\{\}]+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]+$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']++$unilarge  = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$asclarge  = [A-Z]+$large     = [$asclarge $unilarge]++$unismall  = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$ascsmall  = [a-z]+$small     = [$ascsmall $unismall \_]++$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$idchar    = [$small $large $digit $uniidchar \']++$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].+$graphic   = [$small $large $symbol $digit $idchar $special $unigraphic \"\']+$charesc   = [a b f n r t v \\ \" \' \&]++$octit     = 0-7+$hexit     = [$decdigit A-F a-f]++-- -----------------------------------------------------------------------------+-- Alex "Regular expression macros"+-- Copied from GHC/Parser/Lexer.x++@numspc       = _*                   -- numeric spacer (#14473)+@decimal      = $decdigit(@numspc $decdigit)*+@octal        = $octit(@numspc $octit)*+@hexadecimal  = $hexit(@numspc $hexit)*+@gap = \\ $whitechar+ \\+@cntrl = $asclarge | \@ | \[ | \\ | \] | \^ | \_+@ascii = \^ @cntrl | "NUL" | "SOH" | "STX" | "ETX" | "EOT" | "ENQ" | "ACK"+       | "BEL" | "BS" | "HT" | "LF" | "VT" | "FF" | "CR" | "SO" | "SI" | "DLE"+       | "DC1" | "DC2" | "DC3" | "DC4" | "NAK" | "SYN" | "ETB" | "CAN"+       | "EM" | "SUB" | "ESC" | "FS" | "GS" | "RS" | "US" | "SP" | "DEL"+@escape     = \\ ( $charesc      | @ascii | @decimal | o @octal | x @hexadecimal )+@stringchar = ($graphic # [\\ \"]) | $space | @escape     | @gap++:-++-- Define an empty rule so it compiles; callers should always explicitly specify a startcode+<0> () ;++-- See Note [Lexing multiline strings]+<string_multi_content> {+  -- Parse as much of the multiline string as possible, except for quotes+  @stringchar* ($nl ([\  $tab] | @gap)* @stringchar*)* { string_multi_content_action }+  -- Allow bare quotes if it's not a triple quote+  (\" | \"\") / ([\n .] # \") { string_multi_content_action }+}++-- -----------------------------------------------------------------------------+-- Haskell actions+{+-- | Dummy action that should never be called. Should only be used in lex states+-- that are manually lexed in tok_string_multi.+string_multi_content_action :: a+string_multi_content_action = panic "string_multi_content_action unexpectedly invoked"+}
compiler/GHC/Parser/PostProcess.hs view
@@ -1,3176 +1,3787 @@ -{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DataKinds #-}-------  (c) The University of Glasgow 2002-2006------- Functions over HsSyn specialised to RdrName.--module GHC.Parser.PostProcess (-        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot-        mkHsOpApp,-        mkHsIntegral, mkHsFractional, mkHsIsString,-        mkHsDo, mkSpliceDecl,-        mkRoleAnnotDecl,-        mkClassDecl,-        mkTyData, mkDataFamInst,-        mkTySynonym, mkTyFamInstEqn,-        mkStandaloneKindSig,-        mkTyFamInst,-        mkFamDecl,-        mkInlinePragma,-        mkOpaquePragma,-        mkPatSynMatchGroup,-        mkRecConstrOrUpdate,-        mkTyClD, mkInstD,-        mkRdrRecordCon, mkRdrRecordUpd,-        setRdrNameSpace,-        fromSpecTyVarBndr, fromSpecTyVarBndrs,-        annBinds,-        fixValbindsAnn,-        stmtsAnchor, stmtsLoc,--        cvBindGroup,-        cvBindsAndSigs,-        cvTopDecls,-        placeHolderPunRhs,--        -- Stuff to do with Foreign declarations-        mkImport,-        parseCImport,-        mkExport,-        mkExtName,    -- RdrName -> CLabelString-        mkGadtDecl,   -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName-        mkConDeclH98,--        -- Bunch of functions in the parser monad for-        -- checking and constructing values-        checkImportDecl,-        checkExpBlockArguments, checkCmdBlockArguments,-        checkPrecP,           -- Int -> P Int-        checkContext,         -- HsType -> P HsContext-        checkPattern,         -- HsExp -> P HsPat-        checkPattern_details,-        incompleteDoBlock,-        ParseContext(..),-        checkMonadComp,       -- P (HsStmtContext GhcPs)-        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl-        checkValSigLhs,-        LRuleTyTmVar, RuleTyTmVar(..),-        mkRuleBndrs, mkRuleTyVarBndrs,-        checkRuleTyVarBndrNames,-        checkRecordSyntax,-        checkEmptyGADTs,-        addFatalError, hintBangPat,-        mkBangTy,-        UnpackednessPragma(..),-        mkMultTy,--        -- Token location-        mkTokenLocation,--        -- Help with processing exports-        ImpExpSubSpec(..),-        ImpExpQcSpec(..),-        mkModuleImpExp,-        mkTypeImpExp,-        mkImpExpSubSpec,-        checkImportSpec,--        -- Token symbols-        starSym,--        -- Warnings and errors-        warnStarIsType,-        warnPrepositiveQualifiedModule,-        failOpFewArgs,-        failNotEnabledImportQualifiedPost,-        failImportQualifiedTwice,--        SumOrTuple (..),--        -- Expression/command/pattern ambiguity resolution-        PV,-        runPV,-        ECP(ECP, unECP),-        DisambInfixOp(..),-        DisambECP(..),-        ecpFromExp,-        ecpFromCmd,-        PatBuilder,--        -- Type/datacon ambiguity resolution-        DisambTD(..),-        addUnpackednessP,-        dataConBuilderCon,-        dataConBuilderDetails,-    ) where--import GHC.Prelude-import GHC.Hs           -- Lots of it-import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )-import GHC.Core.DataCon        ( DataCon, dataConTyCon )-import GHC.Core.ConLike        ( ConLike(..) )-import GHC.Core.Coercion.Axiom ( Role, fsFromRole )-import GHC.Types.Name.Reader-import GHC.Types.Name-import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Fixity-import GHC.Types.Hint-import GHC.Types.SourceText-import GHC.Parser.Types-import GHC.Parser.Lexer-import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr ()-import GHC.Utils.Lexeme ( okConOcc )-import GHC.Types.TyThing-import GHC.Core.Type    ( Specificity(..) )-import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,-                          nilDataConName, nilDataConKey,-                          listTyConName, listTyConKey,-                          unrestrictedFunTyCon )-import GHC.Types.ForeignCall-import GHC.Types.SrcLoc-import GHC.Types.Unique ( hasKey )-import GHC.Data.OrdList-import GHC.Utils.Outputable as Outputable-import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Utils.Error-import GHC.Utils.Misc-import Data.Either-import Data.List        ( findIndex )-import Data.Foldable-import qualified Data.Semigroup as Semi-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import qualified GHC.Data.Strict as Strict--import Language.Haskell.Syntax.Basic (FieldLabelString(..))--import Control.Monad-import Text.ParserCombinators.ReadP as ReadP-import Data.Char-import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )-import Data.Kind       ( Type )-import Data.List.NonEmpty (NonEmpty)--{- **********************************************************************--  Construction functions for Rdr stuff--  ********************************************************************* -}---- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and--- datacon by deriving them from the name of the class.  We fill in the names--- for the tycon and datacon corresponding to the class, by deriving them--- from the name of the class itself.  This saves recording the names in the--- interface file (which would be equally good).---- Similarly for mkConDecl, mkClassOpSig and default-method names.----         *** See Note [The Naming story] in GHC.Hs.Decls ****--mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)-mkTyClD (L loc d) = L loc (TyClD noExtField d)--mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)-mkInstD (L loc d) = L loc (InstD noExtField d)--mkClassDecl :: SrcSpan-            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)-            -> Located (a,[LHsFunDep GhcPs])-            -> OrdList (LHsDecl GhcPs)-            -> LayoutInfo GhcPs-            -> [AddEpAnn]-            -> P (LTyClDecl GhcPs)--mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn-  = do { let loc = noAnnSrcSpan loc'-       ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls-       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr-       ; tyvars <- checkTyVars (text "class") whereDots cls tparams-       ; cs <- getCommentsFor (locA loc) -- Get any remaining comments-       ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs-       ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey)-                                  , tcdLayout = layoutInfo-                                  , tcdCtxt = mcxt-                                  , tcdLName = cls, tcdTyVars = tyvars-                                  , tcdFixity = fixity-                                  , tcdFDs = snd (unLoc fds)-                                  , tcdSigs = mkClassOpSigs sigs-                                  , tcdMeths = binds-                                  , tcdATs = ats, tcdATDefs = at_defs-                                  , tcdDocs  = docs })) }--mkTyData :: SrcSpan-         -> Bool-         -> NewOrData-         -> Maybe (LocatedP CType)-         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)-         -> Maybe (LHsKind GhcPs)-         -> [LConDecl GhcPs]-         -> Located (HsDeriving GhcPs)-         -> [AddEpAnn]-         -> P (LTyClDecl GhcPs)-mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))-         ksig data_cons (L _ maybe_deriv) annsIn-  = do { let loc = noAnnSrcSpan loc'-       ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr-       ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams-       ; cs <- getCommentsFor (locA loc) -- Get any remaining comments-       ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs-       ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons-       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv-       ; return (L loc (DataDecl { tcdDExt = anns',-                                   tcdLName = tc, tcdTyVars = tyvars,-                                   tcdFixity = fixity,-                                   tcdDataDefn = defn })) }--mkDataDefn :: Maybe (LocatedP CType)-           -> Maybe (LHsContext GhcPs)-           -> Maybe (LHsKind GhcPs)-           -> DataDefnCons (LConDecl GhcPs)-           -> HsDeriving GhcPs-           -> P (HsDataDefn GhcPs)-mkDataDefn cType mcxt ksig data_cons maybe_deriv-  = do { checkDatatypeContext mcxt-       ; return (HsDataDefn { dd_ext = noExtField-                            , dd_cType = cType-                            , dd_ctxt = mcxt-                            , dd_cons = data_cons-                            , dd_kindSig = ksig-                            , dd_derivs = maybe_deriv }) }--mkTySynonym :: SrcSpan-            -> LHsType GhcPs  -- LHS-            -> LHsType GhcPs  -- RHS-            -> [AddEpAnn]-            -> P (LTyClDecl GhcPs)-mkTySynonym loc lhs rhs annsIn-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; tyvars <- checkTyVars (text "type") equalsDots tc tparams-       ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)-       ; return (L (noAnnSrcSpan loc) (SynDecl-                                { tcdSExt = anns'-                                , tcdLName = tc, tcdTyVars = tyvars-                                , tcdFixity = fixity-                                , tcdRhs = rhs })) }--mkStandaloneKindSig-  :: SrcSpan-  -> Located [LocatedN RdrName]   -- LHS-  -> LHsSigType GhcPs             -- RHS-  -> [AddEpAnn]-  -> P (LStandaloneKindSig GhcPs)-mkStandaloneKindSig loc lhs rhs anns =-  do { vs <- mapM check_lhs_name (unLoc lhs)-     ; v <- check_singular_lhs (reverse vs)-     ; cs <- getCommentsFor loc-     ; return $ L (noAnnSrcSpan loc)-       $ StandaloneKindSig (EpAnn (spanAsAnchor loc) anns cs) v rhs }-  where-    check_lhs_name v@(unLoc->name) =-      if isUnqual name && isTcOcc (rdrNameOcc name)-      then return v-      else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $-             (PsErrUnexpectedQualifiedConstructor (unLoc v))-    check_singular_lhs vs =-      case vs of-        [] -> panic "mkStandaloneKindSig: empty left-hand side"-        [v] -> return v-        _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $-               (PsErrMultipleNamesInStandaloneKindSignature vs)--mkTyFamInstEqn :: SrcSpan-               -> HsOuterFamEqnTyVarBndrs GhcPs-               -> LHsType GhcPs-               -> LHsType GhcPs-               -> [AddEpAnn]-               -> P (LTyFamInstEqn GhcPs)-mkTyFamInstEqn loc bndrs lhs rhs anns-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; cs <- getCommentsFor loc-       ; return (L (noAnnSrcSpan loc) $ FamEqn-                        { feqn_ext    = EpAnn (spanAsAnchor loc) (anns `mappend` ann) cs-                        , feqn_tycon  = tc-                        , feqn_bndrs  = bndrs-                        , feqn_pats   = tparams-                        , feqn_fixity = fixity-                        , feqn_rhs    = rhs })}--mkDataFamInst :: SrcSpan-              -> NewOrData-              -> Maybe (LocatedP CType)-              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs-                        , LHsType GhcPs)-              -> Maybe (LHsKind GhcPs)-              -> [LConDecl GhcPs]-              -> Located (HsDeriving GhcPs)-              -> [AddEpAnn]-              -> P (LInstDecl GhcPs)-mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)-              ksig data_cons (L _ maybe_deriv) anns-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr-       ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan-       ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments-       ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons-       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv-       ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl-                  (FamEqn { feqn_ext    = fam_eqn_ans-                          , feqn_tycon  = tc-                          , feqn_bndrs  = bndrs-                          , feqn_pats   = tparams-                          , feqn_fixity = fixity-                          , feqn_rhs    = defn })))) }---- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)---               ksig data_cons (L _ maybe_deriv) anns---   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr---        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan---        ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments---        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv---        ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl---                   (FamEqn { feqn_ext    = anns'---                           , feqn_tycon  = tc---                           , feqn_bndrs  = bndrs---                           , feqn_pats   = tparams---                           , feqn_fixity = fixity---                           , feqn_rhs    = defn })))) }----mkTyFamInst :: SrcSpan-            -> TyFamInstEqn GhcPs-            -> [AddEpAnn]-            -> P (LInstDecl GhcPs)-mkTyFamInst loc eqn anns = do-  cs <- getCommentsFor loc-  return (L (noAnnSrcSpan loc) (TyFamInstD noExtField-              (TyFamInstDecl (EpAnn (spanAsAnchor loc) anns cs) eqn)))--mkFamDecl :: SrcSpan-          -> FamilyInfo GhcPs-          -> TopLevelFlag-          -> LHsType GhcPs                   -- LHS-          -> LFamilyResultSig GhcPs          -- Optional result signature-          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation-          -> [AddEpAnn]-          -> P (LTyClDecl GhcPs)-mkFamDecl loc info topLevel lhs ksig injAnn annsIn-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams-       ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)-       ; return (L (noAnnSrcSpan loc) (FamDecl noExtField-                                         (FamilyDecl-                                           { fdExt       = anns'-                                           , fdTopLevel  = topLevel-                                           , fdInfo      = info, fdLName = tc-                                           , fdTyVars    = tyvars-                                           , fdFixity    = fixity-                                           , fdResultSig = ksig-                                           , fdInjectivityAnn = injAnn }))) }-  where-    equals_or_where = case info of-                        DataFamily          -> empty-                        OpenTypeFamily      -> empty-                        ClosedTypeFamily {} -> whereDots--mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)--- If the user wrote---      [pads| ... ]   then return a QuasiQuoteD---      $(e)           then return a SpliceD--- but if they wrote, say,---      f x            then behave as if they'd written $(f x)---                     ie a SpliceD------ Typed splices are not allowed at the top level, thus we do not represent them--- as spliced declaration.  See #10945-mkSpliceDecl lexpr@(L loc expr)-  | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do-    cs <- getCommentsFor (locA loc)-    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)--  | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do-    cs <- getCommentsFor (locA loc)-    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)--  | otherwise = do-    cs <- getCommentsFor (locA loc)-    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField-                                 (L loc (HsUntypedSpliceExpr noAnn lexpr))-                                       BareSplice)--mkRoleAnnotDecl :: SrcSpan-                -> LocatedN RdrName                -- type being annotated-                -> [Located (Maybe FastString)]    -- roles-                -> [AddEpAnn]-                -> P (LRoleAnnotDecl GhcPs)-mkRoleAnnotDecl loc tycon roles anns-  = do { roles' <- mapM parse_role roles-       ; cs <- getCommentsFor loc-       ; return $ L (noAnnSrcSpan loc)-         $ RoleAnnotDecl (EpAnn (spanAsAnchor loc) anns cs) tycon roles' }-  where-    role_data_type = dataTypeOf (undefined :: Role)-    all_roles = map fromConstr $ dataTypeConstrs role_data_type-    possible_roles = [(fsFromRole role, role) | role <- all_roles]--    parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing-    parse_role (L loc_role (Just role))-      = case lookup role possible_roles of-          Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role-          Nothing         ->-            let nearby = fuzzyLookup (unpackFS role)-                  (mapFst unpackFS possible_roles)-            in-            addFatalError $ mkPlainErrorMsgEnvelope loc_role $-              (PsErrIllegalRoleName role nearby)---- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to--- binders without annotations. Only accepts specified variables, and errors if--- any of the provided binders has an 'InferredSpec' annotation.-fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]-fromSpecTyVarBndrs = mapM fromSpecTyVarBndr---- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without--- annotations. Only accepts specified variables, and errors if the provided--- binder has an 'InferredSpec' annotation.-fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)-fromSpecTyVarBndr bndr = case bndr of-  (L loc (UserTyVar xtv flag idp))     -> (check_spec flag loc)-                                          >> return (L loc $ UserTyVar xtv () idp)-  (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)-                                          >> return (L loc $ KindedTyVar xtv () idp k)-  where-    check_spec :: Specificity -> SrcSpanAnnA -> P ()-    check_spec SpecifiedSpec _   = return ()-    check_spec InferredSpec  loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-                                     PsErrInferredTypeVarNotAllowed---- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@-annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs-  -> (HsLocalBinds GhcPs, Maybe EpAnnComments)-annBinds a cs (HsValBinds an bs)  = (HsValBinds (add_where a an cs) bs, Nothing)-annBinds a cs (HsIPBinds an bs)   = (HsIPBinds (add_where a an cs) bs, Nothing)-annBinds _ cs  (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)--add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList-add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2-  | valid_anchor (anchor a)-  = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)-  | otherwise-  = EpAnn (patch_anchor rs a)-          (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)-add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs-  = EpAnn (Anchor rs UnchangedAnchor)-           (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs-add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"- -- EpaDelta should only be used for transformations--valid_anchor :: RealSrcSpan -> Bool-valid_anchor r = srcSpanStartLine r >= 0---- If the decl list for where binds is empty, the anchor ends up--- invalid. In this case, use the parent one-patch_anchor :: RealSrcSpan -> Anchor -> Anchor-patch_anchor r1 (Anchor r0 op) = Anchor r op-  where-    r = if srcSpanStartLine r0 < 0 then r1 else r0--fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList-fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed-fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)-  = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)---- | The 'Anchor' for a stmtlist is based on either the location or--- the first semicolon annotion.-stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor-stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _))-  = widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r-stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor--stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan-stmtsLoc (L l ((ConsOL aa _), _))-  = widenSpan l [aa]-stmtsLoc (L l _) = l--{- **********************************************************************--  #cvBinds-etc# Converting to @HsBinds@, etc.--  ********************************************************************* -}---- | Function definitions are restructured here. Each is assumed to be recursive--- initially, and non recursive definitions are discovered by the dependency--- analyser.-----  | Groups together bindings for a single function-cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]-cvTopDecls decls = getMonoBindAll (fromOL decls)---- Declaration list may only contain value bindings and signatures.-cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)-cvBindGroup binding-  = do { (mbs, sigs, fam_ds, tfam_insts-         , dfam_insts, _) <- cvBindsAndSigs binding-       ; massert (null fam_ds && null tfam_insts && null dfam_insts)-       ; return $ ValBinds NoAnnSortKey mbs sigs }--cvBindsAndSigs :: OrdList (LHsDecl GhcPs)-  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]-          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])--- Input decls contain just value bindings and signatures--- and in case of class or instance declarations also--- associated type declarations. They might also contain Haddock comments.-cvBindsAndSigs fb = do-  fb' <- drop_bad_decls (fromOL fb)-  return (partitionBindsAndSigs (getMonoBindAll fb'))-  where-    -- cvBindsAndSigs is called in several places in the parser,-    -- and its items can be produced by various productions:-    ---    --    * decl       (when parsing a where clause or a let-expression)-    --    * decl_inst  (when parsing an instance declaration)-    --    * decl_cls   (when parsing a class declaration)-    ---    -- partitionBindsAndSigs can handle almost all declaration forms produced-    -- by the aforementioned productions, except for SpliceD, which we filter-    -- out here (in drop_bad_decls).-    ---    -- We're not concerned with every declaration form possible, such as those-    -- produced by the topdecl parser production, because cvBindsAndSigs is not-    -- called on top-level declarations.-    drop_bad_decls [] = return []-    drop_bad_decls (L l (SpliceD _ d) : ds) = do-      addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d-      drop_bad_decls ds-    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds---------------------------------------------------------------------------------- Group function bindings into equation groups--getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]-  -> (LHsBind GhcPs, [LHsDecl GhcPs])--- Suppose      (b',ds') = getMonoBind b ds---      ds is a list of parsed bindings---      b is a MonoBinds that has just been read off the front---- Then b' is the result of grouping more equations from ds that--- belong with b into a single MonoBinds, and ds' is the depleted--- list of parsed bindings.------ All Haddock comments between equations inside the group are--- discarded.------ No AndMonoBinds or EmptyMonoBinds here; just single equations--getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)-                             , fun_matches =-                               MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))-            binds-  | has_args m1-  = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []-  where-    go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA-       -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]-       -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ-    go mtchs loc-       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)-                                 , fun_matches =-                                    MG { mg_alts = (L _ [L lm2 mtchs2]) } })))-         : binds) _-        | f1 == f2 =-          let (loc2', lm2') = transferAnnsA loc2 lm2-          in go (L lm2' mtchs2 : mtchs)-                        (combineSrcSpansA loc loc2') binds []-    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls-        = let doc_decls' = doc_decl : doc_decls-          in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'-    go mtchs loc binds doc_decls-        = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs))-          , (reverse doc_decls) ++ binds)-        -- Reverse the final matches, to get it back in the right order-        -- Do the same thing with the trailing doc comments--getMonoBind bind binds = (bind, binds)---- Group together adjacent FunBinds for every function.-getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]-getMonoBindAll [] = []-getMonoBindAll (L l (ValD _ b) : ds) =-  let (L l' b', ds') = getMonoBind (L l b) ds-  in L l' (ValD noExtField b') : getMonoBindAll ds'-getMonoBindAll (d : ds) = d : getMonoBindAll ds--has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool-has_args []                                  = panic "GHC.Parser.PostProcess.has_args"-has_args (L _ (Match { m_pats = args }) : _) = not (null args)-        -- Don't group together FunBinds if they have-        -- no arguments.  This is necessary now that variable bindings-        -- with no arguments are now treated as FunBinds rather-        -- than pattern bindings (tests/rename/should_fail/rnfail002).--{- **********************************************************************--  #PrefixToHS-utils# Utilities for conversion--  ********************************************************************* -}--{- Note [Parsing data constructors is hard]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The problem with parsing data constructors is that they look a lot like types.-Compare:--  (s1)   data T = C t1 t2-  (s2)   type T = C t1 t2--Syntactically, there's little difference between these declarations, except in-(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.--This similarity would pose no problem if we knew ahead of time if we are-parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple-(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing-data constructors, and in other contexts (e.g. 'type' declarations) assume we-are parsing type constructors.--This simple rule does not work because of two problematic cases:--  (p1)   data T = C t1 t2 :+ t3-  (p2)   data T = C t1 t2 => t3--In (p1) we encounter (:+) and it turns out we are parsing an infix data-declaration, so (C t1 t2) is a type and 'C' is a type constructor.-In (p2) we encounter (=>) and it turns out we are parsing an existential-context, so (C t1 t2) is a constraint and 'C' is a type constructor.--As the result, in order to determine whether (C t1 t2) declares a data-constructor, a type, or a context, we would need unlimited lookahead which-'happy' is not so happy with.--}---- | Reinterpret a type constructor, including type operators, as a data---   constructor.--- See Note [Parsing data constructors is hard]-tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)-tyConToDataCon (L loc tc)-  | okConOcc (occNameString occ)-  = return (L loc (setRdrNameSpace tc srcDataName))--  | otherwise-  = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)-  where-    occ = rdrNameOcc tc--mkPatSynMatchGroup :: LocatedN RdrName-                   -> LocatedL (OrdList (LHsDecl GhcPs))-                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))-mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =-    do { matches <- mapM fromDecl (fromOL decls)-       ; when (null matches) (wrongNumberErr (locA loc))-       ; return $ mkMatchGroup FromSource (L ld matches) }-  where-    fromDecl (L loc decl@(ValD _ (PatBind _-                                 -- AZ: where should these anns come from?-                         pat@(L _ (ConPat noAnn ln@(L _ name) details))-                               rhs))) =-        do { unless (name == patsyn_name) $-               wrongNameBindingErr (locA loc) decl-           ; match <- case details of-               PrefixCon _ pats -> return $ Match { m_ext = noAnn-                                                  , m_ctxt = ctxt, m_pats = pats-                                                  , m_grhss = rhs }-                   where-                     ctxt = FunRhs { mc_fun = ln-                                   , mc_fixity = Prefix-                                   , mc_strictness = NoSrcStrict }--               InfixCon p1 p2 -> return $ Match { m_ext = noAnn-                                                , m_ctxt = ctxt-                                                , m_pats = [p1, p2]-                                                , m_grhss = rhs }-                   where-                     ctxt = FunRhs { mc_fun = ln-                                   , mc_fixity = Infix-                                   , mc_strictness = NoSrcStrict }--               RecCon{} -> recordPatSynErr (locA loc) pat-           ; return $ L loc match }-    fromDecl (L loc decl) = extraDeclErr (locA loc) decl--    extraDeclErr loc decl =-        addFatalError $ mkPlainErrorMsgEnvelope loc $-          (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)--    wrongNameBindingErr loc decl =-      addFatalError $ mkPlainErrorMsgEnvelope loc $-          (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)--    wrongNumberErr loc =-      addFatalError $ mkPlainErrorMsgEnvelope loc $-        (PsErrEmptyWhereInPatSynDecl patsyn_name)--recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a-recordPatSynErr loc pat =-    addFatalError $ mkPlainErrorMsgEnvelope loc $-      (PsErrRecordSyntaxInPatSynDecl pat)--mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]-                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs-                -> ConDecl GhcPs--mkConDeclH98 ann name mb_forall mb_cxt args-  = ConDeclH98 { con_ext    = ann-               , con_name   = name-               , con_forall = isJust mb_forall-               , con_ex_tvs = mb_forall `orElse` []-               , con_mb_cxt = mb_cxt-               , con_args   = args-               , con_doc    = Nothing }---- | Construct a GADT-style data constructor from the constructor names and--- their type. Some interesting aspects of this function:------ * This splits up the constructor type into its quantified type variables (if---   provided), context (if provided), argument types, and result type, and---   records whether this is a prefix or record GADT constructor. See---   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.-mkGadtDecl :: SrcSpan-           -> NonEmpty (LocatedN RdrName)-           -> LHsUniToken "::" "∷" GhcPs-           -> LHsSigType GhcPs-           -> P (LConDecl GhcPs)-mkGadtDecl loc names dcol ty = do-  cs <- getCommentsFor loc-  let l = noAnnSrcSpan loc--  (args, res_ty, annsa, csa) <--    case body_ty of-     L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do-       let an' = addCommentsToEpAnn (locA loc') an (comments af)-       arr <- case hsArr of-         HsUnrestrictedArrow arr -> return arr-         _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $-                                 (PsErrIllegalGadtRecordMultiplicity hsArr)-                 return noHsUniTok--       return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty-              , [], epAnnComments (ann ll))-     _ -> do-       let (anns, cs, arg_types, res_type) = splitHsFunType body_ty-       return (PrefixConGADT arg_types, res_type, anns, cs)--  let an = EpAnn (spanAsAnchor loc) annsa (cs Semi.<> csa)--  pure $ L l ConDeclGADT-                     { con_g_ext  = an-                     , con_names  = names-                     , con_dcolon = dcol-                     , con_bndrs  = L (getLoc ty) outer_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--setRdrNameSpace :: RdrName -> NameSpace -> RdrName--- ^ This rather gruesome function is used mainly by the parser.--- When parsing:------ > data T a = T | T1 Int------ we parse the data constructors as /types/ because of parser ambiguities,--- so then we need to change the /type constr/ to a /data constr/------ The exact-name case /can/ occur when parsing:------ > data [] a = [] | a : [a]------ For the exact-name case we return an original name.-setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)-setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)-setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)-setRdrNameSpace (Exact n)    ns-  | Just thing <- wiredInNameTyThing_maybe n-  = setWiredInNameSpace thing ns-    -- Preserve Exact Names for wired-in things,-    -- notably tuples and lists--  | isExternalName n-  = Orig (nameModule n) occ--  | otherwise   -- This can happen when quoting and then-                -- splicing a fixity declaration for a type-  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))-  where-    occ = setOccNameSpace ns (nameOccName n)--setWiredInNameSpace :: TyThing -> NameSpace -> RdrName-setWiredInNameSpace (ATyCon tc) ns-  | isDataConNameSpace ns-  = ty_con_data_con tc-  | isTcClsNameSpace ns-  = Exact (getName tc)      -- No-op--setWiredInNameSpace (AConLike (RealDataCon dc)) ns-  | isTcClsNameSpace ns-  = data_con_ty_con dc-  | isDataConNameSpace ns-  = Exact (getName dc)      -- No-op--setWiredInNameSpace thing ns-  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)--ty_con_data_con :: TyCon -> RdrName-ty_con_data_con tc-  | isTupleTyCon tc-  , Just dc <- tyConSingleDataCon_maybe tc-  = Exact (getName dc)--  | tc `hasKey` listTyConKey-  = Exact nilDataConName--  | otherwise  -- See Note [setRdrNameSpace for wired-in names]-  = Unqual (setOccNameSpace srcDataName (getOccName tc))--data_con_ty_con :: DataCon -> RdrName-data_con_ty_con dc-  | let tc = dataConTyCon dc-  , isTupleTyCon tc-  = Exact (getName tc)--  | dc `hasKey` nilDataConKey-  = Exact listTyConName--  | otherwise  -- See Note [setRdrNameSpace for wired-in names]-  = Unqual (setOccNameSpace tcClsName (getOccName dc))----{- Note [setRdrNameSpace for wired-in names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In GHC.Types, which declares (:), we have-  infixr 5 :-The ambiguity about which ":" is meant is resolved by parsing it as a-data constructor, but then using dataTcOccs to try the type constructor too;-and that in turn calls setRdrNameSpace to change the name-space of ":" to-tcClsName.  There isn't a corresponding ":" type constructor, but it's painful-to make setRdrNameSpace partial, so we just make an Unqual name instead. It-really doesn't matter!--}--eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a--- Adapts the Either monad to the P monad-eitherToP (Left err)    = addFatalError err-eitherToP (Right thing) = return thing--checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]-            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables--- ^ Check whether the given list of type parameters are all type variables--- (possibly with a kind signature).-checkTyVars pp_what equals_or_where tc tparms-  = do { tvs <- mapM check tparms-       ; return (mkHsQTvs tvs) }-  where-    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-                                         (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc))-    check (HsValArg ty) = chkParens [] [] emptyComments ty-    check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $-                            (PsErrMalformedDecl pp_what (unLoc tc))-        -- Keep around an action for adjusting the annotations of extra parens-    chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs-              -> P (LHsTyVarBndr () GhcPs)-    chkParens ops cps cs (L l (HsParTy an ty))-      = let-          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)-        in-          chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty-    chkParens ops cps cs ty = chk ops cps cs ty--        -- Check that the name space is correct!-    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)-    chk ops cps cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))-        | isRdrTyVar tv-            = let-                an = (reverse ops) ++ cps-              in-                return (L (widenLocatedAn (l Semi.<> annt) an)-                       (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))-    chk ops cps cs (L l (HsTyVar ann _ (L ltv tv)))-        | isRdrTyVar tv-            = let-                an = (reverse ops) ++ cps-              in-                return (L (widenLocatedAn l an)-                                     (UserTyVar (addAnns ann an cs) () (L ltv tv)))-    chk _ _ _ t@(L loc _)-        = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-            (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)---whereDots, equalsDots :: SDoc--- Second argument to checkTyVars-whereDots  = text "where ..."-equalsDots = text "= ..."--checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()-checkDatatypeContext Nothing = return ()-checkDatatypeContext (Just c)-    = do allowed <- getBit DatatypeContextsBit-         unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $-                                       (PsErrIllegalDataTypeContext c)--type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar-data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (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)---- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting-mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]-mkRuleTyVarBndrs = fmap cvt_one-  where cvt_one (L l (RuleTyTmVar ann v Nothing))-          = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))-        cvt_one (L l (RuleTyTmVar ann v (Just sig)))-          = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)-    -- takes something in namespace 'varName' to something in namespace 'tvName'-        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)-        tm_to_ty _ = panic "mkRuleTyVarBndrs"---- See Note [Parsing explicit foralls in Rules] in Parser.y-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()-checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)-  where check (L loc (Unqual occ)) =-          when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"])-            (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-               (PsErrParseErrorOnInput occ))-        check _ = panic "checkRuleTyVarBndrNames"--checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)-checkRecordSyntax lr@(L loc r)-    = do allowed <- getBit TraditionalRecordSyntaxBit-         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $-                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))-         return lr---- | Check if the gadt_constrlist is empty. Only raise parse error for--- `data T where` to avoid affecting existing error message, see #8258.-checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])-                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))-checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.-    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax-         unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $-                                          PsErrIllegalWhereInDataDecl-         return gadts-checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.--checkTyClHdr :: Bool               -- True  <=> class header-                                   -- False <=> type header-             -> LHsType GhcPs-             -> P (LocatedN RdrName,     -- the head symbol (type or class name)-                   [LHsTypeArg GhcPs],   -- parameters of head symbol-                   LexicalFixity,        -- the declaration is in infix format-                   [AddEpAnn])           -- API Annotation for HsParTy-                                         -- when stripping parens--- Well-formedness check and decomposition of type and class heads.--- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])---              Int :*: Bool   into    (:*:, [Int, Bool])--- returning the pieces-checkTyClHdr is_cls ty-  = goL ty [] [] [] Prefix-  where-    goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix--    -- workaround to define '*' despite StarIsType-    go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix-      = do { addPsMessage (locA l) PsWarnStarBinder-           ; let name = mkOccNameFS tcClsName (starSym isUni)-           ; let a' = newAnns l an-           ; return (L a' (Unqual name), acc, fix-                    , (reverse ops') ++ cps') }--    go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix-      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps)-    go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix-      | isRdrTc tc               = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)-    go l (HsParTy _ ty)    acc ops cps fix = goL ty acc (o:ops) (c:cps) fix-      where-        (o,c) = mkParensEpAnn (realSrcSpan l)-    go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix-    go _ (HsAppKindTy l ty ki) acc ops cps fix = goL ty (HsTypeArg l ki:acc) ops cps fix-    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix-      = return (L (noAnnSrcSpan l) (nameRdrName tup_name)-               , map HsValArg ts, fix, (reverse ops)++cps)-      where-        arity = length ts-        tup_name | is_cls    = cTupleTyConName arity-                 | otherwise = getName (tupleTyCon Boxed arity)-          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)-    go l _ _ _ _ _-      = addFatalError $ mkPlainErrorMsgEnvelope l $-          (PsErrMalformedTyOrClDecl ty)--    -- Combine the annotations from the HsParTy and HsStarTy into a-    -- new one for the LocatedN RdrName-    newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN-    newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =-      let-        lr = combineRealSrcSpans (realSrcSpan l) (anchor as)-        an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs)-      in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)-    newAnns _ EpAnnNotUsed = panic "missing AnnParen"-    newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =-      let-        lr = combineRealSrcSpans (anchor ap) (anchor as)-        an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))-      in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)---- | Yield a parse error if we have a function applied directly to a do block--- etc. and BlockArguments is not enabled.-checkExpBlockArguments :: LHsExpr GhcPs -> PV ()-checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()-(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)-  where-    checkExpr :: LHsExpr GhcPs -> PV ()-    checkExpr expr = case unLoc expr of-      HsDo _ (DoExpr m) _      -> check (PsErrDoInFunAppExpr m)                  expr-      HsDo _ (MDoExpr m) _     -> check (PsErrMDoInFunAppExpr m)                 expr-      HsLam {}                 -> check PsErrLambdaInFunAppExpr                  expr-      HsCase {}                -> check PsErrCaseInFunAppExpr                    expr-      HsLamCase _ lc_variant _ -> check (PsErrLambdaCaseInFunAppExpr lc_variant) expr-      HsLet {}                 -> check PsErrLetInFunAppExpr                     expr-      HsIf {}                  -> check PsErrIfInFunAppExpr                      expr-      HsProc {}                -> check PsErrProcInFunAppExpr                    expr-      _                        -> return ()--    checkCmd :: LHsCmd GhcPs -> PV ()-    checkCmd cmd = case unLoc cmd of-      HsCmdLam {}                 -> check PsErrLambdaCmdInFunAppCmd                  cmd-      HsCmdCase {}                -> check PsErrCaseCmdInFunAppCmd                    cmd-      HsCmdLamCase _ lc_variant _ -> check (PsErrLambdaCaseCmdInFunAppCmd lc_variant) cmd-      HsCmdIf {}                  -> check PsErrIfCmdInFunAppCmd                      cmd-      HsCmdLet {}                 -> check PsErrLetCmdInFunAppCmd                     cmd-      HsCmdDo {}                  -> check PsErrDoCmdInFunAppCmd                      cmd-      _                           -> return ()--    check err a = do-      blockArguments <- getBit BlockArgumentsBit-      unless blockArguments $-        addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)---- | Validate the context constraints and break up a context into a list--- of predicates.------ @---     (Eq a, Ord b)        -->  [Eq a, Ord b]---     Eq a                 -->  [Eq a]---     (Eq a)               -->  [Eq a]---     (((Eq a)))           -->  [Eq a]--- @-checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)-checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =-  check ([],[],emptyComments) orig_t- where-  check :: ([EpaLocation],[EpaLocation],EpAnnComments)-        -> LHsType GhcPs -> P (LHsContext GhcPs)-  check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))-    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can-    -- be used as context constraints.-    -- Ditto ()-    = do-        let (op,cp,cs') = case ann' of-              EpAnnNotUsed -> ([],[],emptyComments)-              EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs)-        return (L (SrcSpanAnn (EpAnn (spanAsAnchor l)-                              -- Append parens so that the original order in the source is maintained-                               (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts)--  check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))-                                  -- to be sure HsParTy doesn't get into the way-    = do-        let (op,cp,cs') = case ann' of-                    EpAnnNotUsed -> ([],[],emptyComments)-                    EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs)-        check (op++opi,cp++cpi,cs' Semi.<> csi) ty--  -- No need for anns, returning original-  check (_opi,_cpi,_csi) _t =-                 return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) emptyComments) l) [orig_t])--checkImportDecl :: Maybe EpaLocation-                -> Maybe EpaLocation-                -> P ()-checkImportDecl mPre mPost = do-  let whenJust mg f = maybe (pure ()) f mg--  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit--  -- Error if 'qualified' found in postpositive position and-  -- 'ImportQualifiedPost' is not in effect.-  whenJust mPost $ \post ->-    when (not importQualifiedPostEnabled) $-      failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)--  -- Error if 'qualified' occurs in both pre and postpositive-  -- positions.-  whenJust mPost $ \post ->-    when (isJust mPre) $-      failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)--  -- Warn if 'qualified' found in prepositive position and-  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.-  whenJust mPre $ \pre ->-    warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing)---- ---------------------------------------------------------------------------- Checking Patterns.---- We parse patterns as expressions and check for valid patterns below,--- converting the expression into a pattern at the same time.--checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)-checkPattern = runPV . checkLPat--checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)-checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)--checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)-checkLPat e@(L l _) = checkPat l e [] []--checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]-         -> PV (LPat GhcPs)-checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args-  | isRdrDataCon 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-      }-  | not (null tyargs) =-      patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs-  | (not (null args) && patIsRec c) = do-      ctx <- askParseContext-      patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =-  checkPat loc f (HsConPatTyArg at t : tyargs) args-checkPat loc (L _ (PatBuilderApp f e)) [] args = do-  p <- checkLPat e-  checkPat loc f [] (p : args)-checkPat loc (L l e) [] [] = do-  p <- checkAPat loc e-  return (L l p)-checkPat loc e _ _ = do-  details <- fromParseContext <$> askParseContext-  patFail (locA loc) (PsErrInPat (unLoc e) details)--checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)-checkAPat loc e0 = do- nPlusKPatterns <- getBit NPlusKPatternsBit- case e0 of-   PatBuilderPat p -> return p-   PatBuilderVar x -> return (VarPat noExtField x)--   -- Overloaded numeric patterns (e.g. f 0 x = x)-   -- Negation is recorded separately, so that the literal is zero or +ve-   -- NB. Negative *primitive* literals are already handled by the lexer-   PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)--   -- n+k patterns-   PatBuilderOpApp-           (L _ (PatBuilderVar (L nloc n)))-           (L l plus)-           (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))-           (EpAnn anc _ cs)-                     | nPlusKPatterns && (plus == plus_RDR)-                     -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)-                                (EpAnn anc (epaLocationFromSrcAnn l) cs))--   -- Improve error messages for the @-operator when the user meant an @-pattern-   PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do-     addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos-     return (WildPat noExtField)--   PatBuilderOpApp l (L cl c) r anns-     | isRdrDataCon c -> do-         l <- checkLPat l-         r <- checkLPat r-         return $ ConPat-           { pat_con_ext = anns-           , pat_con = L cl c-           , pat_args = InfixCon l r-           }--   PatBuilderPar lpar e rpar -> do-     p <- checkLPat e-     return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar)--   _           -> do-     details <- fromParseContext <$> askParseContext-     patFail (locA loc) (PsErrInPat e0 details)--placeHolderPunRhs :: DisambECP b => PV (LocatedA b)--- The RHS of a punned record field will be filled in by the renamer--- It's better not to make it an error, in case we want to print it when--- debugging-placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)--plus_RDR, pun_RDR :: RdrName-plus_RDR = mkUnqual varName (fsLit "+") -- Hack-pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")--checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))-              -> PV (LHsRecField GhcPs (LPat GhcPs))-checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)-                             return (L l (fld { hfbRHS = p }))--patFail :: SrcSpan -> PsMessage -> PV a-patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg--patIsRec :: RdrName -> Bool-patIsRec e = e == mkUnqual varName (fsLit "rec")-------------------------------------------------------------------------------- Check Equation Syntax--checkValDef :: SrcSpan-            -> LocatedA (PatBuilder GhcPs)-            -> Maybe (AddEpAnn, LHsType GhcPs)-            -> Located (GRHSs GhcPs (LHsExpr GhcPs))-            -> P (HsBind GhcPs)--checkValDef loc lhs (Just (sigAnn, sig)) grhss-        -- x :: ty = rhs  parses as a *pattern* binding-  = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn]-                        >>= checkLPat-       checkPatBind loc [] lhs' grhss--checkValDef loc lhs Nothing g-  = do  { mb_fun <- isFunLhs lhs-        ; case mb_fun of-            Just (fun, is_infix, pats, ann) ->-              checkFunBind NoSrcStrict loc ann-                           fun is_infix pats g-            Nothing -> do-              lhs' <- checkPattern lhs-              checkPatBind loc [] lhs' g }--checkFunBind :: SrcStrictness-             -> SrcSpan-             -> [AddEpAnn]-             -> LocatedN RdrName-             -> LexicalFixity-             -> [LocatedA (PatBuilder GhcPs)]-             -> Located (GRHSs GhcPs (LHsExpr GhcPs))-             -> P (HsBind GhcPs)-checkFunBind strictness locF ann fun is_infix pats (L _ grhss)-  = do  ps <- runPV_details extraDetails (mapM checkLPat pats)-        let match_span = noAnnSrcSpan $ locF-        cs <- getCommentsFor locF-        return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)-                 [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs-                                      , m_ctxt = FunRhs-                                          { mc_fun    = fun-                                          , mc_fixity = is_infix-                                          , mc_strictness = strictness }-                                      , m_pats = ps-                                      , m_grhss = grhss })]))-        -- The span of the match covers the entire equation.-        -- That isn't quite right, but it'll do for now.-  where-    extraDetails-      | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock-      | otherwise         = noParseContext--makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]-            -> HsBind GhcPs--- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too-makeFunBind fn ms-  = FunBind { fun_ext = noExtField,-              fun_id = fn,-              fun_matches = mkMatchGroup FromSource ms }---- See Note [FunBind vs PatBind]-checkPatBind :: SrcSpan-             -> [AddEpAnn]-             -> LPat GhcPs-             -> Located (GRHSs GhcPs (LHsExpr GhcPs))-             -> P (HsBind GhcPs)-checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))-                        (L _match_span grhss)-      = return (makeFunBind v (L (noAnnSrcSpan loc)-                [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)]))-  where-    m a v = Match { m_ext = a-                  , m_ctxt = FunRhs { mc_fun    = v-                                    , mc_fixity = Prefix-                                    , mc_strictness = SrcStrict }-                  , m_pats = []-                 , m_grhss = grhss }--checkPatBind loc annsIn lhs (L _ grhss) = do-  cs <- getCommentsFor loc-  return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss)--checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)-checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))-  | isUnqual v-  , not (isDataOcc (rdrNameOcc v))-  = return lrdr--checkValSigLhs lhs@(L l _)-  = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs--checkDoAndIfThenElse-  :: (Outputable a, Outputable b, Outputable c)-  => (a -> Bool -> b -> Bool -> c -> PsMessage)-  -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()-checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr- | semiThen || semiElse = do-      doAndIfThenElse <- getBit DoAndIfThenElseBit-      let e   = err (unLoc guardExpr)-                    semiThen (unLoc thenExpr)-                    semiElse (unLoc elseExpr)-          loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)--      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)-  | otherwise = return ()--isFunLhs :: LocatedA (PatBuilder GhcPs)-      -> P (Maybe (LocatedN RdrName, LexicalFixity,-                   [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))--- 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-   go (L _ (PatBuilderVar (L loc f))) es ops cps-       | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))-   go (L _ (PatBuilderApp f e)) es       ops cps = go f (e:es) ops cps-   go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps-                                      = let-                                          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)-                                        in-                                          go e es (o:ops) (c:cps)-   go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps-        | not (isRdrDataCon op)         -- We have found the function!-        = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps)))-        | otherwise                     -- Infix data con; keep going-        = do { mb_l <- go l es ops cps-             ; case mb_l of-                 Just (op', Infix, j : k : es', anns')-                   -> return (Just (op', Infix, j : op_app : es', anns'))-                   where-                     op_app = L loc (PatBuilderOpApp k-                               (L loc' op) r (EpAnn loca (reverse ops++cps) cs))-                 _ -> return Nothing }-   go _ _ _ _ = return Nothing--mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs-mkBangTy anns strictness =-  HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness)---- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.-data UnpackednessPragma =-  UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness---- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.-addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)-addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do-    let l' = combineSrcSpans lprag (getLocA ty)-    cs <- getCommentsFor l'-    let an = EpAnn (spanAsAnchor l') anns cs-        t' = addUnpackedness an ty-    return (L (noAnnSrcSpan l') t')-  where-    -- If we have a HsBangTy that only has a strictness annotation,-    -- such as ~T or !T, then add the pragma to the existing HsBangTy.-    ---    -- Otherwise, wrap the type in a new HsBangTy constructor.-    addUnpackedness an (L _ (HsBangTy x bang t))-      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang-      = HsBangTy (addAnns an (epAnnAnns x) (epAnnComments x)) (HsSrcBang prag unpk strictness) t-    addUnpackedness an t-      = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t-------------------------------------------------------------------------------- | Check for monad comprehensions------ If the flag MonadComprehensions is set, return a 'MonadComp' context,--- otherwise use the usual 'ListComp' context--checkMonadComp :: PV HsDoFlavour-checkMonadComp = do-    monadComprehensions <- getBit MonadComprehensionsBit-    return $ if monadComprehensions-                then MonadComp-                else ListComp---- ---------------------------------------------------------------------------- Expression/command/pattern ambiguity.--- See Note [Ambiguous syntactic categories]------- See Note [Ambiguous syntactic categories]------ This newtype is required to avoid impredicative types in monadic--- productions. That is, in a production that looks like------    | ... {% return (ECP ...) }------ we are dealing with---    P ECP--- whereas without a newtype we would be dealing with---    P (forall b. DisambECP b => PV (Located b))----newtype ECP =-  ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) }--ecpFromExp :: LHsExpr GhcPs -> ECP-ecpFromExp a = ECP (ecpFromExp' a)--ecpFromCmd :: LHsCmd GhcPs -> ECP-ecpFromCmd a = ECP (ecpFromCmd' a)---- The 'fbinds' parser rule produces values of this type. See Note--- [RecordDotSyntax field updates].-type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))---- | Disambiguate infix operators.--- See Note [Ambiguous syntactic categories]-class DisambInfixOp b where-  mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)-  mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)-  mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located 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 l ann = do-    cs <- getCommentsFor l-    return $ L l (hsHoleExpr (ann cs))--instance DisambInfixOp RdrName where-  mkHsConOpPV (L l v) = return $ L l v-  mkHsVarOpPV (L l v) = return $ L l v-  mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole--type AnnoBody b-  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn NoEpAnns-    , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL-    , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA-    , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA-    , Anno [LocatedA (StmtLR GhcPs GhcPs-                       (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL-    )---- | Disambiguate constructs that may appear when we do not know ahead of time whether we are--- parsing an expression, a command, or a pattern.--- See Note [Ambiguous syntactic categories]-class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where-  -- | See Note [Body in DisambECP]-  type Body b :: Type -> Type-  -- | Return a command without ambiguity, or fail in a non-command context.-  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)-  -- | Return an expression without ambiguity, or fail in a non-expression context.-  ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)-  mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]-    -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))-  -- | Disambiguate "\... -> ..." (lambda)-  mkHsLamPV-    :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)-  -- | Disambiguate "let ... in ..."-  mkHsLetPV-    :: SrcSpan-    -> LHsToken "let" GhcPs-    -> HsLocalBinds GhcPs-    -> LHsToken "in" GhcPs-    -> LocatedA b-    -> PV (LocatedA b)-  -- | Infix operator representation-  type InfixOp b-  -- | Bring superclass constraints on InfixOp into scope.-  -- See Note [UndecidableSuperClasses for associated types]-  superInfixOp-    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)-  -- | Disambiguate "f # x" (infix operator)-  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b-              -> PV (LocatedA b)-  -- | Disambiguate "case ... of ..."-  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])-             -> EpAnnHsCase -> PV (LocatedA b)-  -- | Disambiguate "\case" and "\cases"-  mkHsLamCasePV :: SrcSpan -> LamCaseVariant-                -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]-                -> PV (LocatedA b)-  -- | Function argument representation-  type FunArg b-  -- | Bring superclass constraints on FunArg into scope.-  -- See Note [UndecidableSuperClasses for associated types]-  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)-  -- | Disambiguate "f x" (function application)-  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)-  -- | Disambiguate "f @t" (visible type application)-  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate "if ... then ... else ..."-  mkHsIfPV :: SrcSpan-         -> LHsExpr GhcPs-         -> Bool  -- semicolon?-         -> LocatedA b-         -> Bool  -- semicolon?-         -> LocatedA b-         -> AnnsIf-         -> PV (LocatedA b)-  -- | Disambiguate "do { ... }" (do notation)-  mkHsDoPV ::-    SrcSpan ->-    Maybe ModuleName ->-    LocatedL [LStmt GhcPs (LocatedA b)] ->-    AnnList ->-    PV (LocatedA b)-  -- | Disambiguate "( ... )" (parentheses)-  mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b)-  -- | Disambiguate a variable "f" or a data constructor "MkF".-  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)-  -- | Disambiguate a monomorphic literal-  mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)-  -- | Disambiguate an overloaded literal-  mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)-  -- | Disambiguate a wildcard-  mkHsWildCardPV :: SrcSpan -> PV (Located b)-  -- | Disambiguate "a :: t" (type annotation)-  mkHsTySigPV-    :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "[a,b,c]" (list syntax)-  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)-  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)-  mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (Located b)-  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)-  mkHsRecordPV ::-    Bool -> -- Is OverloadedRecordUpdate in effect?-    SrcSpan ->-    SrcSpan ->-    LocatedA b ->-    ([Fbind b], Maybe SrcSpan) ->-    [AddEpAnn] ->-    PV (LocatedA b)-  -- | Disambiguate "-a" (negation)-  mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "(# a)" (right operator section)-  mkHsSectionR_PV-    :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b)-  -- | Disambiguate "(a -> b)" (view pattern)-  mkHsViewPatPV-    :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "a@b" (as-pattern)-  mkHsAsPatPV-    :: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b)-  -- | Disambiguate "~a" (lazy pattern)-  mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "!a" (bang pattern)-  mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate tuple sections and unboxed sums-  mkSumOrTuplePV-    :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas-  rejectPragmaPV :: LocatedA b -> PV ()--{- Note [UndecidableSuperClasses for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(This Note is about the code in GHC, not about the user code that we are parsing)--Assume we have a class C with an associated type T:--  class C a where-    type T a-    ...--If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:--  {-# LANGUAGE UndecidableSuperClasses #-}-  class C (T a) => C a where-    type T a-    ...--Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes-making GHC loop. The workaround is to bring this constraint into scope-manually with a helper method:--  class C a where-    type T a-    superT :: (C (T a) => r) -> r--In order to avoid ambiguous types, 'r' must mention 'a'.--For consistency, we use this approach for all constraints on associated types,-even when -XUndecidableSuperClasses are not required.--}--{- Note [Body in DisambECP]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that-require their argument to take a form of (body GhcPs) for some (body :: Type ->-*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the-superclass constraints of DisambECP.--The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop-this requirement. It is possible and would allow removing the type index of-PatBuilder, but leads to worse type inference, breaking some code in the-typechecker.--}--instance DisambECP (HsCmd GhcPs) where-  type Body (HsCmd GhcPs) = HsCmd-  ecpFromCmd' = return-  ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $-                                                 PsErrOverloadedRecordDotInvalid-  mkHsLamPV l mg = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))-  mkHsLetPV l tkLet bs tkIn e = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e)-  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs-  superInfixOp m = m-  mkHsOpAppPV l c1 op c2 = do-    let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]-  mkHsCasePV l c (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkMatchGroup FromSource (L lm m)-    return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)-  mkHsLamCasePV l lc_variant (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)-    return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)-  type FunArg (HsCmd GhcPs) = HsExpr GhcPs-  superFunArg m = m-  mkHsAppPV l c e = do-    cs <- getCommentsFor (locA l)-    checkCmdBlockArguments c-    checkExpBlockArguments e-    return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e)-  mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)-  mkHsIfPV l c semi1 a semi2 b anns = do-    checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (EpAnn (spanAsAnchor l) anns cs))-  mkHsDoPV l Nothing stmts anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)-  mkHsDoPV l (Just m)    _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m-  mkHsParPV l lpar c rpar = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar)-  mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)-  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)-  mkHsExplicitListPV l xs _ = cmdFail l $-    brackets (pprWithCommas ppr xs)-  mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)-  mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do-    let (fs, ps) = partitionEithers fbinds-    if not (null ps)-      then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid-      else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)-  mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)-  mkHsSectionR_PV l op c = cmdFail l $-    let pp_op = fromMaybe (panic "cannot print infix operator")-                          (ppr_infix_expr (unLoc op))-    in pp_op <> ppr c-  mkHsViewPatPV l a b _ = cmdFail l $-    ppr a <+> text "->" <+> ppr b-  mkHsAsPatPV l v _ c = cmdFail l $-    pprPrefixOcc (unLoc v) <> text "@" <> ppr c-  mkHsLazyPatPV l c _ = cmdFail l $-    text "~" <> ppr c-  mkHsBangPatPV l c _ = cmdFail l $-    text "!" <> ppr c-  mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)-  rejectPragmaPV _ = return ()--cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e--checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()-checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do-  when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda-checkLamMatchGroup _ _ = return ()--instance DisambECP (HsExpr GhcPs) where-  type Body (HsExpr GhcPs) = HsExpr-  ecpFromCmd' (L l c) = do-    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c-    return (L l (hsHoleExpr noAnn))-  ecpFromExp' = return-  mkHsProjUpdatePV l fields arg isPun anns = do-    cs <- getCommentsFor l-    return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)-  mkHsLamPV l mg = do-    cs <- getCommentsFor l-    let mg' = mg cs-    checkLamMatchGroup l mg'-    return $ L (noAnnSrcSpan l) (HsLam NoExtField mg')-  mkHsLetPV l tkLet bs tkIn c = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c)-  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs-  superInfixOp m = m-  mkHsOpAppPV l e1 op e2 = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2-  mkHsCasePV l e (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkMatchGroup FromSource (L lm m)-    return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)-  mkHsLamCasePV l lc_variant (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)-    return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)-  type FunArg (HsExpr GhcPs) = HsExpr GhcPs-  superFunArg m = m-  mkHsAppPV l e1 e2 = do-    cs <- getCommentsFor (locA l)-    checkExpBlockArguments e1-    checkExpBlockArguments e2-    return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2)-  mkHsAppTypePV l e at t = do-    checkExpBlockArguments e-    return $ L l (HsAppType noExtField e at (mkHsWildCardBndrs t))-  mkHsIfPV l c semi1 a semi2 b anns = do-    checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (mkHsIf c a b (EpAnn (spanAsAnchor l) anns cs))-  mkHsDoPV l mod stmts anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts)-  mkHsParPV l lpar e rpar = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)-  mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)-  mkHsLitPV (L l a) = do-    cs <- getCommentsFor l-    return $ L l (HsLit (comment (realSrcSpan l) cs) a)-  mkHsOverLitPV (L l a) = do-    cs <- getCommentsFor (locA l)-    return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a)-  mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn)-  mkHsTySigPV l a sig anns = do-    cs <- getCommentsFor (locA l)-    return $ L l (ExprWithTySig (EpAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig))-  mkHsExplicitListPV l xs anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs)-  mkHsSplicePV sp@(L l _) = do-    cs <- getCommentsFor l-    return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp-  mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do-    cs <- getCommentsFor l-    r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs)-    checkRecordSyntax (L (noAnnSrcSpan l) r)-  mkHsNegAppPV l a anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr)-  mkHsSectionR_PV l op e = do-    cs <- getCommentsFor l-    return $ L l (SectionR (comment (realSrcSpan l) cs) op e)-  mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsAsPatPV l v _ e   = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkSumOrTuplePV = mkSumOrTupleExpr-  rejectPragmaPV (L _ (OpApp _ _ _ e)) =-    -- assuming left-associative parsing of operators-    rejectPragmaPV e-  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $-                                                         (PsErrUnallowedPragma prag)-  rejectPragmaPV _                        = return ()--hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs-hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_")))--type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns-type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL-type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA-type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA--instance DisambECP (PatBuilder GhcPs) where-  type Body (PatBuilder GhcPs) = PatBuilder-  ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c-  ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e-  mkHsLamPV l _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat-  mkHsLetPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid-  type InfixOp (PatBuilder GhcPs) = RdrName-  superInfixOp m = m-  mkHsOpAppPV l p1 op p2 = do-    cs <- getCommentsFor l-    let anns = EpAnn (spanAsAnchor l) [] cs-    return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns-  mkHsCasePV l _ _ _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat-  mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant)-  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs-  superFunArg m = m-  mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)-  mkHsAppTypePV l p at t = do-    cs <- getCommentsFor (locA l)-    let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs-    return $ L l (PatBuilderAppType p at (mkHsPatSigType anns t))-  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat-  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat-  mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)-  mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)-  mkHsLitPV lit@(L l a) = do-    checkUnboxedLitPat lit-    return $ L l (PatBuilderPat (LitPat noExtField a))-  mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)-  mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))-  mkHsTySigPV l b sig anns = do-    p <- checkLPat b-    cs <- getCommentsFor (locA l)-    return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig)))-  mkHsExplicitListPV l xs anns = do-    ps <- traverse checkLPat xs-    cs <- getCommentsFor l-    return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps)))-  mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))-  mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do-    let (fs, ps) = partitionEithers fbinds-    if not (null ps)-     then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid-     else do-       cs <- getCommentsFor l-       r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)-       checkRecordSyntax (L (noAnnSrcSpan l) r)-  mkHsNegAppPV l (L lp p) anns = do-    lit <- case p of-      PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)-      _ -> patFail l $ PsErrInPat p PEIP_NegApp-    cs <- getCommentsFor l-    let an = EpAnn (spanAsAnchor l) anns cs-    return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))-  mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))-  mkHsViewPatPV l a b anns = do-    p <- checkLPat b-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p))-  mkHsAsPatPV l v at e = do-    p <- checkLPat e-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) NoEpAnns cs) v at p))-  mkHsLazyPatPV l e a = do-    p <- checkLPat e-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (EpAnn (spanAsAnchor l) a cs) p))-  mkHsBangPatPV l e an = do-    p <- checkLPat e-    cs <- getCommentsFor l-    let pb = BangPat (EpAnn (spanAsAnchor l) an cs) p-    hintBangPat l pb-    return $ L (noAnnSrcSpan l) (PatBuilderPat pb)-  mkSumOrTuplePV = mkSumOrTuplePat-  rejectPragmaPV _ = return ()---- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.-checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()-checkUnboxedLitPat (L loc lit) =-  case lit of-    -- Don't allow primitive string literal patterns.-    -- See #13260.-    HsStringPrim {}-      -> addError $ mkPlainErrorMsgEnvelope loc $-                           (PsErrIllegalUnboxedStringInPat lit)--   -- Don't allow Float#/Double# literal patterns.-   -- See #9238 and Note [Rules for floating-point comparisons]-   -- in GHC.Core.Opt.ConstantFold.-    _ | is_floating_lit lit-      -> addError $ mkPlainErrorMsgEnvelope loc $-                           (PsErrIllegalUnboxedFloatingLitInPat lit)--      | otherwise-      -> return ()--  where-    is_floating_lit :: HsLit GhcPs -> Bool-    is_floating_lit (HsFloatPrim  {}) = True-    is_floating_lit (HsDoublePrim {}) = True-    is_floating_lit _                 = False--mkPatRec ::-  LocatedA (PatBuilder GhcPs) ->-  HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->-  EpAnn [AddEpAnn] ->-  PV (PatBuilder GhcPs)-mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns-  | isRdrDataCon (unLoc c)-  = do fs <- mapM checkPatField fs-       return $ PatBuilderPat $ ConPat-         { pat_con_ext = anns-         , pat_con = c-         , pat_args = RecCon (HsRecFields fs dd)-         }-mkPatRec p _ _ =-  addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $-                    (PsErrInvalidRecordCon (unLoc p))---- | Disambiguate constructs that may appear when we do not know--- ahead of time whether we are parsing a type or a newtype/data constructor.------ See Note [Ambiguous syntactic categories] for the general idea.------ See Note [Parsing data constructors is hard] for the specific issue this--- particular class is solving.----class DisambTD b where-  -- | Process the head of a type-level function/constructor application,-  -- i.e. the @H@ in @H a b c@.-  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @f x@ (function application or prefix data constructor).-  mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @f \@t@ (visible kind application)-  mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @f \# x@ (infix operator)-  mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)-  mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)--instance DisambTD (HsType GhcPs) where-  mkHsAppTyHeadPV = return-  mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)-  mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki)-  mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)-  mkUnpackednessPV = addUnpackednessP--dataConBuilderCon :: DataConBuilder -> LocatedN RdrName-dataConBuilderCon (PrefixDataConBuilder _ dc) = dc-dataConBuilderCon (InfixDataConBuilder _ dc _) = dc--dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs---- Detect when the record syntax is used:---   data T = MkT { ... }-dataConBuilderDetails (PrefixDataConBuilder flds _)-  | [L l_t (HsRecTy an fields)] <- toList flds-  = RecCon (L (SrcSpanAnn an (locA l_t)) fields)---- Normal prefix constructor, e.g.  data T = MkT A B C-dataConBuilderDetails (PrefixDataConBuilder flds _)-  = PrefixCon noTypeArgs (map hsLinear (toList flds))---- Infix constructor, e.g. data T = Int :! Bool-dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)-  = InfixCon (hsLinear lhs) (hsLinear rhs)--instance DisambTD DataConBuilder where-  mkHsAppTyHeadPV = tyToDataConBuilder--  mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =-    return $-      L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))-        (PrefixDataConBuilder (flds `snocOL` t) fn)-  mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =-    -- This case is impossible because of the way-    -- the grammar in Parser.y is written (see infixtype/ftype).-    panic "mkHsAppTyPV: InfixDataConBuilder"--  mkHsAppKindTyPV lhs l_at ki =-    addFatalError $ mkPlainErrorMsgEnvelope l_at $-                      (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))--  mkHsOpTyPV prom lhs tc rhs = do-      check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative-      data_con <- eitherToP $ tyConToDataCon tc-      checkNotPromotedDataCon prom data_con-      return $ L l (InfixDataConBuilder lhs data_con rhs)-    where-      l = combineLocsA lhs rhs-      check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)-      check_no_ops (HsOpTy{}) =-        addError $ mkPlainErrorMsgEnvelope (locA l) $-                     (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))-      check_no_ops _ = return ()--  mkUnpackednessPV unpk constr_stuff-    | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff-    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool-      --   we apply {-# UNPACK #-} to the LHS-      do lhs' <- addUnpackednessP unpk lhs-         let l = combineLocsA (reLocA unpk) constr_stuff-         return $ L l (InfixDataConBuilder lhs' data_con rhs)-    | otherwise =-      do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon-         return constr_stuff--tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)-tyToDataConBuilder (L l (HsTyVar _ prom v)) = do-  data_con <- eitherToP $ tyConToDataCon v-  checkNotPromotedDataCon prom data_con-  return $ L l (PrefixDataConBuilder nilOL data_con)-tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do-  let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))-  return $ L l (PrefixDataConBuilder (toOL ts) data_con)-tyToDataConBuilder t =-  addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $-                    (PsErrInvalidDataCon (unLoc t))---- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).-checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()-checkNotPromotedDataCon NotPromoted _ = return ()-checkNotPromotedDataCon IsPromoted (L l name) =-  addError $ mkPlainErrorMsgEnvelope (locA l) $-    PsErrIllegalPromotionQuoteDataCon name--{- Note [Ambiguous syntactic categories]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are places in the grammar where we do not know whether we are parsing an-expression or a pattern without unlimited lookahead (which we do not have in-'happy'):--View patterns:--    f (Con a b     ) = ...  -- 'Con a b' is a pattern-    f (Con a b -> x) = ...  -- 'Con a b' is an expression--do-notation:--    do { Con a b <- x } -- 'Con a b' is a pattern-    do { Con a b }      -- 'Con a b' is an expression--Guards:--    x | True <- p && q = ...  -- 'True' is a pattern-    x | True           = ...  -- 'True' is an expression--Top-level value/function declarations (FunBind/PatBind):--    f ! a         -- TH splice-    f ! a = ...   -- function declaration--    Until we encounter the = sign, we don't know if it's a top-level-    TemplateHaskell splice where ! is used, or if it's a function declaration-    where ! is bound.--There are also places in the grammar where we do not know whether we are-parsing an expression or a command:--    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression-    proc x -> do { (stuff) }        -- 'stuff' is a command--    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'-    as an expression or a command.--In fact, do-notation is subject to both ambiguities:--    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression-    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern-    proc x -> do { (stuff) }             -- 'stuff' is a command--There are many possible solutions to this problem. For an overview of the ones-we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]--The solution that keeps basic definitions (such as HsExpr) clean, keeps the-concerns local to the parser, and does not require duplication of hsSyn types,-or an extra pass over the entire AST, is to parse into an overloaded-parser-validator (a so-called tagless final encoding):--    class DisambECP b where ...-    instance DisambECP (HsCmd GhcPs) where ...-    instance DisambECP (HsExp GhcPs) where ...-    instance DisambECP (PatBuilder GhcPs) where ...--The 'DisambECP' class contains functions to build and validate 'b'. For example,-to add parentheses we have:--  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)--'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for-expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,-see Note [PatBuilder]).--Consider the 'alts' production used to parse case-of alternatives:--  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--We abstract over LHsExpr GhcPs, and it becomes:--  alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }-    : alts1     { $1 >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { $2 >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Compared to the initial definition, the added bits are:--    forall b. DisambECP b => PV ( ... ) -- in the type signature-    $1 >>= \ $1 -> return $             -- in one reduction rule-    $2 >>= \ $2 -> return $             -- in another reduction rule--The overhead is constant relative to the size of the rest of the reduction-rule, so this approach scales well to large parser productions.--Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding-position and shadows the previous $1. We can do this because internally-'happy' desugars $n to happy_var_n, and the rationale behind this idiom-is to be able to write (sLL $1 $>) later on. The alternative would be to-write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer-to the last fresh name as $>.--Finally, we instantiate the polymorphic type to a concrete one, and run the-parser-validator, for example:--    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }-    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }-            : stmt {% runPV $1 }--In e_stmt, three things happen:--  1. we instantiate: b ~ HsExpr GhcPs-  2. we embed the PV computation into P by using runPV-  3. we run validation by using a monadic production, {% ... }--At this point the ambiguity is resolved.--}---{- Note [Resolving parsing ambiguities: non-taken alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Alternative I, extra constructors in GHC.Hs.Expr--------------------------------------------------We could add extra constructors to HsExpr to represent command-specific and-pattern-specific syntactic constructs. Under this scheme, we parse patterns-and commands as expressions and rejig later.  This is what GHC used to do, and-it polluted 'HsExpr' with irrelevant constructors:--  * for commands: 'HsArrForm', 'HsArrApp'-  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'--(As of now, we still do that for patterns, but we plan to fix it).--There are several issues with this:--  * The implementation details of parsing are leaking into hsSyn definitions.--  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.--  * HsExpr is arbitrarily selected as the extension basis. Why not extend-    HsCmd or HsPat with extra constructors instead?--Alternative II, extra constructors in GHC.Hs.Expr for GhcPs-------------------------------------------------------------We could address some of the problems with Alternative I by using Trees That-Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to-the output of parsing, not to its intermediate results, so we wouldn't want-them there either.--Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs-----------------------------------------------------------------We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.-Unfortunately, creating a new pass would significantly bloat conversion code-and slow down the compiler by adding another linear-time pass over the entire-AST. For example, in order to build HsExpr GhcPrePs, we would need to build-HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds-GhcPrePs.---Alternative IV, sum type and bottom-up data flow--------------------------------------------------Expressions and commands are disjoint. There are no user inputs that could be-interpreted as either an expression or a command depending on outer context:--  5        -- definitely an expression-  x -< y   -- definitely a command--Even though we have both 'HsLam' and 'HsCmdLam', we can look at-the body to disambiguate:--  \p -> 5        -- definitely an expression-  \p -> x -< y   -- definitely a command--This means we could use a bottom-up flow of information to determine-whether we are parsing an expression or a command, using a sum type-for intermediate results:--  Either (LHsExpr GhcPs) (LHsCmd GhcPs)--There are two problems with this:--  * We cannot handle the ambiguity between expressions and-    patterns, which are not disjoint.--  * Bottom-up flow of information leads to poor error messages. Consider--        if ... then 5 else (x -< y)--    Do we report that '5' is not a valid command or that (x -< y) is not a-    valid expression?  It depends on whether we want the entire node to be-    'HsIf' or 'HsCmdIf', and this information flows top-down, from the-    surrounding parsing context (are we in 'proc'?)--Alternative V, backtracking with parser combinators-----------------------------------------------------One might think we could sidestep the issue entirely by using a backtracking-parser and doing something along the lines of (try pExpr <|> pPat).--Turns out, this wouldn't work very well, as there can be patterns inside-expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns-(e.g. view patterns). To handle this, we would need to backtrack while-backtracking, and unbound levels of backtracking lead to very fragile-performance.--Alternative VI, an intermediate data type-------------------------------------------There are common syntactic elements of expressions, commands, and patterns-(e.g. all of them must have balanced parentheses), and we can capture this-common structure in an intermediate data type, Frame:--data Frame-  = FrameVar RdrName-    -- ^ Identifier: Just, map, BS.length-  | FrameTuple [LTupArgFrame] Boxity-    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)-  | FrameTySig LFrame (LHsSigWcType GhcPs)-    -- ^ Type signature: x :: ty-  | FramePar (SrcSpan, SrcSpan) LFrame-    -- ^ Parentheses-  | FrameIf LFrame LFrame LFrame-    -- ^ If-expression: if p then x else y-  | FrameCase LFrame [LFrameMatch]-    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }-  | FrameDo (HsStmtContext GhcRn) [LFrameStmt]-    -- ^ Do-expression: do { s1; a <- s2; s3 }-  ...-  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression-  | FramePat (HsPat GhcPs)     -- unambiguously a pattern-  | FrameCommand (HsCmd GhcPs) -- unambiguously a command--To determine which constructors 'Frame' needs to have, we take the union of-intersections between HsExpr, HsCmd, and HsPat.--The intersection between HsPat and HsExpr:--  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...-  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...-  --------------------------------------------------------------------  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...--The intersection between HsCmd and HsExpr:--  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar-  HsExpr = HsIf    | HsCase    | HsDo    | HsPar-  -------------------------------------------------  Frame = FrameIf  | FrameCase | FrameDo | FramePar--The intersection between HsCmd and HsPat:--  HsPat  = ParPat   | ...-  HsCmd  = HsCmdPar | ...-  ------------------------  Frame  = FramePar | ...--Take the union of each intersection and this yields the final 'Frame' data-type. The problem with this approach is that we end up duplicating a good-portion of hsSyn:--    Frame         for  HsExpr, HsPat, HsCmd-    TupArgFrame   for  HsTupArg-    FrameMatch    for  Match-    FrameStmt     for  StmtLR-    FrameGRHS     for  GRHS-    FrameGRHSs    for  GRHSs-    ...--Alternative VII, a product type---------------------------------We could avoid the intermediate representation of Alternative VI by parsing-into a product of interpretations directly:--    type ExpCmdPat = ( PV (LHsExpr GhcPs)-                     , PV (LHsCmd GhcPs)-                     , PV (LHsPat GhcPs) )--This means that in positions where we do not know whether to produce-expression, a pattern, or a command, we instead produce a parser-validator for-each possible option.--Then, as soon as we have parsed far enough to resolve the ambiguity, we pick-the appropriate component of the product, discarding the rest:--    checkExpOf3 (e, _, _) = e  -- interpret as an expression-    checkCmdOf3 (_, c, _) = c  -- interpret as a command-    checkPatOf3 (_, _, p) = p  -- interpret as a pattern--We can easily define ambiguities between arbitrary subsets of interpretations.-For example, when we know ahead of type that only an expression or a command is-possible, but not a pattern, we can use a smaller type:--    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))--    checkExpOf2 (e, _) = e  -- interpret as an expression-    checkCmdOf2 (_, c) = c  -- interpret as a command--However, there is a slight problem with this approach, namely code duplication-in parser productions. Consider the 'alts' production used to parse case-of-alternatives:--  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Under the new scheme, we have to completely duplicate its type signature and-each reduction rule:--  alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression-            , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command-            ) }-    : alts1-        { ( checkExpOf2 $1 >>= \ $1 ->-            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)-          , checkCmdOf2 $1 >>= \ $1 ->-            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)-          ) }-    | ';' alts-        { ( checkExpOf2 $2 >>= \ $2 ->-            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)-          , checkCmdOf2 $2 >>= \ $2 ->-            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)-          ) }--And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',-'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!--Alternative VIII, a function from a GADT------------------------------------------We could avoid code duplication of the Alternative VII by representing the product-as a function from a GADT:--    data ExpCmdG b where-      ExpG :: ExpCmdG HsExpr-      CmdG :: ExpCmdG HsCmd--    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))--    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)-    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)-    checkExp f = f ExpG  -- interpret as an expression-    checkCmd f = f CmdG  -- interpret as a command--Consider the 'alts' production used to parse case-of alternatives:--  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--We abstract over LHsExpr, and it becomes:--  alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1-        { \tag -> $1 tag >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts-        { \tag -> $2 tag >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Note that 'ExpCmdG' is a singleton type, the value is completely-determined by the type:--  when (b~HsExpr),  tag = ExpG-  when (b~HsCmd),   tag = CmdG--This is a clear indication that we can use a class to pass this value behind-the scenes:--  class    ExpCmdI b      where expCmdG :: ExpCmdG b-  instance ExpCmdI HsExpr where expCmdG = ExpG-  instance ExpCmdI HsCmd  where expCmdG = CmdG--And now the 'alts' production is simplified, as we no longer need to-thread 'tag' explicitly:--  alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1     { $1 >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { $2 >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--This encoding works well enough, but introduces an extra GADT unlike the-tagless final encoding, and there's no need for this complexity.---}--{- Note [PatBuilder]-~~~~~~~~~~~~~~~~~~~~-Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,-so we introduce the notion of a PatBuilder.--Consider a pattern like this:--  Con a b c--We parse arguments to "Con" one at a time in the  fexp aexp  parser production,-building the result with mkHsAppPV, so the intermediate forms are:--  1. Con-  2. Con a-  3. Con a b-  4. Con a b c--In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like-this (pseudocode):--  1. "Con"-  2. HsApp "Con" "a"-  3. HsApp (HsApp "Con" "a") "b"-  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"--Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have-instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for-the intermediate forms.--We also need an intermediate representation to postpone disambiguation between-FunBind and PatBind. Consider:--  a `Con` b = ...-  a `fun` b = ...--How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We-learn this by inspecting an intermediate representation in 'isFunLhs' and-seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate-representation capable of representing both a FunBind and a PatBind, so Pat is-insufficient.--PatBuilder is an extension of Pat that is capable of representing intermediate-parsing results for patterns and function bindings:--  data PatBuilder p-    = PatBuilderPat (Pat p)-    | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))-    | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))-    ...--It can represent any pattern via 'PatBuilderPat', but it also has a variety of-other constructors which were added by following a simple principle: we never-pattern match on the pattern stored inside 'PatBuilderPat'.--}-------------------------------------------------------------------------------- Miscellaneous utilities---- | Check if a fixity is valid. We support bypassing the usual bound checks--- for some special operators.-checkPrecP-        :: Located (SourceText,Int)              -- ^ precedence-        -> Located (OrdList (LocatedN RdrName))  -- ^ operators-        -> P ()-checkPrecP (L l (_,i)) (L _ ol)- | 0 <= i, i <= maxPrecedence = pure ()- | all specialOp ol = pure ()- | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)-  where-    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs-    specialOp op = unLoc op == getRdrName unrestrictedFunTyCon--mkRecConstrOrUpdate-        :: Bool-        -> LHsExpr GhcPs-        -> SrcSpan-        -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)-        -> EpAnn [AddEpAnn]-        -> PV (HsExpr GhcPs)-mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns-  | isRdrDataCon c-  = do-      let (fs, ps) = partitionEithers fbinds-      case ps of-          p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $-              PsErrOverloadedRecordDotInvalid-          _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)-mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns-  | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $-                                          PsErrDotsInRecordUpdate-  | otherwise = mkRdrRecordUpd overloaded_update exp fs anns--mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)-mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do-  -- We do not need to know if OverloadedRecordDot is in effect. We do-  -- however need to know if OverloadedRecordUpdate (passed in-  -- overloaded_on) is in effect because it affects the Left/Right nature-  -- of the RecordUpd value we calculate.-  let (fs, ps) = partitionEithers fbinds-      fs' :: [LHsRecUpdField GhcPs]-      fs' = map (fmap mk_rec_upd_field) fs-  case overloaded_on of-    False | not $ null ps ->-      -- A '.' was found in an update and OverloadedRecordUpdate isn't on.-      addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled-    False ->-      -- This is just a regular record update.-      return RecordUpd {-        rupd_ext = anns-      , rupd_expr = exp-      , rupd_flds = Left fs' }-    True -> do-      let qualifiedFields =-            [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'-                      , isQual . rdrNameAmbiguousFieldOcc $ lbl-            ]-      case qualifiedFields of-          qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $-            PsErrOverloadedRecordUpdateNoQualifiedFields-          _ -> return RecordUpd -- This is a RecordDotSyntax update.-             { rupd_ext = anns-             , rupd_expr = exp-             , rupd_flds = Right (toProjUpdates fbinds) }-  where-    toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]-    toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })--    -- Convert a top-level field update like {foo=2} or {bar} (punned)-    -- to a projection update.-    recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs-    recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =-        -- The idea here is to convert the label to a singleton [FastString].-        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-        where-          -- If punning, compute HsVar "f" otherwise just arg. This-          -- has the effect that sentinel HsVar "pun-rhs" is replaced-          -- by HsVar "f" here, before the update is written to a-          -- setField expressions.-          punnedVar :: FastString -> LHsExpr GhcPs-          punnedVar f  = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f--mkRdrRecordCon-  :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs-mkRdrRecordCon con flds anns-  = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds }--mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg-mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }-mk_rec_fields fs (Just s)  = HsRecFields { rec_flds = fs-                                     , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) }--mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs-mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)-  = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun--mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation-               -> InlinePragma--- The (Maybe Activation) is because the user can omit--- the activation spec (and usually does)-mkInlinePragma src (inl, match_info) mb_act-  = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.SourceText-                 , inl_inline = inl-                 , inl_sat    = Nothing-                 , inl_act    = act-                 , inl_rule   = match_info }-  where-    act = case mb_act of-            Just act -> act-            Nothing  -> -- No phase specified-                        case inl of-                          NoInline _  -> NeverActive-                          Opaque _    -> NeverActive-                          _other      -> AlwaysActive--mkOpaquePragma :: SourceText -> InlinePragma-mkOpaquePragma src-  = InlinePragma { inl_src    = src-                 , inl_inline = Opaque src-                 , inl_sat    = Nothing-                 -- By marking the OPAQUE pragma NeverActive we stop-                 -- (constructor) specialisation on OPAQUE things.-                 ---                 -- See Note [OPAQUE pragma]-                 , inl_act    = NeverActive-                 , inl_rule   = FunLike-                 }--checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]-               -> P (DataDefnCons (LConDecl GhcPs))-checkNewOrData span name is_type_data = curry $ \ case-    (NewType, [a]) -> pure $ NewTypeCon a-    (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)-    (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)-  where-    -- In a "type data" declaration, the constructors are in the type/class-    -- namespace rather than the data constructor namespace.-    -- See Note [Type data declarations] in GHC.Rename.Module.-    handle_type_data-      | is_type_data = map (fmap promote_constructor)-      | otherwise = id--    promote_constructor (dc@ConDeclGADT { con_names = cons })-      = dc { con_names = fmap (fmap promote_name) cons }-    promote_constructor (dc@ConDeclH98 { con_name = con })-      = dc { con_name = fmap promote_name con }-    promote_constructor dc = dc--    promote_name name = fromMaybe name (promoteRdrName name)---------------------------------------------------------------------------------- utilities for foreign declarations---- construct a foreign import declaration----mkImport :: Located CCallConv-         -> Located Safety-         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)-         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)-mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =-    case unLoc cconv of-      CCallConv          -> returnSpec =<< mkCImport-      CApiConv           -> do-        imp <- mkCImport-        if isCWrapperImport imp-          then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport-          else returnSpec imp-      StdCallConv        -> returnSpec =<< mkCImport-      PrimCallConv       -> mkOtherImport-      JavaScriptCallConv -> mkOtherImport-  where-    -- Parse a C-like entity string of the following form:-    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"-    -- If 'cid' is missing, the function name 'v' is used instead as symbol-    -- name (cf section 8.5.1 in Haskell 2010 report).-    mkCImport = do-      let e = unpackFS entity-      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of-        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $-                             PsErrMalformedEntityString-        Just importSpec -> return importSpec--    isCWrapperImport (CImport _ _ _ _ CWrapper) = True-    isCWrapperImport _ = False--    -- currently, all the other import conventions only support a symbol name in-    -- the entity string. If it is missing, we use the function name instead.-    mkOtherImport = returnSpec importSpec-      where-        entity'    = if nullFS entity-                        then mkExtName (unLoc v)-                        else entity-        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)-        importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget--    returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport-          { fd_i_ext  = ann-          , fd_name   = v-          , fd_sig_ty = ty-          , fd_fi     = spec-          }------ the string "foo" is ambiguous: either a header or a C identifier.  The--- C identifier case comes first in the alternatives below, so we pick--- that one.-parseCImport :: Located CCallConv -> Located Safety -> FastString -> String-             -> Located SourceText-             -> Maybe (ForeignImport (GhcPass p))-parseCImport cconv safety nm str sourceText =- listToMaybe $ map fst $ filter (null.snd) $-     readP_to_S parse str- where-   parse = do-       skipSpaces-       r <- choice [-          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),-          string "wrapper" >> return (mk Nothing CWrapper),-          do optional (token "static" >> skipSpaces)-             ((mk Nothing <$> cimp nm) +++-              (do h <- munch1 hdr_char-                  skipSpaces-                  mk (Just (Header (SourceText h) (mkFastString h)))-                      <$> cimp nm))-         ]-       skipSpaces-       return r--   token str = do _ <- string str-                  toks <- look-                  case toks of-                      c : _-                       | id_char c -> pfail-                      _            -> return ()--   mk h n = CImport sourceText cconv safety h n--   hdr_char c = not (isSpace c)-   -- header files are filenames, which can contain-   -- pretty much any char (depending on the platform),-   -- so just accept any non-space character-   id_first_char c = isAlpha    c || c == '_'-   id_char       c = isAlphaNum c || c == '_'--   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)-             +++ (do isFun <- case unLoc cconv of-                               CApiConv ->-                                  option True-                                         (do token "value"-                                             skipSpaces-                                             return False)-                               _ -> return True-                     cid' <- cid-                     return (CFunction (StaticTarget NoSourceText cid'-                                        Nothing isFun)))-          where-            cid = return nm +++-                  (do c  <- satisfy id_first_char-                      cs <-  many (satisfy id_char)-                      return (mkFastString (c:cs)))----- construct a foreign export declaration----mkExport :: Located CCallConv-         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)-         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)-mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)- = return $ \ann -> ForD noExtField $-   ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty-                 , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) }-  where-    entity' | nullFS entity = mkExtName (unLoc v)-            | otherwise     = entity---- Supplying the ext_name in a foreign decl is optional; if it--- isn't there, the Haskell name is assumed. Note that no transformation--- of the Haskell name is then performed, so if you foreign export (++),--- it's external name will be "++". Too bad; it's important because we don't--- want z-encoding (e.g. names with z's in them shouldn't be doubled)----mkExtName :: RdrName -> CLabelString-mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm)------------------------------------------------------------------------------------- Help with module system imports/exports--data ImpExpSubSpec = ImpExpAbs-                   | ImpExpAll-                   | ImpExpList [LocatedA ImpExpQcSpec]-                   | ImpExpAllWith [LocatedA ImpExpQcSpec]--data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)-                  | ImpExpQcType EpaLocation (LocatedN RdrName)-                  | ImpExpQcWildcard--mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)-mkModuleImpExp anns (L l specname) subs = do-  cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments-  let ann = EpAnn (spanAsAnchor $ locA l) anns cs-  case subs of-    ImpExpAbs-      | isVarNameSpace (rdrNameSpace name)-                       -> return $ IEVar noExtField (L l (ieNameFromSpec specname))-      | otherwise      -> IEThingAbs ann . L l <$> nameT-    ImpExpAll          -> IEThingAll ann . L l <$> nameT-    ImpExpList xs      ->-      (\newName -> IEThingWith ann (L l newName)-        NoIEWildcard (wrapped xs)) <$> nameT-    ImpExpAllWith xs                       ->-      do allowed <- getBit PatternSynonymsBit-         if allowed-          then-            let withs = map unLoc xs-                pos   = maybe NoIEWildcard IEWildcard-                          (findIndex isImpExpQcWildcard withs)-                ies :: [LocatedA (IEWrappedName GhcPs)]-                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs-            in (\newName-                        -> IEThingWith ann (L l newName) pos ies)-               <$> nameT-          else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $-                 PsErrIllegalPatSynExport-  where-    name = ieNameVal specname-    nameT =-      if isVarNameSpace (rdrNameSpace name)-        then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $-               (PsErrVarForTyCon name)-        else return $ ieNameFromSpec specname--    ieNameVal (ImpExpQcName ln)   = unLoc ln-    ieNameVal (ImpExpQcType _ 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"--    wrapped = map (fmap ieNameFromSpec)--mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space-             -> P (LocatedN RdrName)-mkTypeImpExp name =-  do allowed <- getBit ExplicitNamespacesBit-     unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $-                                   PsErrIllegalExplicitNamespace-     return (fmap (`setRdrNameSpace` tcClsName) name)--checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])-checkImportSpec ie@(L _ specs) =-    case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of-      [] -> return ie-      (l:_) -> importSpecError (locA l)-  where-    importSpecError l =-      addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm---- In the correct order-mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)-mkImpExpSubSpec [] = return ([], ImpExpList [])-mkImpExpSubSpec [L la ImpExpQcWildcard] =-  return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll)-mkImpExpSubSpec xs =-  if (any (isImpExpQcWildcard . unLoc) xs)-    then return $ ([], ImpExpAllWith xs)-    else return $ ([], ImpExpList xs)--isImpExpQcWildcard :: ImpExpQcSpec -> Bool-isImpExpQcWildcard ImpExpQcWildcard = True-isImpExpQcWildcard _                = False---------------------------------------------------------------------------------- Warnings and failures--warnPrepositiveQualifiedModule :: SrcSpan -> P ()-warnPrepositiveQualifiedModule span =-  addPsMessage span PsWarnImportPreQualified--failNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failNotEnabledImportQualifiedPost loc =-  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified--failImportQualifiedTwice :: SrcSpan -> P ()-failImportQualifiedTwice loc =-  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice--warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addPsMessage span PsWarnStarIsType--failOpFewArgs :: MonadP m => LocatedN RdrName -> m a-failOpFewArgs (L loc op) =-  do { star_is_type <- getBit StarIsTypeBit-     ; let is_star_type = if star_is_type then StarIsType else StarIsNotType-     ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-         (PsErrOpFewArgs is_star_type op) }---------------------------------------------------------------------------------- Misc utils--data PV_Context =-  PV_Context-    { pv_options :: ParserOpts-    , pv_details :: ParseContext -- See Note [Parser-Validator Details]-    }--data PV_Accum =-  PV_Accum-    { pv_warnings        :: Messages PsMessage-    , pv_errors          :: Messages PsMessage-    , pv_header_comments :: Strict.Maybe [LEpaComment]-    , pv_comment_q       :: [LEpaComment]-    }--data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum-  deriving (Foldable, Functor, Traversable)---- During parsing, we make use of several monadic effects: reporting parse errors,--- accumulating warnings, adding API annotations, and checking for extensions. These--- effects are captured by the 'MonadP' type class.------ Sometimes we need to postpone some of these effects to a later stage due to--- ambiguities described in Note [Ambiguous syntactic categories].--- We could use two layers of the P monad, one for each stage:------   abParser :: forall x. DisambAB x => P (P x)------ The outer layer of P consumes the input and builds the inner layer, which--- validates the input. But this type is not particularly helpful, as it obscures--- the fact that the inner layer of P never consumes any input.------ For clarity, we introduce the notion of a parser-validator: a parser that does--- not consume any input, but may fail or use other effects. Thus we have:------   abParser :: forall x. DisambAB x => P (PV x)----newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }-  deriving (Functor)--instance Applicative PV where-  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)-  (<*>) = ap--instance Monad PV where-  m >>= f = PV $ \ctx acc ->-    case unPV m ctx acc of-      PV_Ok acc' a -> unPV (f a) ctx acc'-      PV_Failed acc' -> PV_Failed acc'--runPV :: PV a -> P a-runPV = runPV_details noParseContext--askParseContext :: PV ParseContext-askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details--runPV_details :: ParseContext -> PV a -> P a-runPV_details details m =-  P $ \s ->-    let-      pv_ctx = PV_Context-        { pv_options = options s-        , pv_details = details }-      pv_acc = PV_Accum-        { pv_warnings = warnings s-        , pv_errors   = errors s-        , pv_header_comments = header_comments s-        , pv_comment_q = comment_q s }-      mkPState acc' =-        s { warnings = pv_warnings acc'-          , errors   = pv_errors acc'-          , comment_q = pv_comment_q acc' }-    in-      case unPV m pv_ctx pv_acc of-        PV_Ok acc' a -> POk (mkPState acc') a-        PV_Failed acc' -> PFailed (mkPState acc')--instance MonadP PV where-  addError err =-    PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()-  addWarning w =-    PV $ \_ctx acc ->-      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed-      -- diagnostics.-      PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()-  addFatalError err =-    addError err >> PV (const PV_Failed)-  getBit ext =-    PV $ \ctx acc ->-      let b = ext `xtest` pExtsBitmap (pv_options ctx) in-      PV_Ok acc $! b-  allocateCommentsP ss = PV $ \_ s ->-    let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in-      PV_Ok s {-         pv_comment_q = comment_q'-       } (EpaComments newAnns)-  allocatePriorCommentsP ss = PV $ \_ s ->-    let (header_comments', comment_q', newAnns)-          = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in-      PV_Ok s {-         pv_header_comments = header_comments',-         pv_comment_q = comment_q'-       } (EpaComments newAnns)-  allocateFinalCommentsP ss = PV $ \_ s ->-    let (header_comments', comment_q', newAnns)-          = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in-      PV_Ok s {-         pv_header_comments = header_comments',-         pv_comment_q = comment_q'-       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)--{- Note [Parser-Validator Details]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set-depending on validation context. We use this in checkPattern to fix #984.--Consider this example, where the user has forgotten a 'do':--  f _ = do-    x <- computation-    case () of-      _ ->-        result <- computation-        case () of () -> undefined--GHC parses it as follows:--  f _ = do-    x <- computation-    (case () of-      _ ->-        result) <- computation-        case () of () -> undefined--Note that this fragment is parsed as a pattern:--  case () of-    _ ->-      result--We attempt to detect such cases and add a hint to the diagnostic messages:--  T984.hs:6:9:-    Parse error in pattern: case () of { _ -> result }-    Possibly caused by a missing 'do'?--The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed-out of the 'ParseContext', which are read by functions like 'patFail' when-constructing the 'PsParseErrorInPatDetails' data structure. When validating in a-context other than 'bindpat' (a pattern to the left of <-), we set the-details to 'noParseContext' and it has no effect on the diagnostic messages.---}---- | Hint about bang patterns, assuming @BangPatterns@ is off.-hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()-hintBangPat span e = do-    bang_on <- getBit BangPatBit-    unless bang_on $-      addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e--mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)-                 -> [AddEpAnn]-                 -> PV (LHsExpr GhcPs)---- Tuple-mkSumOrTupleExpr l boxity (Tuple es) anns = do-    cs <- getCommentsFor (locA l)-    return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity)-  where-    toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs-    toTupArg (Left ann) = missingTupArg ann-    toTupArg (Right a)  = Present noAnn a---- Sum--- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =---     return $ L l (ExplicitSum noExtField alt arity e)-mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do-    let an = case anns of-               [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] ->-                 AnnExplicitSum o barsp barsa c-               _ -> panic "mkSumOrTupleExpr"-    cs <- getCommentsFor (locA l)-    return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e)-mkSumOrTupleExpr l Boxed a@Sum{} _ =-    addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a--mkSumOrTuplePat-  :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]-  -> PV (LocatedA (PatBuilder GhcPs))---- Tuple-mkSumOrTuplePat l boxity (Tuple ps) anns = do-  ps' <- traverse toTupPat ps-  cs <- getCommentsFor (locA l)-  return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity))-  where-    toTupPat :: Either (EpAnn EpaLocation) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)-    -- Ignore the element location so that the error message refers to the-    -- entire tuple. See #19504 (and the discussion) for details.-    toTupPat p = case p of-      Left _ -> addFatalError $-                  mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat-      Right p' -> checkLPat p'---- Sum-mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do-   p' <- checkLPat p-   cs <- getCommentsFor (locA l)-   let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs-   return $ L l (PatBuilderPat (SumPat an p' alt arity))-mkSumOrTuplePat l Boxed a@Sum{} _ =-    addFatalError $-      mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a--mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs-mkLHsOpTy prom x op y =-  let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y-  in L loc (mkHsOpTy prom x op y)--mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs-mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr-  -- See #18888 for the use of (SourceText "1") above-  = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)-  where-    -- The location of "%" combined with the location of "1".-    locOfPct1 :: TokenLocation-    locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t))-mkMultTy pct t arr = HsExplicitMult pct t arr--mkTokenLocation :: SrcSpan -> TokenLocation-mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc-mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)---- Precondition: the TokenLocation has EpaSpan, never EpaDelta.-token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation-token_location_widenR NoTokenLoc _ = NoTokenLoc-token_location_widenR tl (UnhelpfulSpan _) = tl-token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) =-                      (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2)))-token_location_widenR (TokenLoc (EpaDelta _ _)) _ =-  -- Never happens because the parser does not produce EpaDelta.-  panic "token_location_widenR: EpaDelta"----------------------------------------------------------------------------------- Token symbols--starSym :: Bool -> FastString-starSym True = fsLit "★"-starSym False = fsLit "*"---------------------------------------------- Bits and pieces for RecordDotSyntax.--mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)-  -> EpAnnCO -> LHsExpr GhcPs-mkRdrGetField loc arg field anns =-  L loc HsGetField {-      gf_ext = anns-    , gf_expr = arg-    , gf_field = field-    }--mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs-mkRdrProjection flds anns =-  HsProjection {-      proj_ext = anns-    , proj_flds = flds-    }--mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]-                -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn]-                -> 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-    , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)-    , hfbRHS = arg-    , hfbPun = isPun-  }+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-}++--+--  (c) The University of Glasgow 2002-2006+--++-- Functions over HsSyn specialised to RdrName.++module GHC.Parser.PostProcess (+        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot+        mkHsOpApp,+        mkHsIntegral, mkHsFractional, mkHsIsString,+        mkHsDo, mkMDo, mkSpliceDecl,+        mkRoleAnnotDecl,+        mkClassDecl,+        mkTyData, mkDataFamInst,+        mkTySynonym, mkTyFamInstEqn,+        mkStandaloneKindSig,+        mkTyFamInst,+        mkFamDecl,+        mkInlinePragma,+        mkOpaquePragma,+        mkPatSynMatchGroup,+        mkRecConstrOrUpdate,+        mkTyClD, mkInstD,+        mkRdrRecordCon, mkRdrRecordUpd,+        setRdrNameSpace,+        fromSpecTyVarBndr, fromSpecTyVarBndrs,+        annBinds,+        stmtsAnchor, stmtsLoc,++        cvBindGroup,+        cvBindsAndSigs,+        cvTopDecls,+        placeHolderPunRhs,++        -- Stuff to do with Foreign declarations+        mkImport,+        parseCImport,+        mkExport,+        mkExtName,    -- RdrName -> CLabelString+        mkGadtDecl,   -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName+        mkConDeclH98,++        -- Bunch of functions in the parser monad for+        -- checking and constructing values+        checkImportDecl,+        checkExpBlockArguments, checkCmdBlockArguments,+        checkPrecP,           -- Int -> P Int+        checkContext,         -- HsType -> P HsContext+        checkPattern,         -- HsExp -> P HsPat+        checkPattern_details,+        incompleteDoBlock,+        ParseContext(..),+        checkMonadComp,+        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl+        checkValSigLhs,+        LRuleTyTmVar, RuleTyTmVar(..),+        mkRuleBndrs,+        ruleBndrsOrDef,+        checkRuleTyVarBndrNames,+        mkSpecSig,+        checkRecordSyntax,+        checkEmptyGADTs,+        addFatalError, hintBangPat,+        mkBangTy,+        UnpackednessPragma(..),+        mkMultAnn,+        mkMultField,+        mkConDeclField,++        -- Help with processing exports+        ImpExpSubSpec(..),+        ImpExpQcSpec(..),+        mkModuleImpExp,+        mkPlainImpExp,+        mkTypeImpExp,+        mkDataImpExp,+        mkImpExpSubSpec,+        checkImportSpec,+        warnPatternNamespaceSpecifier,++        -- Token symbols+        starSym,++        -- Warnings and errors+        warnStarIsType,+        warnPrepositiveQualifiedModule,+        failOpFewArgs,+        failNotEnabledImportQualifiedPost,+        failImportQualifiedTwice,+        failSpliceOrQuoteTwice,++        SumOrTuple (..),++        -- Expression/command/pattern ambiguity resolution+        PV,+        runPV,+        ECP(ECP, unECP),+        DisambInfixOp(..),+        DisambECP(..),+        ecpFromExp,+        ecpFromCmd,+        ecpFromPat,+        ArrowParsingMode(..),+        withArrowParsingMode, withArrowParsingMode',+        setTelescopeBndrsNameSpace,+        PatBuilder,++        -- Type/datacon ambiguity resolution+        DisambTD(..),+        addUnpackednessP,+        dataConBuilderCon,+        dataConBuilderDetails,+        mkUnboxedSumCon,++        -- ListTuplePuns related parsers+        mkTupleSyntaxTy,+        mkTupleSyntaxTycon,+        mkListSyntaxTy0,+        mkListSyntaxTy1,+        withCombinedComments,+        requireLTPuns,+    ) where++import GHC.Prelude+import GHC.Hs           -- Lots of it+import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )+import GHC.Core.DataCon        ( DataCon, dataConTyCon, dataConName )+import GHC.Core.ConLike        ( ConLike(..) )+import GHC.Core.Coercion.Axiom ( Role, fsFromRole )+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Fixity+import GHC.Types.Hint+import GHC.Types.SourceText+import GHC.Parser.Types+import GHC.Parser.Lexer+import GHC.Parser.Errors.Types+import GHC.Utils.Lexeme ( okConOcc )+import GHC.Types.TyThing+import GHC.Core.Type    ( Specificity(..) )+import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,+                          nilDataConName, nilDataConKey,+                          listTyConName, listTyConKey, sumDataCon,+                          unrestrictedFunTyCon , listTyCon_RDR, unitDataCon )+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc+import GHC.Types.Unique ( hasKey )+import GHC.Data.OrdList+import GHC.Utils.Outputable as Outputable+import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Monad (unlessM)+import Data.Either+import Data.List        ( findIndex )+import Data.Foldable+import qualified Data.Semigroup as Semi+import GHC.Unit.Module.Warnings+import GHC.Utils.Panic+import qualified GHC.Data.Strict as Strict++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import Control.Monad+import Text.ParserCombinators.ReadP as ReadP+import Data.Char+import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )+import Data.Kind       ( Type )+import Data.List.NonEmpty ( NonEmpty (..) )++{- **********************************************************************++  Construction functions for Rdr stuff++  ********************************************************************* -}++-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and+-- datacon by deriving them from the name of the class.  We fill in the names+-- for the tycon and datacon corresponding to the class, by deriving them+-- from the name of the class itself.  This saves recording the names in the+-- interface file (which would be equally good).++-- Similarly for mkConDecl, mkClassOpSig and default-method names.++--         *** See Note [The Naming story] in GHC.Hs.Decls ****++mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)+mkTyClD (L loc d) = L loc (TyClD noExtField d)++mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)+mkInstD (L loc d) = L loc (InstD noExtField d)++mkClassDecl :: SrcSpan+            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)+            -> Located (a,[LHsFunDep GhcPs])+            -> OrdList (LHsDecl GhcPs)+            -> EpLayout+            -> AnnClassDecl+            -> P (LTyClDecl GhcPs)++mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn+  = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls+       ; (cls, tparams, fixity, ops, cps, cs) <- checkTyClHdr True tycl_hdr+       ; tyvars <- checkTyVars (text "class") whereDots cls tparams+       ; let anns' = annsIn { acd_openp = ops, acd_closep = cps}+       ; let loc = EpAnn (spanAsAnchor loc') noAnn cs+       ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)+                                  , tcdCtxt = mcxt+                                  , tcdLName = cls, tcdTyVars = tyvars+                                  , tcdFixity = fixity+                                  , tcdFDs = snd (unLoc fds)+                                  , tcdSigs = mkClassOpSigs sigs+                                  , tcdMeths = binds+                                  , tcdATs = ats, tcdATDefs = at_defs+                                  , tcdDocs  = docs })) }++mkTyData :: SrcSpan+         -> Bool+         -> NewOrData+         -> Maybe (LocatedP CType)+         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)+         -> Maybe (LHsKind GhcPs)+         -> [LConDecl GhcPs]+         -> Located (HsDeriving GhcPs)+         -> AnnDataDefn+         -> P (LTyClDecl GhcPs)+mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))+         ksig data_cons (L _ maybe_deriv) annsIn+  = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr+       ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams+       ; let anns = annsIn {andd_openp = ops, andd_closep = cps}+       ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons+       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns+       ; !cs' <- getCommentsFor loc'+       ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs)+       ; return (L loc (DataDecl { tcdDExt = noExtField,+                                   tcdLName = tc, tcdTyVars = tyvars,+                                   tcdFixity = fixity,+                                   tcdDataDefn = defn })) }++mkDataDefn :: Maybe (LocatedP CType)+           -> Maybe (LHsContext GhcPs)+           -> Maybe (LHsKind GhcPs)+           -> DataDefnCons (LConDecl GhcPs)+           -> HsDeriving GhcPs+           -> AnnDataDefn+           -> P (HsDataDefn GhcPs)+mkDataDefn cType mcxt ksig data_cons maybe_deriv anns+  = do { checkDatatypeContext mcxt+       ; return (HsDataDefn { dd_ext = anns+                            , dd_cType = cType+                            , dd_ctxt = mcxt+                            , dd_cons = data_cons+                            , dd_kindSig = ksig+                            , dd_derivs = maybe_deriv }) }++mkTySynonym :: SrcSpan+            -> LHsType GhcPs  -- LHS+            -> LHsType GhcPs  -- RHS+            -> EpToken "type"+            -> EpToken "="+            -> P (LTyClDecl GhcPs)+mkTySynonym loc lhs rhs antype aneq+  = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs+       ; tyvars <- checkTyVars (text "type") equalsDots tc tparams+       ; let anns = AnnSynDecl ops cps antype aneq+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' (SynDecl { tcdSExt = anns+                                 , tcdLName = tc, tcdTyVars = tyvars+                                 , tcdFixity = fixity+                                 , tcdRhs = rhs })) }++mkStandaloneKindSig+  :: SrcSpan+  -> Located [LocatedN RdrName]   -- LHS+  -> LHsSigType GhcPs             -- RHS+  -> (EpToken "type", TokDcolon)+  -> P (LStandaloneKindSig GhcPs)+mkStandaloneKindSig loc lhs rhs anns =+  do { vs <- mapM check_lhs_name (unLoc lhs)+     ; v <- check_singular_lhs (reverse vs)+     ; return $ L (noAnnSrcSpan loc)+       $ StandaloneKindSig anns v rhs }+  where+    check_lhs_name v@(unLoc->name) =+      if isUnqual name && isTcOcc (rdrNameOcc name)+      then return v+      else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $+             (PsErrUnexpectedQualifiedConstructor (unLoc v))+    check_singular_lhs vs =+      case vs of+        [] -> panic "mkStandaloneKindSig: empty left-hand side"+        [v] -> return v+        _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $+               (PsErrMultipleNamesInStandaloneKindSignature vs)++mkTyFamInstEqn :: SrcSpan+               -> HsOuterFamEqnTyVarBndrs GhcPs+               -> LHsType GhcPs+               -> LHsType GhcPs+               -> EpToken "="+               -> P (LTyFamInstEqn GhcPs)+mkTyFamInstEqn loc bndrs lhs rhs annEq+  = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' $ FamEqn+                        { feqn_ext    = (ops, cps, annEq)+                        , feqn_tycon  = tc+                        , feqn_bndrs  = bndrs+                        , feqn_pats   = tparams+                        , feqn_fixity = fixity+                        , feqn_rhs    = rhs })}++mkDataFamInst :: SrcSpan+              -> NewOrData+              -> Maybe (LocatedP CType)+              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs+                        , LHsType GhcPs)+              -> Maybe (LHsKind GhcPs)+              -> [LConDecl GhcPs]+              -> Located (HsDeriving GhcPs)+              -> AnnDataDefn+              -> P (LInstDecl GhcPs)+mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)+              ksig data_cons (L _ maybe_deriv) anns+  = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr+       ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons+       ; let anns' = anns {andd_openp = ops, andd_closep = cps}+       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns'+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl+                  (FamEqn { feqn_ext    = ([], [], NoEpTok)+                          , feqn_tycon  = tc+                          , feqn_bndrs  = bndrs+                          , feqn_pats   = tparams+                          , feqn_fixity = fixity+                          , feqn_rhs    = defn })))) }++++mkTyFamInst :: SrcSpan+            -> TyFamInstEqn GhcPs+            -> EpToken "type"+            -> EpToken "instance"+            -> P (LInstDecl GhcPs)+mkTyFamInst loc eqn t i = do+  return (L (noAnnSrcSpan loc) (TyFamInstD noExtField+              (TyFamInstDecl (t,i) eqn)))++mkFamDecl :: SrcSpan+          -> FamilyInfo GhcPs+          -> TopLevelFlag+          -> LHsType GhcPs                   -- LHS+          -> LFamilyResultSig GhcPs          -- Optional result signature+          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation+          -> AnnFamilyDecl+          -> P (LTyClDecl GhcPs)+mkFamDecl loc info topLevel lhs ksig injAnn annsIn+  = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs+       ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; let anns' = annsIn { afd_openp = ops, afd_closep = cps }+       ; return (L loc' (FamDecl noExtField (FamilyDecl+                                           { fdExt       = anns'+                                           , fdTopLevel  = topLevel+                                           , fdInfo      = info, fdLName = tc+                                           , fdTyVars    = tyvars+                                           , fdFixity    = fixity+                                           , fdResultSig = ksig+                                           , fdInjectivityAnn = injAnn }))) }+  where+    equals_or_where = case info of+                        DataFamily          -> empty+                        OpenTypeFamily      -> empty+                        ClosedTypeFamily {} -> whereDots++mkSpliceDecl :: LHsExpr GhcPs -> (LHsDecl GhcPs)+-- If the user wrote+--      [pads| ... ]   then return a QuasiQuoteD+--      $(e)           then return a SpliceD+-- but if they wrote, say,+--      f x            then behave as if they'd written $(f x)+--                     ie a SpliceD+--+-- Typed splices are not allowed at the top level, thus we do not represent them+-- as spliced declaration.  See #10945+mkSpliceDecl lexpr@(L loc expr)+  | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr+    = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice)++  | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr+    = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice)++  | otherwise+    = L loc $ SpliceD noExtField (SpliceDecl noExtField+                                 (L (l2l loc) (HsUntypedSpliceExpr noAnn (la2la lexpr)))+                                       BareSplice)++mkRoleAnnotDecl :: SrcSpan+                -> LocatedN RdrName                -- type being annotated+                -> [Located (Maybe FastString)]    -- roles+                -> (EpToken "type", EpToken "role")+                -> P (LRoleAnnotDecl GhcPs)+mkRoleAnnotDecl loc tycon roles anns+  = do { roles' <- mapM parse_role roles+       ; !cs <- getCommentsFor loc+       ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs)+         $ RoleAnnotDecl anns tycon roles' }+  where+    role_data_type = dataTypeOf (undefined :: Role)+    all_roles = map fromConstr $ dataTypeConstrs role_data_type+    possible_roles = [(fsFromRole role, role) | role <- all_roles]++    parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing+    parse_role (L loc_role (Just role))+      = case lookup role possible_roles of+          Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role+          Nothing         ->+            let nearby = fuzzyLookup (unpackFS role)+                  (mapFst unpackFS possible_roles)+            in+            addFatalError $ mkPlainErrorMsgEnvelope loc_role $+              (PsErrIllegalRoleName role nearby)++mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs+mkMDo ctxt stmts tok loc+  = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok [])++-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to+-- binders without annotations. Only accepts specified variables, and errors if+-- any of the provided binders has an 'InferredSpec' annotation.+fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]+fromSpecTyVarBndrs = mapM fromSpecTyVarBndr++-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without+-- annotations. Only accepts specified variables, and errors if the provided+-- binder has an 'InferredSpec' annotation.+fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)+fromSpecTyVarBndr (L loc (HsTvb xtv flag idp k)) = do+  case flag of+    SpecifiedSpec -> return ()+    InferredSpec  -> addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+                                     PsErrInferredTypeVarNotAllowed+  return $ L loc (HsTvb xtv () idp k)++-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@+annBinds :: EpToken "where" -> EpAnnComments -> HsLocalBinds GhcPs+  -> (HsLocalBinds GhcPs, Maybe EpAnnComments)+annBinds w cs (HsValBinds an bs)  = (HsValBinds (add_where w an cs) bs, Nothing)+annBinds w cs (HsIPBinds an bs)   = (HsIPBinds (add_where w an cs) bs, Nothing)+annBinds _ cs  (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)++add_where :: EpToken "where" -> EpAnn (AnnList (EpToken "where")) -> EpAnnComments -> EpAnn (AnnList (EpToken "where"))+add_where w@(EpTok (EpaSpan (RealSrcSpan rs _))) (EpAnn a al cs) cs2+  | valid_anchor a+  = EpAnn (widenAnchorT a w) (al { al_rest = w}) (cs Semi.<> cs2)+  | otherwise+  = EpAnn (patch_anchor rs a)+          (al { al_anchor = (fmap (patch_anchor rs) (al_anchor al))+              , al_rest = w})+          (cs Semi.<> cs2)+add_where _ _ _ = panic "add_where"+ -- EpaDelta should only be used for transformations++valid_anchor :: EpaLocation -> Bool+valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0+valid_anchor _ = False++-- If the decl list for where binds is empty, the anchor ends up+-- invalid. In this case, use the parent one+patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation+patch_anchor r EpaDelta{} = EpaSpan (RealSrcSpan r Strict.Nothing)+patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb)+  where+    r = if srcSpanStartLine r0 < 0 then r1 else r0+patch_anchor _ (EpaSpan ss) = EpaSpan ss++-- | The anchor for a stmtlist is based on either the location or+-- the first semicolon annotion.+stmtsAnchor :: Located (OrdList (EpToken tok),a) -> Maybe EpaLocation+stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (EpTok (EpaSpan (RealSrcSpan r rb))) _), _))+  = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb)+stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb)+stmtsAnchor _ = Nothing++stmtsLoc :: Located (OrdList (EpToken tok),a) -> SrcSpan+stmtsLoc (L l ((ConsOL aa _), _))+  = widenSpanT l aa+stmtsLoc (L l _) = l++{- **********************************************************************++  #cvBinds-etc# Converting to @HsBinds@, etc.++  ********************************************************************* -}++-- | Function definitions are restructured here. Each is assumed to be recursive+-- initially, and non recursive definitions are discovered by the dependency+-- analyser.+++--  | Groups together bindings for a single function+cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]+cvTopDecls decls = getMonoBindAll (fromOL decls)++-- Declaration list may only contain value bindings and signatures.+cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)+cvBindGroup binding+  = do { (mbs, sigs, fam_ds, tfam_insts+         , dfam_insts, _) <- cvBindsAndSigs binding+       ; massert (null fam_ds && null tfam_insts && null dfam_insts)+       ; return $ ValBinds NoAnnSortKey mbs sigs }++cvBindsAndSigs :: OrdList (LHsDecl GhcPs)+  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]+          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])+-- Input decls contain just value bindings and signatures+-- and in case of class or instance declarations also+-- associated type declarations. They might also contain Haddock comments.+cvBindsAndSigs fb = do+  fb' <- drop_bad_decls (fromOL fb)+  return (partitionBindsAndSigs (getMonoBindAll fb'))+  where+    -- cvBindsAndSigs is called in several places in the parser,+    -- and its items can be produced by various productions:+    --+    --    * decl       (when parsing a where clause or a let-expression)+    --    * decl_inst  (when parsing an instance declaration)+    --    * decl_cls   (when parsing a class declaration)+    --+    -- partitionBindsAndSigs can handle almost all declaration forms produced+    -- by the aforementioned productions, except for SpliceD, which we filter+    -- out here (in drop_bad_decls).+    --+    -- We're not concerned with every declaration form possible, such as those+    -- produced by the topdecl parser production, because cvBindsAndSigs is not+    -- called on top-level declarations.+    drop_bad_decls [] = return []+    drop_bad_decls (L l (SpliceD _ d) : ds) = do+      addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d+      drop_bad_decls ds+    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds++-----------------------------------------------------------------------------+-- Group function bindings into equation groups++getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]+  -> (LHsBind GhcPs, [LHsDecl GhcPs])+-- Suppose      (b',ds') = getMonoBind b ds+--      ds is a list of parsed bindings+--      b is a MonoBinds that has just been read off the front++-- Then b' is the result of grouping more equations from ds that+-- belong with b into a single MonoBinds, and ds' is the depleted+-- list of parsed bindings.+--+-- All Haddock comments between equations inside the group are+-- discarded.+--+-- No AndMonoBinds or EmptyMonoBinds here; just single equations++getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)+                             , fun_matches =+                               MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))+            binds+  | has_args m1+  = go [L loc1 mtchs1] (noAnnSrcSpan $ locA loc1) binds []+  where+    -- See Note [Exact Print Annotations for FunBind]+    go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun+       -> SrcSpanAnnA                    -- current top level loc+       -> [LHsDecl GhcPs]                -- Any docbinds seen+       -> [LHsDecl GhcPs]                -- rest of decls to be processed+       -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls+    go mtchs loc+       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)+                                 , fun_matches =+                                    MG { mg_alts = (L _ [L lm2 mtchs2]) } })))+         : binds) _+        | f1 == f2 =+          let (loc2', lm2') = transferAnnsA loc2 lm2+          in go (L lm2' mtchs2 : mtchs)+                        (combineSrcSpansA loc loc2') binds []+    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls+        = let doc_decls' = doc_decl : doc_decls+          in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'+    go mtchs loc binds doc_decls+        = let+            L llm last_m = head mtchs -- Guaranteed at least one+            (llm',loc') = transferAnnsOnlyA llm loc -- Keep comments, transfer trailing++            matches' = reverse (L llm' last_m:tail mtchs)+            L lfm first_m =  head matches'+            (lfm', loc'') = transferCommentsOnlyA lfm loc'+          in+            ( L loc'' (makeFunBind fun_id1 (mkLocatedList $ (L lfm' first_m:tail matches')))+              , (reverse doc_decls) ++ binds)+        -- Reverse the final matches, to get it back in the right order+        -- Do the same thing with the trailing doc comments++getMonoBind bind binds = (bind, binds)++{- Note [Exact Print Annotations for FunBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++An individual Match that ends up in a FunBind MatchGroup is initially+parsed as a LHsDecl. This takes the form++   L loc (ValD NoExtField (FunBind ... [L lm (Match ..)]))++The loc contains the annotations, in particular comments, which are to+precede the declaration when printed, and [TrailingAnn] which are to+follow it. The [TrailingAnn] captures semicolons that may appear after+it when using the braces and semis style of coding.++The match location (lm) has only a location in it at this point, no+annotations. Its location is the same as the top level location in+loc.++What getMonoBind does it to take a sequence of FunBind LHsDecls that+belong to the same function and group them into a single function with+the component declarations all combined into the single MatchGroup as+[LMatch GhcPs].++Given that when exact printing a FunBind the exact printer simply+iterates over all the matches and prints each in turn, the simplest+behaviour would be to simply take the top level annotations (loc) for+each declaration, and use them for the individual component matches+(lm).++The problem is the exact printer first has to deal with the top level+LHsDecl, which means annotations for the loc. This needs to be able to+be exact printed in the context of surrounding declarations, and if+some refactor decides to move the declaration elsewhere, the leading+comments and trailing semicolons need to be handled at that level.++So the solution is to combine all the matches into one, pushing the+annotations into the LMatch's, and then at the end extract the+comments from the first match and [TrailingAnn] from the last to go in+the top level LHsDecl.+-}++-- Group together adjacent FunBinds for every function.+getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]+getMonoBindAll [] = []+getMonoBindAll (L l (ValD _ b) : ds) =+  let (L l' b', ds') = getMonoBind (L l b) ds+  in L l' (ValD noExtField b') : getMonoBindAll ds'+getMonoBindAll (d : ds) = d : getMonoBindAll ds++has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool+has_args []                                  = panic "GHC.Parser.PostProcess.has_args"+has_args (L _ (Match { m_pats = L _ args }) : _) = not (null args)+        -- Don't group together FunBinds if they have+        -- no arguments.  This is necessary now that variable bindings+        -- with no arguments are now treated as FunBinds rather+        -- than pattern bindings (tests/rename/should_fail/rnfail002).++{- **********************************************************************++  #PrefixToHS-utils# Utilities for conversion++  ********************************************************************* -}++{- Note [Parsing data constructors is hard]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The problem with parsing data constructors is that they look a lot like types.+Compare:++  (s1)   data T = C t1 t2+  (s2)   type T = C t1 t2++Syntactically, there's little difference between these declarations, except in+(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.++This similarity would pose no problem if we knew ahead of time if we are+parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple+(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing+data constructors, and in other contexts (e.g. 'type' declarations) assume we+are parsing type constructors.++This simple rule does not work because of two problematic cases:++  (p1)   data T = C t1 t2 :+ t3+  (p2)   data T = C t1 t2 => t3++In (p1) we encounter (:+) and it turns out we are parsing an infix data+declaration, so (C t1 t2) is a type and 'C' is a type constructor.+In (p2) we encounter (=>) and it turns out we are parsing an existential+context, so (C t1 t2) is a constraint and 'C' is a type constructor.++As the result, in order to determine whether (C t1 t2) declares a data+constructor, a type, or a context, we would need unlimited lookahead which+'happy' is not so happy with.+-}++-- | Reinterpret a type constructor, including type operators, as a data+--   constructor.+-- See Note [Parsing data constructors is hard]+tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)+tyConToDataCon (L loc tc)+  | okConOcc (occNameString occ)+  = return (L loc (setRdrNameSpace tc srcDataName))++  | otherwise+  = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)+  where+    occ = rdrNameOcc tc++mkPatSynMatchGroup :: LocatedN RdrName+                   -> LocatedLW (OrdList (LHsDecl GhcPs))+                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))+mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =+    do { matches <- mapM fromDecl (fromOL decls)+       ; when (null matches) (wrongNumberErr (locA loc))+       ; return $ mkMatchGroup FromSource (L ld matches) }+  where+    fromDecl (L loc decl@(ValD _ (PatBind _+                         pat@(L _ (ConPat _conAnn ln@(L _ name) details))+                               _ rhs))) =+        do { unless (name == patsyn_name) $+               wrongNameBindingErr (locA loc) decl+           -- 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 }+                   where+                     l = listLocation pats+                     ctxt = FunRhs { mc_fun = ln+                                   , mc_fixity = Prefix+                                   , mc_strictness = NoSrcStrict+                                   , mc_an = ann_fun }++               InfixCon p1 p2 -> return $ Match { m_ext = noExtField+                                                , m_ctxt = ctxt+                                                , m_pats = L l [p1, p2]+                                                , m_grhss = rhs }+                   where+                     l = listLocation [p1, p2]+                     ctxt = FunRhs { mc_fun = ln+                                   , mc_fixity = Infix+                                   , mc_strictness = NoSrcStrict+                                   , mc_an = ann_fun }++               RecCon{} -> recordPatSynErr (locA loc) pat+           ; return $ L loc match }+    fromDecl (L loc decl) = extraDeclErr (locA loc) decl++    extraDeclErr loc decl =+        addFatalError $ mkPlainErrorMsgEnvelope loc $+          (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)++    wrongNameBindingErr loc decl =+      addFatalError $ mkPlainErrorMsgEnvelope loc $+          (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)++    wrongNumberErr loc =+      addFatalError $ mkPlainErrorMsgEnvelope loc $+        (PsErrEmptyWhereInPatSynDecl patsyn_name)++recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a+recordPatSynErr loc pat =+    addFatalError $ mkPlainErrorMsgEnvelope loc $+      (PsErrRecordSyntaxInPatSynDecl pat)++mkConDeclH98 :: (TokDarrow, (TokForall, EpToken ".")) -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]+                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs+                -> ConDecl GhcPs++mkConDeclH98 (tdarrow, (tforall,tdot)) name mb_forall mb_cxt args+  = ConDeclH98 { con_ext    = AnnConDeclH98 tforall tdot tdarrow+               , con_name   = name+               , con_forall = isJust mb_forall+               , con_ex_tvs = mb_forall `orElse` []+               , con_mb_cxt = mb_cxt+               , con_args   = args+               , con_doc    = Nothing }++-- | Construct a GADT-style data constructor from the constructor names and+-- their type. Some interesting aspects of this function:+--+-- * This splits up the constructor type into its quantified type variables (if+--   provided), context (if provided), argument types, and result type, and+--   records whether this is a prefix or record GADT constructor. See+--   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.+mkGadtDecl :: SrcSpan+           -> NonEmpty (LocatedN RdrName)+           -> TokDcolon+           -> LHsSigType GhcPs+           -> P (LConDecl GhcPs)+mkGadtDecl loc names dcol ty = do++  (args, res_ty, (ops, cps), csa) <-+    case body_ty of+     L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (XHsType (HsRecTy an rf))) res_ty) -> do+       arr <- case hsArr of+         HsUnannotated (EpArrow arr) -> return arr+         _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $+                                 (PsErrIllegalGadtRecordMultiplicity hsArr)+                 return noAnn++       return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty+              , ([], []), epAnnComments ll)+     _ -> do+       let ((ops, cps), cs, arg_types, res_type) = splitHsFunType body_ty+       return (PrefixConGADT noExtField arg_types, res_type, (ops,cps), cs)++  let l = EpAnn (spanAsAnchor loc) noAnn csa++  pure $ L l ConDeclGADT+                     { con_g_ext  = AnnConDeclGADT ops cps dcol+                     , con_names  = names+                     , 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, 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.+--+-- Case #1. When parsing:+--+-- > data T a = T | T1 Int+--+-- we parse the data constructors as /types/ because of parser ambiguities,+-- so then we need to change the /type constr/ to a /data constr/+--+-- The exact-name case /can/ occur when parsing:+--+-- > data [] a = [] | a : [a]+--+-- For the exact-name case we return an original name.+--+-- Case #2. When parsing:+--+-- > x = fn (forall a. a)   -- RequiredTypeArguments+--+-- we use setRdrNameSpace to set the namespace of forall-bound variables.+--+setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)+setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)+setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)+setRdrNameSpace (Exact n)    ns+  | Just thing <- wiredInNameTyThing_maybe n+  = setWiredInNameSpace thing ns+    -- Preserve Exact Names for wired-in things,+    -- notably tuples and lists++  | isExternalName n+  = Orig (nameModule n) occ++  | otherwise   -- This can happen when quoting and then+                -- splicing a fixity declaration for a type+  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))+  where+    occ = setOccNameSpace ns (nameOccName n)++setWiredInNameSpace :: TyThing -> NameSpace -> RdrName+setWiredInNameSpace (ATyCon tc) ns+  | isDataConNameSpace ns+  = ty_con_data_con tc+  | isTcClsNameSpace ns+  = Exact (getName tc)      -- No-op++setWiredInNameSpace (AConLike (RealDataCon dc)) ns+  | isTcClsNameSpace ns+  = data_con_ty_con dc+  | isDataConNameSpace ns+  = Exact (getName dc)      -- No-op++setWiredInNameSpace thing ns+  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)++ty_con_data_con :: TyCon -> RdrName+ty_con_data_con tc+  | isTupleTyCon tc+  , Just dc <- tyConSingleDataCon_maybe tc+  = Exact (getName dc)++  | tc `hasKey` listTyConKey+  = Exact nilDataConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace srcDataName (getOccName tc))++data_con_ty_con :: DataCon -> RdrName+data_con_ty_con dc+  | let tc = dataConTyCon dc+  , isTupleTyCon tc+  = Exact (getName tc)++  | dc `hasKey` nilDataConKey+  = Exact listTyConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace tcClsName (getOccName dc))++++{- Note [setRdrNameSpace for wired-in names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC.Types, which declares (:), we have+  infixr 5 :+The ambiguity about which ":" is meant is resolved by parsing it as a+data constructor, but then using dataTcOccs to try the type constructor too;+and that in turn calls setRdrNameSpace to change the name-space of ":" to+tcClsName.  There isn't a corresponding ":" type constructor, but it's painful+to make setRdrNameSpace partial, so we just make an Unqual name instead. It+really doesn't matter!+-}++eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a+-- Adapts the Either monad to the P monad+eitherToP (Left err)    = addFatalError err+eitherToP (Right thing) = return thing++checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]+            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables+-- ^ Check whether the given list of type parameters are all type variables+-- (possibly with a kind signature).+checkTyVars pp_what equals_or_where tc tparms+  = do { tvs <- mapM check tparms+       ; return (mkHsQTvs tvs) }+  where+    check (HsTypeArg at ki) = chkParens [] [] (HsBndrInvisible at) ki+    check (HsValArg _ ty) = chkParens [] [] (HsBndrRequired noExtField) ty+    check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $+                            (PsErrMalformedDecl pp_what (unLoc tc))+        -- Keep around an action for adjusting the annotations of extra parens+    chkParens :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs+              -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)+    chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))+      = let+          (o,c) = mkParensLocs (realSrcSpan $ locA l)+          (_,lt') = transferCommentsOnlyA l lt+        in+          chkParens (o:ops) (c:cps) bvis (L lt' ty)+    chkParens ops cps bvis ty = chk ops cps bvis ty++        -- Check that the name space is correct!+    chk :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)+    chk ops cps bvis (L l (HsKindSig tok_dc (L annt t) k))+        | Just (ann, bvar) <- match_bndr_var t+            = let+                bkind = HsBndrKind noExtField k+                an = (reverse ops) ++ cps+              in+                return (L (widenLocatedAnL (l Semi.<> annt) (for_widening bvis:an))+                       (HsTvb (AnnTyVarBndr (reverse ops) cps ann tok_dc) bvis bvar bkind))+    chk ops cps bvis (L l t)+        | Just (ann, bvar) <- match_bndr_var t+            = let+                bkind = HsBndrNoKind noExtField+                an = (reverse ops) ++ cps+              in+                return (L (widenLocatedAnL l (for_widening bvis:an))+                                     (HsTvb (AnnTyVarBndr (reverse ops) cps ann noAnn) bvis bvar bkind))+    chk _ _ _ t@(L loc _)+        = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+            (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)++    match_bndr_var :: HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs)+    match_bndr_var (HsTyVar ann _ tv) | isRdrTyVar (unLoc tv)+      = Just (ann, HsBndrVar noExtField tv)+    match_bndr_var (HsWildCardTy tok)+      = Just (noAnn, HsBndrWildCard tok)+    match_bndr_var _ = Nothing++    -- Return a EpaLocation for use in widenLocatedAnL.+    for_widening :: HsBndrVis GhcPs -> EpaLocation+    for_widening (HsBndrInvisible (EpTok loc)) = loc+    for_widening  _                            = noAnn+++whereDots, equalsDots :: SDoc+-- Second argument to checkTyVars+whereDots  = text "where ..."+equalsDots = text "= ..."++checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()+checkDatatypeContext Nothing = return ()+checkDatatypeContext (Just c)+    = do allowed <- getBit DatatypeContextsBit+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $+                                       (PsErrIllegalDataTypeContext c)++type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar+data RuleTyTmVar = RuleTyTmVar AnnTyVarBndr (LocatedN RdrName) (Maybe (LHsType GhcPs))+-- ^ Essentially a wrapper for a @RuleBndr GhcPs@++ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs+ruleBndrsOrDef (Just bndrs) = bndrs+ruleBndrsOrDef Nothing      = mkRuleBndrs noAnn Nothing []++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++checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P ()+-- See Note [Parsing explicit foralls in Rules] in Parser.y+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+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $+                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))+         return lr++-- | Check if the gadt_constrlist is empty. Only raise parse error for+-- `data T where` to avoid affecting existing error message, see #8258.+checkEmptyGADTs :: Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])+                -> P (Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs]))+checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.+    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax+         unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $+                                          PsErrIllegalWhereInDataDecl+         return gadts+checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.++checkTyClHdr :: Bool               -- True  <=> class header+                                   -- False <=> type header+             -> LHsType GhcPs+             -> P (LocatedN RdrName,     -- the head symbol (type or class name)+                   [LHsTypeArg GhcPs],   -- parameters of head symbol+                   LexicalFixity,        -- the declaration is in infix format+                   [EpToken "("],        -- API Annotation for HsParTy+                   [EpToken ")"],        -- when stripping parens+                   EpAnnComments)        -- Accumulated comments from re-arranging+-- Well-formedness check and decomposition of type and class heads.+-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])+--              Int :*: Bool   into    (:*:, [Int, Bool])+-- returning the pieces+checkTyClHdr is_cls ty+  = goL emptyComments ty [] [] [] Prefix+  where+    goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix++    -- workaround to define '*' despite StarIsType+    go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix+      = do { addPsMessage (locA l) PsWarnStarBinder+           ; let name = mkOccNameFS tcClsName (starSym isUni)+           ; let a' = newAnns ll l an+           ; return (L a' (Unqual name), acc, fix+                    , (reverse ops'), cps', cs) }++    go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix+      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l)+    go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix+      | isRdrTc tc               = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l)+      where lhs = HsValArg noExtField t1+            rhs = HsValArg noExtField t2+    go cs l (HsParTy (o,c) ty)    acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix+    go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix+    go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix+    go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix+      = return (L (l2l l) (nameRdrName tup_name)+               , map (HsValArg noExtField) ts, fix, (reverse ops), cps, cs Semi.<> comments l)+      where+        arity = length ts+        tup_name | is_cls    = cTupleTyConName arity+                 | otherwise = getName (tupleTyCon Boxed arity)+          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)+    go _ l _ _ _ _ _+      = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+          (PsErrMalformedTyOrClDecl ty)++    -- Combine the annotations from the HsParTy and HsStarTy into a+    -- new one for the LocatedN RdrName+    newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN+    newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (o,c) =+      let+        lr = combineSrcSpans (locA l1) (locA l)+      in+        EpAnn (EpaSpan lr) (NameAnn (NameParens o c) ap ta) (csp0 Semi.<> csp)++-- | Yield a parse error if we have a function applied directly to a do block+-- etc. and BlockArguments is not enabled.+checkExpBlockArguments :: LHsExpr GhcPs -> PV ()+checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)+  where+    checkExpr :: LHsExpr GhcPs -> PV ()+    checkExpr expr = case unLoc expr of+      HsDo _ (DoExpr m) _      -> check (PsErrDoInFunAppExpr m)               expr+      HsDo _ (MDoExpr m) _     -> check (PsErrMDoInFunAppExpr m)              expr+      HsCase {}                -> check PsErrCaseInFunAppExpr                 expr+      HsLam _ lam_variant _    -> check (PsErrLambdaInFunAppExpr lam_variant) expr+      HsLet {}                 -> check PsErrLetInFunAppExpr                  expr+      HsIf {}                  -> check PsErrIfInFunAppExpr                   expr+      HsProc {}                -> check PsErrProcInFunAppExpr                 expr+      _                        -> return ()++    checkCmd :: LHsCmd GhcPs -> PV ()+    checkCmd cmd = case unLoc cmd of+      HsCmdLam _ lam_variant _ -> check (PsErrLambdaCmdInFunAppCmd lam_variant) cmd+      HsCmdCase {}             -> check PsErrCaseCmdInFunAppCmd                 cmd+      HsCmdIf {}               -> check PsErrIfCmdInFunAppCmd                   cmd+      HsCmdLet {}              -> check PsErrLetCmdInFunAppCmd                  cmd+      HsCmdDo {}               -> check PsErrDoCmdInFunAppCmd                   cmd+      _                        -> return ()++    check err a = do+      blockArguments <- getBit BlockArgumentsBit+      unless blockArguments $+        addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)++-- | Validate the context constraints and break up a context into a list+-- of predicates.+--+-- @+--     (Eq a, Ord b)        -->  [Eq a, Ord b]+--     Eq a                 -->  [Eq a]+--     (Eq a)               -->  [Eq a]+--     (((Eq a)))           -->  [Eq a]+-- @+checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)+checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =+  check ([],[],cs) orig_t+ where+  check :: ([EpToken "("],[EpToken ")"],EpAnnComments)+        -> LHsType GhcPs -> P (LHsContext GhcPs)+  check (oparens,cparens,cs) (L _l (HsTupleTy (AnnParens o c) HsBoxedOrConstraintTuple ts))+    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can+    -- be used as context constraints.+    -- Ditto ()+    = mkCTuple (oparens ++ [o], c : cparens, cs) ts++  -- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure+  -- downstream.+  -- This converts them just like when they are parsed as types in the punned case.+  check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) _ ts))+    = punsAllowed >>= \case+      True -> unprocessed+      False -> do+        let+          (op, cp) = case q of+            EpTok ql -> ([EpTok ql], [c])+            _        -> ([o], [c])+        mkCTuple (oparens ++ op, cp ++ cparens, cs) ts+  check (opi,cpi,csi) (L _lp1 (HsParTy (o,c) ty))+                                             -- to be sure HsParTy doesn't get into the way+    = check (o:opi, c:cpi, csi) ty++  -- No need for anns, returning original+  check (_opi,_cpi,_csi) _t = unprocessed++  unprocessed =+    return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_t])+++  mkCTuple (oparens, cparens, cs) ts =+    -- Append parens so that the original order in the source is maintained+    return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts)++-- | The same as `checkContext`, but for expressions.+--+-- Validate the context constraints and break up a context into a list+-- of predicates.+--+-- @+--     (Eq a, Ord b)        -->  [Eq a, Ord b]+--     Eq a                 -->  [Eq a]+--     (Eq a)               -->  [Eq a]+--     (((Eq a)))           -->  [Eq a]+-- @+checkContextExpr :: LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])+checkContextExpr orig_expr@(L (EpAnn l _ cs) _) =+  check ([],[], cs) orig_expr+  where+    check :: ([EpToken "("],[EpToken ")"],EpAnnComments)+        -> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])+    check (oparens,cparens,cs) (L _ (ExplicitTuple (ap_open, ap_close) tup_args boxity))+             -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be a context+      | isBoxed boxity+      , Just es <- tupArgsPresent_maybe tup_args+      = mkCTuple (oparens ++ [EpTok ap_open], EpTok ap_close : cparens, cs) es+    check (opi, cpi, csi) (L _ (HsPar (open_tok, close_tok) expr))+      = check (opi ++ [open_tok], close_tok : cpi, csi) expr+    check (oparens,cparens,cs) (L _ (HsVar _ (L (EpAnn _ (NameAnnOnly (NameParens open closed) []) _) name)))+      | name == nameRdrName (dataConName unitDataCon)+      = mkCTuple (oparens ++ [open], closed : cparens, cs) []+    check _ _ = unprocessed++    unprocessed =+      return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_expr])++    mkCTuple (oparens, cparens, cs) ts =+      -- Append parens so that the original order in the source is maintained+      return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts)++checkImportDecl :: Maybe (EpToken "qualified")+                -> Maybe (EpToken "qualified")+                -> 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++  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit++  -- Error if 'qualified' found in postpositive position and+  -- 'ImportQualifiedPost' is not in effect.+  whenJust mPost $ \post ->+    when (not importQualifiedPostEnabled) $+      failNotEnabledImportQualifiedPost (tokenSpan post)++  -- Error if 'qualified' occurs in both pre and postpositive+  -- positions.+  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.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)+checkPattern = runPV . checkLPat++checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)+checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)++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) []+  return (L (addCommentsToEpAnn l' cs) p')++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))) 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 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)) 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+  p <- checkAPat loc e+  return (L l p, cs)+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+ case e0 of+   PatBuilderPat p -> return p+   PatBuilderVar x -> return (VarPat noExtField x)++   -- Overloaded numeric patterns (e.g. f 0 x = x)+   -- Negation is recorded separately, so that the literal is zero or +ve+   -- NB. Negative *primitive* literals are already handled by the lexer+   PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)++   -- n+k patterns+   PatBuilderOpApp+           (L _ (PatBuilderVar (L nloc n)))+           (L l plus)+           (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))+           _+                     | nPlusKPatterns && (plus == plus_RDR)+                     -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)+                                (EpTok $ entry l))++   -- Improve error messages for the @-operator when the user meant an @-pattern+   PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do+     addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos+     return (WildPat noExtField)++   PatBuilderOpApp l (L cl c) r (_os,_cs)+     | isRdrDataCon c || isRdrTc c -> do+         l <- checkLPat l+         r <- checkLPat r+         return $ ConPat+           { pat_con_ext = noAnn+           , pat_con = L cl c+           , pat_args = InfixCon l r+           }++   PatBuilderPar lpar e rpar -> do+     p <- checkLPat e+     return (ParPat (lpar, rpar) p)++   _           -> do+     details <- fromParseContext <$> askParseContext+     patFail (locA loc) (PsErrInPat e0 details)++placeHolderPunRhs :: DisambECP b => PV (LocatedA b)+-- The RHS of a punned record field will be filled in by the renamer+-- It's better not to make it an error, in case we want to print it when+-- debugging+placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)++plus_RDR, pun_RDR :: RdrName+plus_RDR = mkUnqual varName (fsLit "+") -- Hack+pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")++checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))+              -> PV (LHsRecField GhcPs (LPat GhcPs))+checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)+                             return (L l (fld { hfbRHS = p }))++patFail :: SrcSpan -> PsMessage -> PV a+patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg++patIsRec :: RdrName -> Bool+patIsRec e = e == mkUnqual varName (fsLit "rec")++---------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SrcSpan+            -> LocatedA (PatBuilder GhcPs)+            -> (HsMultAnn GhcPs, Maybe (TokDcolon, LHsType GhcPs))+            -> Located (GRHSs GhcPs (LHsExpr GhcPs))+            -> P (HsBind GhcPs)++checkValDef loc lhs (mult, Just (sigAnn, sig)) grhss+        -- x :: ty = rhs  parses as a *pattern* binding+  = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig sigAnn+                        >>= checkLPat+       checkPatBind loc lhs' grhss mult++checkValDef loc lhs (mult_ann, Nothing) grhss+  | HsUnannotated{} <- mult_ann+  = do  { mb_fun <- isFunLhs lhs+        ; case mb_fun of+            Just (fun, is_infix, pats, ops, cps) -> do+              let ann_fun = mk_ann_funrhs ops cps+              let l = listLocation pats+              checkFunBind loc ann_fun+                           fun is_infix (L l pats) grhss+            Nothing -> do+              lhs' <- checkPattern lhs+              checkPatBind loc lhs' grhss mult_ann }++checkValDef loc lhs (mult_ann, Nothing) ghrss+        -- %p x = rhs  parses as a *pattern* binding+  = do lhs' <- checkPattern lhs+       checkPatBind loc lhs' ghrss mult_ann++mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs+mk_ann_funrhs ops cps = AnnFunRhs NoEpTok ops cps++checkFunBind :: SrcSpan+             -> AnnFunRhs+             -> LocatedN RdrName+             -> LexicalFixity+             -> 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 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+                                      , m_ctxt = FunRhs+                                          { mc_fun    = L lf fun+                                          , mc_fixity = is_infix+                                          , mc_strictness = NoSrcStrict+                                          , mc_an = ann_fun }+                                      , m_pats = L lp ps+                                      , m_grhss = grhss })]))+        -- The span of the match covers the entire equation.+        -- That isn't quite right, but it'll do for now.+  where+    extraDetails+      | Infix <- is_infix = ParseContext (Just fun) NoIncompleteDoBlock+      | otherwise         = noParseContext++makeFunBind :: LocatedN RdrName -> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)]+            -> HsBind GhcPs+-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too+makeFunBind fn ms+  = FunBind { fun_ext = noExtField,+              fun_id = fn,+              fun_matches = mkMatchGroup FromSource ms }++-- See Note [FunBind vs PatBind]+checkPatBind :: SrcSpan+             -> LPat GhcPs+             -> Located (GRHSs GhcPs (LHsExpr GhcPs))+             -> HsMultAnn GhcPs+             -> P (HsBind GhcPs)+checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v))))+                        (L _match_span grhss) (HsUnannotated _)+      = return (makeFunBind v (L (noAnnSrcSpan loc)+                [L (noAnnSrcSpan loc) (m an v)]))+  where+    m a v = Match { m_ext = noExtField+                  , m_ctxt = FunRhs { mc_fun    = v+                                    , mc_fixity = Prefix+                                    , mc_strictness = SrcStrict+                                    , mc_an = AnnFunRhs a [] [] }+                  , m_pats = noLocA []+                 , m_grhss = grhss }++checkPatBind _loc lhs (L _ grhss) mult = do+  return (PatBind noExtField lhs mult grhss)+++checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)+checkValSigLhs lhs@(L l lhs_expr) =+  case lhs_expr of+    HsVar _ lrdr@(L _ v) -> check_var v lrdr+    _                    -> make_err PsErrInvalidTypeSig_Other+  where+    check_var v lrdr+      | not (isUnqual v) = make_err PsErrInvalidTypeSig_Qualified+      | isDataOcc occ_n  = make_err PsErrInvalidTypeSig_DataCon+      | otherwise        = pure lrdr+      where occ_n = rdrNameOcc v+    make_err reason = addFatalError $+      mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs)+++checkDoAndIfThenElse+  :: (Outputable a, Outputable b, Outputable c)+  => (a -> Bool -> b -> Bool -> c -> PsMessage)+  -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()+checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr+ | semiThen || semiElse = do+      doAndIfThenElse <- getBit DoAndIfThenElseBit+      let e   = err (unLoc guardExpr)+                    semiThen (unLoc thenExpr)+                    semiElse (unLoc elseExpr)+          loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)++      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)+  | otherwise = return ()++isFunLhs :: LocatedA (PatBuilder GhcPs)+      -> P (Maybe (LocatedN RdrName, LexicalFixity,+                   [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+   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) (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+      -- of funlhs.+     where+       (_l, le') = transferCommentsOnlyA l le+       (o,c) = mkParensEpToks (realSrcSpan $ locA l)+   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, ((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 k : es', ops', cps')+            = Just (op', Infix, j : op_app : es', ops', cps')+            where+              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) (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++mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs+mkBangTy tok_loc strictness lty =+  XHsType (HsBangTy (noAnn, noAnn, tok_loc) (HsSrcBang NoSourceText NoSrcUnpack strictness) lty)++-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.+data UnpackednessPragma =+  UnpackednessPragma (EpaLocation, EpToken "#-}") SourceText SrcUnpackedness++-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.+addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)+addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do+    let l' = combineSrcSpans lprag (getLocA ty)+    let t' = addUnpackedness anns ty+    return (L (noAnnSrcSpan l') t')+  where+    -- If we have a HsBangTy that only has a strictness annotation,+    -- 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 _ (XHsType (HsBangTy (_,_,tl) bang t)))+      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang+      = XHsType (HsBangTy (o,c,tl) (HsSrcBang prag unpk strictness) t)+    addUnpackedness (o,c) t+      = XHsType (HsBangTy (o,c,noAnn) (HsSrcBang prag unpk NoSrcStrict) t)++---------------------------------------------------------------------------+-- | Check for monad comprehensions+--+-- If the flag MonadComprehensions is set, return a 'MonadComp' context,+-- otherwise use the usual 'ListComp' context++checkMonadComp :: PV HsDoFlavour+checkMonadComp = do+    monadComprehensions <- getBit MonadComprehensionsBit+    return $ if monadComprehensions+                then MonadComp+                else ListComp++-- -------------------------------------------------------------------------+-- Expression/command/pattern ambiguity.+-- See Note [Ambiguous syntactic categories]+--++-- See Note [Ambiguous syntactic categories]+--+-- This newtype is required to avoid impredicative types in monadic+-- productions. That is, in a production that looks like+--+--    | ... {% return (ECP ...) }+--+-- we are dealing with+--    P ECP+-- whereas without a newtype we would be dealing with+--    P (forall b. DisambECP b => PV (Located b))+--+newtype ECP =+  ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) }++ecpFromExp :: LHsExpr GhcPs -> ECP+ecpFromExp a = ECP (ecpFromExp' a)++ecpFromCmd :: LHsCmd GhcPs -> ECP+ecpFromCmd a = ECP (ecpFromCmd' a)++ecpFromPat :: LPat GhcPs -> ECP+ecpFromPat a = ECP (ecpFromPat' a)++-- The 'fbinds' parser rule produces values of this type. See Note+-- [RecordDotSyntax field updates].+type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))++-- | Disambiguate infix operators.+-- See Note [Ambiguous syntactic categories]+class DisambInfixOp b where+  mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)+  mkHsConOpPV :: LocatedN RdrName -> 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 v = return $ L (getLoc v) (HsHole (HoleVar v))++instance DisambInfixOp RdrName where+  mkHsConOpPV (L l v) = return $ L l v+  mkHsVarOpPV (L l v) = return $ L l v+  mkHsInfixHolePV (L l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole++type AnnoBody b+  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO+    , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnLW+    , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA+    , Anno [LocatedA (StmtLR GhcPs GhcPs+                       (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW+    )++-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are+-- parsing an expression, a command, or a pattern.+-- See Note [Ambiguous syntactic categories]+class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where+  -- | See Note [Body in DisambECP]+  type Body b :: Type -> Type+  -- | Return a command without ambiguity, or fail in a non-command context.+  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)+  -- | Return an expression without ambiguity, or fail in a non-expression context.+  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 (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))+    -> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b))+  -- | Disambiguate "let ... in ..."+  mkHsLetPV+    :: SrcSpan+    -> EpToken "let"+    -> HsLocalBinds GhcPs+    -> EpToken "in"+    -> LocatedA b+    -> PV (LocatedA b)+  -- | Infix operator representation+  type InfixOp b+  -- | Bring superclass constraints on InfixOp into scope.+  -- See Note [UndecidableSuperClasses for associated types]+  superInfixOp+    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)+  -- | Disambiguate "f # x" (infix operator)+  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b+              -> PV (LocatedA b)+  -- | Disambiguate "case ... of ..."+  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedLW [LMatch GhcPs (LocatedA b)])+             -> EpAnnHsCase -> PV (LocatedA b)+  -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases"+  mkHsLamPV :: SrcSpan -> HsLamVariant+            -> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnLam+            -> PV (LocatedA b)+  -- | Function argument representation+  type FunArg b+  -- | Bring superclass constraints on FunArg into scope.+  -- See Note [UndecidableSuperClasses for associated types]+  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)+  -- | Disambiguate "f x" (function application)+  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)+  -- | Disambiguate "f @t" (visible type application)+  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate "if ... then ... else ..."+  mkHsIfPV :: SrcSpan+         -> LHsExpr GhcPs+         -> Bool  -- semicolon?+         -> LocatedA b+         -> Bool  -- semicolon?+         -> LocatedA b+         -> AnnsIf+         -> PV (LocatedA b)+  -- | Disambiguate "do { ... }" (do notation)+  mkHsDoPV ::+    SrcSpan ->+    Maybe ModuleName ->+    LocatedLW [LStmt GhcPs (LocatedA b)] ->+    EpaLocation -> -- Token+    EpaLocation -> -- Anchor+    PV (LocatedA b)+  -- | Disambiguate "( ... )" (parentheses)+  mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)+  -- | Disambiguate a variable "f" or a data constructor "MkF".+  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)+  -- | Disambiguate a monomorphic literal+  mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b)+  -- | Disambiguate an overloaded literal+  mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)+  -- | Disambiguate a wildcard+  mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b)+  -- | Disambiguate "a :: t" (type annotation)+  mkHsTySigPV+    :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b)+  -- | Disambiguate "[a,b,c]" (list syntax)+  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList () -> PV (LocatedA b)+  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)+  mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b)+  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)+  mkHsRecordPV ::+    Bool -> -- Is OverloadedRecordUpdate in effect?+    SrcSpan ->+    SrcSpan ->+    LocatedA b ->+    ([Fbind b], Maybe SrcSpan) ->+    (Maybe (EpToken "{"), Maybe (EpToken "}")) ->+    PV (LocatedA b)+  -- | Disambiguate "-a" (negation)+  mkHsNegAppPV :: SrcSpan -> LocatedA b -> EpToken "-" -> PV (LocatedA b)+  -- | Disambiguate "(# a)" (right operator section)+  mkHsSectionR_PV+    :: 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 -> HsMultAnnOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)+  -- | Disambiguate "%m" to the left of "->" (multiplicity)+  mkHsMultPV+    :: 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)+  checkContextPV :: LocatedA b -> PV (LocatedC [LocatedA b])+  -- | Disambiguate "a => b" (constraint context)+  mkQualPV :: SrcSpan -> LocatedC [LocatedA b] -> LocatedA b -> PV (LocatedA b)+  -- | Disambiguate "a@b" (as-pattern)+  mkHsAsPatPV+    :: SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b)+  -- | Disambiguate "~a" (lazy pattern)+  mkHsLazyPatPV :: SrcSpan -> LocatedA b -> EpToken "~" -> PV (LocatedA b)+  -- | Disambiguate "!a" (bang pattern)+  mkHsBangPatPV :: SrcSpan -> LocatedA b -> EpToken "!" -> PV (LocatedA b)+  -- | Disambiguate tuple sections and unboxed sums+  mkSumOrTuplePV+    :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> (EpaLocation, EpaLocation) -> PV (LocatedA b)+  -- | Disambiguate "type t" (embedded type)+  mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)+  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas+  rejectPragmaPV :: LocatedA b -> PV ()++{- Note [UndecidableSuperClasses for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This Note is about the code in GHC, not about the user code that we are parsing)++Assume we have a class C with an associated type T:++  class C a where+    type T a+    ...++If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:++  {-# LANGUAGE UndecidableSuperClasses #-}+  class C (T a) => C a where+    type T a+    ...++Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes+making GHC loop. The workaround is to bring this constraint into scope+manually with a helper method:++  class C a where+    type T a+    superT :: (C (T a) => r) -> r++In order to avoid ambiguous types, 'r' must mention 'a'.++For consistency, we use this approach for all constraints on associated types,+even when -XUndecidableSuperClasses are not required.+-}++{- Note [Body in DisambECP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that+require their argument to take a form of (body GhcPs) for some (body :: Type ->+*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the+superclass constraints of DisambECP.++The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop+this requirement. It is possible and would allow removing the type index of+PatBuilder, but leads to worse type inference, breaking some code in the+typechecker.+-}++instance DisambECP (HsCmd GhcPs) where+  type Body (HsCmd GhcPs) = HsCmd+  ecpFromCmd' = return+  ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)+  ecpFromPat' (L l p) = cmdFail (locA l) (ppr p)+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $+                                                 PsErrOverloadedRecordDotInvalid+  mkHsLamPV l lam_variant (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg)++  mkHsLetPV l tkLet bs tkIn e = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e)++  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs++  superInfixOp m = m++  mkHsOpAppPV l c1 op c2 = do+    let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm noAnn (reLoc op) Infix [cmdArg c1, cmdArg c2]++  mkHsCasePV l c (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg)++  type FunArg (HsCmd GhcPs) = HsExpr GhcPs+  superFunArg m = m+  mkHsAppPV l c e = do+    checkCmdBlockArguments c+    checkExpBlockArguments e+    return $ L l (HsCmdApp noExtField c e)+  mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)+  mkHsIfPV l c semi1 a semi2 b anns = do+    checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)+  mkHsDoPV l Nothing stmts tok_loc anc = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts)+  mkHsDoPV l (Just m)    _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m+  mkHsParPV l lpar c rpar = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)+  mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)+  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 <+> dcolon <+> ppr sig)+  mkHsExplicitListPV l xs _ = cmdFail l $+    brackets (pprWithCommas ppr xs)+  mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)+  mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do+    let (fs, ps) = partitionEithers fbinds+    if not (null ps)+      then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid+      else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)+  mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)+  mkHsSectionR_PV l op c = cmdFail l $+    let pp_op = fromMaybe (panic "cannot print infix operator")+                          (ppr_infix_expr (unLoc op))+    in pp_op <> ppr c+  mkHsArrowPV l mode a arr b = cmdFail l $+    case mode of  -- matching on the mode brings Outputable instances into scope+      ArrowIsViewPat -> ppr a <+> pprHsArrow arr <+> ppr b+      ArrowIsFunType -> ppr a <+> pprHsArrow arr <+> ppr b+  mkHsMultPV pct mult = cmdFail l $+    ppr pct <> ppr mult+    where l = getHasLoc pct `combineSrcSpans` getHasLoc mult+  mkHsForallPV l tele cmd = cmdFail l $+    pprHsForAll tele Nothing <+> ppr cmd+  checkContextPV ctxt = cmdFail (getLocA ctxt) $ ppr ctxt+  mkQualPV l ctxt cmd = cmdFail l $+    ppr ctxt <+> text "=>" <+> ppr cmd+  mkHsAsPatPV l v _ c = cmdFail l $+    pprPrefixOcc (unLoc v) <> text "@" <> ppr c+  mkHsLazyPatPV l c _ = cmdFail l $+    text "~" <> ppr c+  mkHsBangPatPV l c _ = cmdFail l $+    text "!" <> ppr c+  mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)+  mkHsEmbTyPV l _ ty = cmdFail l (text "type" <+> ppr ty)+  rejectPragmaPV _ = return ()++cmdFail :: SrcSpan -> SDoc -> PV a+cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e++checkLamMatchGroup :: SrcSpan -> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()+checkLamMatchGroup l LamSingle (MG { mg_alts = (L _ (matches:_))}) = do+  when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda+checkLamMatchGroup _ _ _ = return ()++instance DisambECP (HsExpr GhcPs) where+  type Body (HsExpr GhcPs) = HsExpr+  ecpFromCmd' (L l c) = do+    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c+    return (L l parseError)+  ecpFromExp' = return+  ecpFromPat' p@(L l _) = do+    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrOrPatInExpr p+    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+  mkHsLetPV l tkLet bs tkIn c = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c)+  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs+  superInfixOp m = m+  mkHsOpAppPV l e1 op e2 = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp noExtField e1 (reLoc op) e2+  mkHsCasePV l e (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg)+  mkHsLamPV l lam_variant (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)+    checkLamMatchGroup l lam_variant mg+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg)+  type FunArg (HsExpr GhcPs) = HsExpr GhcPs+  superFunArg m = m+  mkHsAppPV l e1 e2 = do+    checkExpBlockArguments e1+    checkExpBlockArguments e2+    return $ L l (HsApp noExtField e1 e2)+  mkHsAppTypePV l e at t = do+    checkExpBlockArguments e+    return $ L l (HsAppType at e (mkHsWildCardBndrs t))+  mkHsIfPV l c semi1 a semi2 b anns = do+    checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)+  mkHsDoPV l mod stmts loc_tok anc = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts)+  mkHsParPV l lpar e rpar = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)+  mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do+    !cs <- getCommentsFor (getHasLoc l)+    return $ L (EpAnn anc noAnn cs) (HsVar noExtField v)+  mkHsLitPV (L l a) = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a)+  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) (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))+  mkHsExplicitListPV l xs anns = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs)+  mkHsSplicePV (L l a) = do+    !cs <- getCommentsFor l+    return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a)+  mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do+    !cs <- getCommentsFor l+    r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns+    checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)+  mkHsNegAppPV l a anns = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr)+  mkHsSectionR_PV l op e = do+    !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) parseError)+  mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)+                          >> return (L (noAnnSrcSpan l) parseError)+  mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)+                          >> return (L (noAnnSrcSpan l) parseError)+  mkSumOrTuplePV = mkSumOrTupleExpr+  mkHsEmbTyPV l toktype ty =+    return $ L (noAnnSrcSpan l) $+      HsEmbTy toktype (mkHsWildCardBndrs ty)+  mkHsArrowPV l mode arg arr res =+    -- In expressions, (e1 -> e2) is always parsed as a function type,+    -- even if ViewPatterns are enabled.+    exprArrowParsingMode mode $+    return $ L (noAnnSrcSpan l) $+      HsFunArr noExtField arr arg res+  mkHsMultPV pct t =+    return $ mkMultExpr pct t+  mkHsForallPV l telescope ty =+    return $ L (noAnnSrcSpan l) $+      HsForAll noExtField (setTelescopeBndrsNameSpace varName telescope) ty+  checkContextPV = checkContextExpr+  mkQualPV l qual ty =+    return $ L (noAnnSrcSpan l) $+      HsQual noExtField qual ty+  rejectPragmaPV (L _ (OpApp _ _ _ e)) =+    -- assuming left-associative parsing of operators+    rejectPragmaPV e+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $+                                                         (PsErrUnallowedPragma prag)+  rejectPragmaPV _                        = return ()++instance DisambECP (PatBuilder GhcPs) where+  type Body (PatBuilder GhcPs) = PatBuilder+  ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c+  ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e+  ecpFromPat' (L l p)    = return $ L l (PatBuilderPat p)+  mkHsLetPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid+  type InfixOp (PatBuilder GhcPs) = RdrName+  superInfixOp m = m+  mkHsOpAppPV l p1 op p2 = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[])++  mkHsLamPV l lam_variant _ _     = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)++  mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat+  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs+  superFunArg m = m+  mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)+  mkHsAppTypePV l p at t = do+    !cs <- getCommentsFor (locA l)+    return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))+  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat+  mkHsDoPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat+  mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)+  mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)+  mkHsLitPV lit@(L l a) = do+    checkUnboxedLitPat lit+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a))+  mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)+  mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField))+  mkHsTySigPV l p t anns = do+    p' <- checkLPat p+    let sig = mkHsPatSigType noAnn t+    sig_pat <- addSigPatP l p' sig anns+    return $ fmap PatBuilderPat sig_pat+  mkHsExplicitListPV l xs anns = do+    ps <- traverse checkLPat xs+    !cs <- getCommentsFor l+    return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps)))+  mkHsSplicePV (L l sp) = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp))+  mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do+    let (fs, ps) = partitionEithers fbinds+    if not (null ps)+     then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid+     else do+       !cs <- getCommentsFor l+       r <- mkPatRec a (mk_rec_fields fs ddLoc) anns+       checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)+  mkHsNegAppPV l (L lp p) anns = do+    lit <- case p of+      PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)+      _ -> patFail l $ PsErrInPat p PEIP_NegApp+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns))+  mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))+  mkHsArrowPV l ArrowIsViewPat a arr b = do+      p <- checkLPat b+      !cs <- getCommentsFor l+      return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat tok a p))+    where+      tok :: TokRarrow+      tok = case arr of+        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 HsUnannotated"+  mkHsArrowPV l ArrowIsFunType a arr b =+    patFail l (PsErrTypeSyntaxInPat (PETS_FunctionArrow a arr b))+  mkHsMultPV tok arg =+    let l = getHasLoc tok `combineSrcSpans` getLocA arg in+    patFail l (PsErrTypeSyntaxInPat (PETS_Multiplicity tok arg))+  mkHsForallPV l tele body = patFail l (PsErrTypeSyntaxInPat (PETS_ForallTelescope tele body))+  checkContextPV ctx = patFail (getLocA ctx) (PsErrTypeSyntaxInPat (PETS_ConstraintContext ctx))+  mkQualPV _ _ _ =  -- unreachable because mkQualPV is only called on the result+                    -- of checkContextPV, which fails in patterns+                  panic "mkQualPV in a pattern"+  mkHsAsPatPV l v at e = do+    p <- checkLPat e+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p))+  mkHsLazyPatPV l e a = do+    p <- checkLPat e+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p))+  mkHsBangPatPV l e an = do+    p <- checkLPat e+    !cs <- getCommentsFor l+    let pb = BangPat an p+    hintBangPat l pb+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb)+  mkSumOrTuplePV = mkSumOrTuplePat+  mkHsEmbTyPV l toktype ty =+    return $ L (noAnnSrcSpan l) $+      PatBuilderPat (EmbTyPat toktype (mkHsTyPat ty))+  rejectPragmaPV _ = return ()++-- For reasons of backwards compatibility, we can't simply add the pattern+-- signature if the inner pattern is a view pattern. Consider:+--      (f -> p :: t)+-- There are two ways to parse it+--      (f -> (p :: t))   -- legacy parse+--      ((f -> p) :: t)   -- future parse+-- The grammar in Parser.y is structured in such a way that we get the+-- future parse by default. Until we're ready to make the breaking change,+-- we need to do some extra work here to push the signature under the view+-- pattern (and emit a warning).+addSigPatP :: SrcSpanAnnA -> LPat GhcPs -> HsPatSigType GhcPs -> TokDcolon -> PV (LPat GhcPs)+addSigPatP l viewpat@(L _ ViewPat{}) sig anns =+  -- Test case: T24159_viewpat+  do { let futureParse = L l (SigPat anns viewpat sig)+     ; legacyParse <- go viewpat+     ; addPsMessage (locA l) (PsWarnViewPatternSignatures legacyParse futureParse)+     ; return legacyParse }+  where+    sig_loc_no_comments :: SrcSpan+    sig_loc_no_comments = getLocA (hsps_body sig)++    -- Test case for comments and locations preservation: Test24159+    go :: LPat GhcPs -> PV (LPat GhcPs)+    go  (L (EpAnn (EpaSpan view_pat_loc) anns cs1) (ViewPat anns' e' p')) = do+      sig' <- go  p'+      let new_loc = view_pat_loc `combineSrcSpans` sig_loc_no_comments+      cs2 <- getCommentsFor new_loc+      let ep_ann_loc = EpAnn (spanAsAnchor new_loc) anns (cs1 Semi.<> cs2)+      pure (L ep_ann_loc (ViewPat anns' e' sig'))++    go p = pure $ L new_loc (SigPat anns p sig)+      where new_loc = noAnnSrcSpan ((getLocA p) `combineSrcSpans` sig_loc_no_comments)++addSigPatP l p sig anns = do+  return $ L l (SigPat anns p sig)++{- Note [Arrow parsing mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example:+  f (K (a -> b)) = ()++A pattern of the form (a -> b) could be parsed in one of two ways:+  * a view pattern `viewfn -> pat` (with ViewPatterns)+  * a function type `t1 -> t2`     (with RequiredTypeArguments)++This depends on the enabled extensions:+  NoViewPatterns, RequiredTypeArguments     =>  function type+  NoViewPatterns, NoRequiredTypeArguments   =>  error (suggest ViewPatterns)+  ViewPatterns,   RequiredTypeArguments     =>  view pattern+  ViewPatterns,   NoRequiredTypeArguments   =>  view pattern++The decision how to parse arrow patterns (p1 -> p2) is captured by the+`ArrowParsingMode` data type, produced in `withArrowParsingMode` and+consumed in `mkHsArrowPV`.++Naively, one might expect to see the following definition:++  -- a simple (but insufficient) definition+  data ArrowParsingMode = ArrowIsViewPat | ArrowIsFunType++However, there is a slight complication that leads us to parameterize these+constructor with GADT type indices. In a pattern (p1 -> p2), what is the AST+type to represent the LHS `p1`? It depends:+  * if (p1 -> p2) is a view pattern,  `p1` is an HsExpr+  * if (p1 -> p2) is a function type, `p1` is a  Pat (PatBuilder)++And since the decision how to parse `p1` depends on the arrow parsing mode, we+could try to encode the LHS type as a GADT index:++  -- a less simple (but still insufficient) definition+  data ArrowParsingMode lhs where+    ArrowIsViewPat :: ArrowParsingMode (PatBuilder GhcPs)+    ArrowIsFunType :: ArrowParsingMode (HsExpr GhcPs)++This definition would suffice for parsing patterns, but remember that+expressions, commands, and patterns are all parsed using a unified framework+`DisambECP`, as described in Note [Ambiguous syntactic categories].++In an expression (e1 -> e2), the LHS is always represented by an HsExpr.+We can account for this with a further refinement of the definition:++  -- actual definition+  data ArrowParsingMode lhs rhs where+    ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b+    ArrowIsFunType :: ArrowParsingMode b b++So when parsing a view pattern, the LHS is an HsExpr; and when parsing a+function type, the type of the LHS is assumed to match the type of the RHS,+which works out just right both for expressions and patterns.+-}++-- The arrow parsing mode is selected depending on the enabled extensions and+-- determines how we parse patterns of the form (p1 -> p2). See Note [Arrow parsing mode]+data ArrowParsingMode lhs rhs where+  ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b   -- the LHS is always of type HsExpr+  ArrowIsFunType :: ArrowParsingMode b b                -- the LHS is of the same type as RHS++-- When parsing an expression (e1 -> e2), the LHS `e1` is an HsExpr regardless of+-- the arrow parsing mode. `exprArrowParsingMode` proves this to the type checker.+-- See Note [Arrow parsing mode]+exprArrowParsingMode :: ArrowParsingMode lhs (HsExpr GhcPs) -> (lhs ~ HsExpr GhcPs => r) -> r+exprArrowParsingMode ArrowIsViewPat k = k+exprArrowParsingMode ArrowIsFunType k = k++-- Check the enabled extensions and select the appropriate ArrowParsingMode,+-- then pass it to a continuation. See Note [Arrow parsing mode]+withArrowParsingMode :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r) -> PV r+withArrowParsingMode cont = do+  vpEnabled <- getBit ViewPatternsBit+  rtaEnabled <- getBit RequiredTypeArgumentsBit+  if | vpEnabled  -> cont ArrowIsViewPat+     | rtaEnabled -> cont ArrowIsFunType+     | otherwise  -> cont ArrowIsViewPat -- Error message should suggest ViewPatterns in patterns++-- Type-restricted variant of `withArrowParsingMode` to aid type inference (#25103)+withArrowParsingMode' :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV (LocatedA b)) -> PV (LocatedA b)+withArrowParsingMode' = withArrowParsingMode++-- When a forall-type occurs in term syntax, forall-bound variables should+-- inhabit the term namespace `varName` rather than the usual `tvName`.+-- See Note [Types in terms].+--+-- Since type variable binders in a `HsForAllTelescope` produced by the+-- `forall_telescope` nonterminal have their namespaces set to `tvName`,+-- we use `setTelescopeBndrsNameSpace` to fix them up.+setTelescopeBndrsNameSpace :: NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs+setTelescopeBndrsNameSpace ns forall_telescope =+  case forall_telescope of+    HsForAllInvis x bndrs -> HsForAllInvis x (set_bndrs_ns bndrs)+    HsForAllVis   x bndrs -> HsForAllVis   x (set_bndrs_ns bndrs)+  where+    set_bndrs_ns :: [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs]+    set_bndrs_ns = map (setLHsTyVarBndrNameSpace ns)++setLHsTyVarBndrNameSpace :: NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs+setLHsTyVarBndrNameSpace ns (L l tvb) = L l tvb'+  where tvb' = tvb { tvb_var = setHsBndrVarNameSpace ns (tvb_var tvb) }++setHsBndrVarNameSpace :: NameSpace -> HsBndrVar GhcPs -> HsBndrVar GhcPs+setHsBndrVarNameSpace ns (HsBndrVar x (L l rdr)) = HsBndrVar x (L l rdr')+  where rdr' = setRdrNameSpace rdr ns+setHsBndrVarNameSpace _ (HsBndrWildCard x) = HsBndrWildCard x++-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.+checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()+checkUnboxedLitPat (L loc lit) =+  case lit of+    -- Don't allow primitive string literal patterns.+    -- See #13260.+    HsStringPrim {}+      -> addError $ mkPlainErrorMsgEnvelope loc $+                           (PsErrIllegalUnboxedStringInPat lit)++   -- Don't allow Float#/Double# literal patterns.+   -- See #9238 and Note [Rules for floating-point comparisons]+   -- in GHC.Core.Opt.ConstantFold.+    _ | is_floating_lit lit+      -> addError $ mkPlainErrorMsgEnvelope loc $+                           (PsErrIllegalUnboxedFloatingLitInPat lit)++      | otherwise+      -> return ()++  where+    is_floating_lit :: HsLit GhcPs -> Bool+    is_floating_lit (HsFloatPrim  {}) = True+    is_floating_lit (HsDoublePrim {}) = True+    is_floating_lit _                 = False++mkPatRec ::+  LocatedA (PatBuilder GhcPs) ->+  HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->+  (Maybe (EpToken "{"), Maybe (EpToken "}")) ->+  PV (PatBuilder GhcPs)+mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields x fs dd) anns+  | isRdrDataCon (unLoc c)+  = do fs <- mapM checkPatField fs+       return $ PatBuilderPat $ ConPat+         { pat_con_ext = anns+         , pat_con = c+         , pat_args = RecCon (HsRecFields x fs dd)+         }+mkPatRec p _ _ =+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+                    (PsErrInvalidRecordCon (unLoc p))++-- | Disambiguate constructs that may appear when we do not know+-- ahead of time whether we are parsing a type or a newtype/data constructor.+--+-- See Note [Ambiguous syntactic categories] for the general idea.+--+-- See Note [Parsing data constructors is hard] for the specific issue this+-- particular class is solving.+--+class DisambTD b where+  -- | Process the head of a type-level function/constructor application,+  -- i.e. the @H@ in @H a b c@.+  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f x@ (function application or prefix data constructor).+  mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f \@t@ (visible kind application)+  mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f \# x@ (infix operator)+  mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)+  mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)++instance DisambTD (HsType GhcPs) where+  mkHsAppTyHeadPV = return+  mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)+  mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)+  mkHsOpTyPV prom t1 op t2 = do+    let (L l ty) = mkLHsOpTy prom t1 op t2+    !cs <- getCommentsFor (locA l)+    return (L (addCommentsToEpAnn l cs) ty)+  mkUnpackednessPV = addUnpackednessP++dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName+dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc+dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc++dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs++-- Detect when the record syntax is used:+--   data T = MkT { ... }+dataConBuilderDetails (L _ (PrefixDataConBuilder 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 (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 (hsPlainTypeField (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsPlainTypeField rhs)+++instance DisambTD DataConBuilder where+  mkHsAppTyHeadPV = tyToDataConBuilder++  mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =+    return $+      L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))+        (PrefixDataConBuilder (flds `snocOL` t) fn)+  mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =+    -- This case is impossible because of the way+    -- the grammar in Parser.y is written (see infixtype/ftype).+    panic "mkHsAppTyPV: InfixDataConBuilder"++  mkHsAppKindTyPV lhs at ki =+    addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $+                      (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))++  mkHsOpTyPV prom lhs tc rhs = do+      check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative+      data_con <- eitherToP $ tyConToDataCon tc+      !cs <- getCommentsFor (locA l)+      checkNotPromotedDataCon prom data_con+      return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)+    where+      l = combineLocsA lhs rhs+      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))+      check_no_ops _ = return ()++  mkUnpackednessPV unpk constr_stuff+    | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff+    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool+      --   we apply {-# UNPACK #-} to the LHS+      do lhs' <- addUnpackednessP unpk lhs+         let l = combineLocsA (reLoc unpk) constr_stuff+         return $ L l (InfixDataConBuilder lhs' data_con rhs)+    | otherwise =+      do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon+         return constr_stuff++tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)+tyToDataConBuilder (L l (HsTyVar _ prom v)) = do+  data_con <- eitherToP $ tyConToDataCon v+  checkNotPromotedDataCon prom data_con+  return $ L l (PrefixDataConBuilder nilOL data_con)+tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do+  let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))+  return $ L l (PrefixDataConBuilder (toOL ts) data_con)+tyToDataConBuilder (L l (HsTupleTy _ HsUnboxedTuple ts)) = do+  let data_con = L (l2l l) (getRdrName (tupleDataCon Unboxed (length ts)))+  return $ L l (PrefixDataConBuilder (toOL ts) data_con)+tyToDataConBuilder t =+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $+                    (PsErrInvalidDataCon (unLoc t))++-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).+checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()+checkNotPromotedDataCon NotPromoted _ = return ()+checkNotPromotedDataCon IsPromoted (L l name) =+  addError $ mkPlainErrorMsgEnvelope (locA l) $+    PsErrIllegalPromotionQuoteDataCon name++mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)+mkUnboxedSumCon t tag arity =+  (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon [hsPlainTypeField t])++{- Note [Ambiguous syntactic categories]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are places in the grammar where we do not know whether we are parsing an+expression or a pattern without unlimited lookahead (which we do not have in+'happy'):++View patterns:++    f (Con a b     ) = ...  -- 'Con a b' is a pattern+    f (Con a b -> x) = ...  -- 'Con a b' is an expression++do-notation:++    do { Con a b <- x } -- 'Con a b' is a pattern+    do { Con a b }      -- 'Con a b' is an expression++Guards:++    x | True <- p && q = ...  -- 'True' is a pattern+    x | True           = ...  -- 'True' is an expression++Top-level value/function declarations (FunBind/PatBind):++    f ! a         -- TH splice+    f ! a = ...   -- function declaration++    Until we encounter the = sign, we don't know if it's a top-level+    TemplateHaskell splice where ! is used, or if it's a function declaration+    where ! is bound.++There are also places in the grammar where we do not know whether we are+parsing an expression or a command:++    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression+    proc x -> do { (stuff) }        -- 'stuff' is a command++    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'+    as an expression or a command.++In fact, do-notation is subject to both ambiguities:++    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression+    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern+    proc x -> do { (stuff) }             -- 'stuff' is a command++There are many possible solutions to this problem. For an overview of the ones+we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]++The solution that keeps basic definitions (such as HsExpr) clean, keeps the+concerns local to the parser, and does not require duplication of hsSyn types,+or an extra pass over the entire AST, is to parse into an overloaded+parser-validator (a so-called tagless final encoding):++    class DisambECP b where ...+    instance DisambECP (HsCmd GhcPs) where ...+    instance DisambECP (HsExp GhcPs) where ...+    instance DisambECP (PatBuilder GhcPs) where ...++The 'DisambECP' class contains functions to build and validate 'b'. For example,+to add parentheses we have:++  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)++'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for+expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,+see Note [PatBuilder]).++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr GhcPs, and it becomes:++  alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Compared to the initial definition, the added bits are:++    forall b. DisambECP b => PV ( ... ) -- in the type signature+    $1 >>= \ $1 -> return $             -- in one reduction rule+    $2 >>= \ $2 -> return $             -- in another reduction rule++The overhead is constant relative to the size of the rest of the reduction+rule, so this approach scales well to large parser productions.++Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding+position and shadows the previous $1. We can do this because internally+'happy' desugars $n to happy_var_n, and the rationale behind this idiom+is to be able to write (sLL $1 $>) later on. The alternative would be to+write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer+to the last fresh name as $>.++Finally, we instantiate the polymorphic type to a concrete one, and run the+parser-validator, for example:++    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }+    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }+            : stmt {% runPV $1 }++In e_stmt, three things happen:++  1. we instantiate: b ~ HsExpr GhcPs+  2. we embed the PV computation into P by using runPV+  3. we run validation by using a monadic production, {% ... }++At this point the ambiguity is resolved.+-}+++{- Note [Resolving parsing ambiguities: non-taken alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Alternative I, extra constructors in GHC.Hs.Expr+------------------------------------------------+We could add extra constructors to HsExpr to represent command-specific and+pattern-specific syntactic constructs. Under this scheme, we parse patterns+and commands as expressions and rejig later.  This is what GHC used to do, and+it polluted 'HsExpr' with irrelevant constructors:++  * for commands: 'HsArrForm', 'HsArrApp'+  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'++(As of now, we still do that for patterns, but we plan to fix it).++There are several issues with this:++  * The implementation details of parsing are leaking into hsSyn definitions.++  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.++  * HsExpr is arbitrarily selected as the extension basis. Why not extend+    HsCmd or HsPat with extra constructors instead?++Alternative II, extra constructors in GHC.Hs.Expr for GhcPs+-----------------------------------------------------------+We could address some of the problems with Alternative I by using Trees That+Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to+the output of parsing, not to its intermediate results, so we wouldn't want+them there either.++Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs+---------------------------------------------------------------+We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.+Unfortunately, creating a new pass would significantly bloat conversion code+and slow down the compiler by adding another linear-time pass over the entire+AST. For example, in order to build HsExpr GhcPrePs, we would need to build+HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds+GhcPrePs.+++Alternative IV, sum type and bottom-up data flow+------------------------------------------------+Expressions and commands are disjoint. There are no user inputs that could be+interpreted as either an expression or a command depending on outer context:++  5        -- definitely an expression+  x -< y   -- definitely a command++Even though we have both 'HsLam' and 'HsCmdLam', we can look at+the body to disambiguate:++  \p -> 5        -- definitely an expression+  \p -> x -< y   -- definitely a command++This means we could use a bottom-up flow of information to determine+whether we are parsing an expression or a command, using a sum type+for intermediate results:++  Either (LHsExpr GhcPs) (LHsCmd GhcPs)++There are two problems with this:++  * We cannot handle the ambiguity between expressions and+    patterns, which are not disjoint.++  * Bottom-up flow of information leads to poor error messages. Consider++        if ... then 5 else (x -< y)++    Do we report that '5' is not a valid command or that (x -< y) is not a+    valid expression?  It depends on whether we want the entire node to be+    'HsIf' or 'HsCmdIf', and this information flows top-down, from the+    surrounding parsing context (are we in 'proc'?)++Alternative V, backtracking with parser combinators+---------------------------------------------------+One might think we could sidestep the issue entirely by using a backtracking+parser and doing something along the lines of (try pExpr <|> pPat).++Turns out, this wouldn't work very well, as there can be patterns inside+expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns+(e.g. view patterns). To handle this, we would need to backtrack while+backtracking, and unbound levels of backtracking lead to very fragile+performance.++Alternative VI, an intermediate data type+-----------------------------------------+There are common syntactic elements of expressions, commands, and patterns+(e.g. all of them must have balanced parentheses), and we can capture this+common structure in an intermediate data type, Frame:++data Frame+  = FrameVar RdrName+    -- ^ Identifier: Just, map, BS.length+  | FrameTuple [LTupArgFrame] Boxity+    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)+  | FrameTySig LFrame (LHsSigWcType GhcPs)+    -- ^ Type signature: x :: ty+  | FramePar (SrcSpan, SrcSpan) LFrame+    -- ^ Parentheses+  | FrameIf LFrame LFrame LFrame+    -- ^ If-expression: if p then x else y+  | FrameCase LFrame [LFrameMatch]+    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }+  | FrameDo HsStmtContextRn [LFrameStmt]+    -- ^ Do-expression: do { s1; a <- s2; s3 }+  ...+  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression+  | FramePat (HsPat GhcPs)     -- unambiguously a pattern+  | FrameCommand (HsCmd GhcPs) -- unambiguously a command++To determine which constructors 'Frame' needs to have, we take the union of+intersections between HsExpr, HsCmd, and HsPat.++The intersection between HsPat and HsExpr:++  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...+  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...+  -------------------------------------------------------------------+  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...++The intersection between HsCmd and HsExpr:++  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar+  HsExpr = HsIf    | HsCase    | HsDo    | HsPar+  ------------------------------------------------+  Frame = FrameIf  | FrameCase | FrameDo | FramePar++The intersection between HsCmd and HsPat:++  HsPat  = ParPat   | ...+  HsCmd  = HsCmdPar | ...+  -----------------------+  Frame  = FramePar | ...++Take the union of each intersection and this yields the final 'Frame' data+type. The problem with this approach is that we end up duplicating a good+portion of hsSyn:++    Frame         for  HsExpr, HsPat, HsCmd+    TupArgFrame   for  HsTupArg+    FrameMatch    for  Match+    FrameStmt     for  StmtLR+    FrameGRHS     for  GRHS+    FrameGRHSs    for  GRHSs+    ...++Alternative VII, a product type+-------------------------------+We could avoid the intermediate representation of Alternative VI by parsing+into a product of interpretations directly:++    type ExpCmdPat = ( PV (LHsExpr GhcPs)+                     , PV (LHsCmd GhcPs)+                     , PV (LHsPat GhcPs) )++This means that in positions where we do not know whether to produce+expression, a pattern, or a command, we instead produce a parser-validator for+each possible option.++Then, as soon as we have parsed far enough to resolve the ambiguity, we pick+the appropriate component of the product, discarding the rest:++    checkExpOf3 (e, _, _) = e  -- interpret as an expression+    checkCmdOf3 (_, c, _) = c  -- interpret as a command+    checkPatOf3 (_, _, p) = p  -- interpret as a pattern++We can easily define ambiguities between arbitrary subsets of interpretations.+For example, when we know ahead of type that only an expression or a command is+possible, but not a pattern, we can use a smaller type:++    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))++    checkExpOf2 (e, _) = e  -- interpret as an expression+    checkCmdOf2 (_, c) = c  -- interpret as a command++However, there is a slight problem with this approach, namely code duplication+in parser productions. Consider the 'alts' production used to parse case-of+alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Under the new scheme, we have to completely duplicate its type signature and+each reduction rule:++  alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression+            , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command+            ) }+    : alts1+        { ( checkExpOf2 $1 >>= \ $1 ->+            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)+          , checkCmdOf2 $1 >>= \ $1 ->+            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)+          ) }+    | ';' alts+        { ( checkExpOf2 $2 >>= \ $2 ->+            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)+          , checkCmdOf2 $2 >>= \ $2 ->+            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)+          ) }++And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',+'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!++Alternative VIII, a function from a GADT+----------------------------------------+We could avoid code duplication of the Alternative VII by representing the product+as a function from a GADT:++    data ExpCmdG b where+      ExpG :: ExpCmdG HsExpr+      CmdG :: ExpCmdG HsCmd++    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))++    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)+    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)+    checkExp f = f ExpG  -- interpret as an expression+    checkCmd f = f CmdG  -- interpret as a command++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr, and it becomes:++  alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1+        { \tag -> $1 tag >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts+        { \tag -> $2 tag >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Note that 'ExpCmdG' is a singleton type, the value is completely+determined by the type:++  when (b~HsExpr),  tag = ExpG+  when (b~HsCmd),   tag = CmdG++This is a clear indication that we can use a class to pass this value behind+the scenes:++  class    ExpCmdI b      where expCmdG :: ExpCmdG b+  instance ExpCmdI HsExpr where expCmdG = ExpG+  instance ExpCmdI HsCmd  where expCmdG = CmdG++And now the 'alts' production is simplified, as we no longer need to+thread 'tag' explicitly:++  alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++This encoding works well enough, but introduces an extra GADT unlike the+tagless final encoding, and there's no need for this complexity.++-}++{- Note [PatBuilder]+~~~~~~~~~~~~~~~~~~~~+Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,+so we introduce the notion of a PatBuilder.++Consider a pattern like this:++  Con a b c++We parse arguments to "Con" one at a time in the  fexp aexp  parser production,+building the result with mkHsAppPV, so the intermediate forms are:++  1. Con+  2. Con a+  3. Con a b+  4. Con a b c++In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like+this (pseudocode):++  1. "Con"+  2. HsApp "Con" "a"+  3. HsApp (HsApp "Con" "a") "b"+  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"++Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have+instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for+the intermediate forms.++We also need an intermediate representation to postpone disambiguation between+FunBind and PatBind. Consider:++  a `Con` b = ...+  a `fun` b = ...++How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We+learn this by inspecting an intermediate representation in 'isFunLhs' and+seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate+representation capable of representing both a FunBind and a PatBind, so Pat is+insufficient.++PatBuilder is an extension of Pat that is capable of representing intermediate+parsing results for patterns and function bindings:++  data PatBuilder p+    = PatBuilderPat (Pat p)+    | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))+    | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))+    ...++It can represent any pattern via 'PatBuilderPat', but it also has a variety of+other constructors which were added by following a simple principle: we never+pattern match on the pattern stored inside 'PatBuilderPat'.+-}++---------------------------------------------------------------------------+-- Miscellaneous utilities++-- | Check if a fixity is valid. We support bypassing the usual bound checks+-- for some special operators.+checkPrecP+        :: Located (SourceText,Int)              -- ^ precedence+        -> Located (OrdList (LocatedN RdrName))  -- ^ operators+        -> P ()+checkPrecP (L l (_,i)) (L _ ol)+ | 0 <= i, i <= maxPrecedence = pure ()+ | all specialOp ol = pure ()+ | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)+  where+    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs+    specialOp op = unLoc op == getRdrName unrestrictedFunTyCon++mkRecConstrOrUpdate+        :: Bool+        -> LHsExpr GhcPs+        -> SrcSpan+        -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)+        -> (Maybe (EpToken "{"), Maybe (EpToken "}"))+        -> PV (HsExpr GhcPs)+mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns+  | isRdrDataCon c+  = do+      let (fs, ps) = partitionEithers fbinds+      case ps of+          p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+              PsErrOverloadedRecordDotInvalid+          _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)+mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns+  | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $+                                          PsErrDotsInRecordUpdate+  | otherwise = mkRdrRecordUpd overloaded_update exp fs anns++mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> (Maybe (EpToken "{"), Maybe (EpToken "}"))+  -> PV (HsExpr GhcPs)+mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do+  -- We do not need to know if OverloadedRecordDot is in effect. We do+  -- however need to know if OverloadedRecordUpdate (passed in+  -- overloaded_on) is in effect because it affects the Left/Right nature+  -- of the RecordUpd value we calculate.+  let (fs, ps) = partitionEithers fbinds+      fs' :: [LHsRecUpdField GhcPs GhcPs]+      fs' = map (fmap mk_rec_upd_field) fs+  case overloaded_on of+    False | not $ null ps ->+      -- A '.' was found in an update and OverloadedRecordUpdate isn't on.+      addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled+    False ->+      -- This is just a regular record update.+      return RecordUpd {+        rupd_ext = anns+      , rupd_expr = exp+      , rupd_flds =+          RegularRecUpdFields+            { xRecUpdFields = noExtField+            , recUpdFields  = fs' } }+    -- This is a RecordDotSyntax update.+    True -> do+      let qualifiedFields =+            [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'+                      , isQual . fieldOccRdrName $ lbl+            ]+      case qualifiedFields of+          qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $+                  PsErrOverloadedRecordUpdateNoQualifiedFields+          _ -> return $+               RecordUpd+                { rupd_ext = anns+                , rupd_expr = exp+                , rupd_flds =+                   OverloadedRecUpdFields+                     { xOLRecUpdFields = noExtField+                     , olRecUpdFields  = toProjUpdates fbinds } }+  where+    toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]+    toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })++    -- Convert a top-level field update like {foo=2} or {bar} (punned)+    -- to a projection update.+    recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs+    recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =+        -- The idea here is to convert the label to a singleton [FastString].+        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+        where+          -- If punning, compute HsVar "f" otherwise just arg. This+          -- has the effect that sentinel HsVar "pun-rhs" is replaced+          -- by HsVar "f" here, before the update is written to a+          -- setField expressions.+          punnedVar :: FastString -> LHsExpr GhcPs+          punnedVar f  = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f++mkRdrRecordCon+  :: LocatedN RdrName -> HsRecordBinds GhcPs -> (Maybe (EpToken "{"), Maybe (EpToken "}")) -> HsExpr GhcPs+mkRdrRecordCon con flds anns+  = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds }++mk_rec_fields :: [LocatedA (HsRecField GhcPs arg)] -> Maybe SrcSpan -> HsRecFields GhcPs arg+mk_rec_fields fs Nothing = HsRecFields { rec_ext = noExtField, rec_flds = fs, rec_dotdot = Nothing }+mk_rec_fields fs (Just s)  = HsRecFields { rec_ext = noExtField, rec_flds = fs+                                     , rec_dotdot = Just (L (l2l s) (RecFieldsDotDot $ length fs)) }++mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs+mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)+  = HsFieldBind noAnn (L loc (FieldOcc noExtField rdr)) arg pun++mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation+               -> InlinePragma+-- The (Maybe Activation) is because the user can omit+-- the activation spec (and usually does)+mkInlinePragma src (inl, match_info) mb_act+  = InlinePragma { inl_src = src -- See Note [Pragma source text] in "GHC.Types.SourceText"+                 , inl_inline = inl+                 , inl_sat    = Nothing+                 , inl_act    = act+                 , inl_rule   = match_info }+  where+    act = case mb_act of+            Just act -> act+            Nothing  -> -- No phase specified+                        case inl of+                          NoInline _  -> NeverActive+                          Opaque _    -> NeverActive+                          _other      -> AlwaysActive++mkOpaquePragma :: SourceText -> InlinePragma+mkOpaquePragma src+  = InlinePragma { inl_src    = src+                 , inl_inline = Opaque src+                 , inl_sat    = Nothing+                 -- By marking the OPAQUE pragma NeverActive we stop+                 -- (constructor) specialisation on OPAQUE things.+                 --+                 -- See Note [OPAQUE pragma]+                 , inl_act    = NeverActive+                 , inl_rule   = FunLike+                 }++checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]+               -> P (DataDefnCons (LConDecl GhcPs))+checkNewOrData span name is_type_data = curry $ \ case+    (NewType, [a]) -> pure $ NewTypeCon a+    (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)+    (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)+  where+    -- In a "type data" declaration, the constructors are in the type/class+    -- namespace rather than the data constructor namespace.+    -- See Note [Type data declarations] in GHC.Rename.Module.+    handle_type_data+      | is_type_data = map (fmap promote_constructor)+      | otherwise = id++    promote_constructor (dc@ConDeclGADT { con_names = cons })+      = dc { con_names = fmap (fmap promote_name) cons }+    promote_constructor (dc@ConDeclH98 { con_name = con })+      = dc { con_name = fmap promote_name con }+    promote_constructor dc = dc++    promote_name name = fromMaybe name (promoteRdrName name)++-----------------------------------------------------------------------------+-- utilities for foreign declarations++-- construct a foreign import declaration+--+mkImport :: Located CCallConv+         -> Located Safety+         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)+         -> (EpToken "import", TokDcolon)+         -> P (EpToken "foreign" -> HsDecl GhcPs)+mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) =+    case unLoc cconv of+      CCallConv          -> returnSpec =<< mkCImport+      CApiConv           -> do+        imp <- mkCImport+        if isCWrapperImport imp+          then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport+          else returnSpec imp+      StdCallConv        -> returnSpec =<< mkCImport+      PrimCallConv       -> mkOtherImport+      JavaScriptCallConv -> mkOtherImport+  where+    -- Parse a C-like entity string of the following form:+    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"+    -- If 'cid' is missing, the function name 'v' is used instead as symbol+    -- name (cf section 8.5.1 in Haskell 2010 report).+    mkCImport = do+      let e = unpackFS entity+      case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of+        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $+                             PsErrMalformedEntityString+        Just importSpec -> return importSpec++    isCWrapperImport (CImport _ _ _ _ CWrapper) = True+    isCWrapperImport _ = False++    -- currently, all the other import conventions only support a symbol name in+    -- the entity string. If it is missing, we use the function name instead.+    mkOtherImport = returnSpec importSpec+      where+        entity'    = if nullFS entity+                        then mkExtName (unLoc v)+                        else entity+        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)+        importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget++    returnSpec spec = return $ \tforeign -> ForD noExtField $ ForeignImport+          { fd_i_ext  = (tforeign, timport, td)+          , fd_name   = v+          , fd_sig_ty = ty+          , fd_fi     = spec+          }++++-- the string "foo" is ambiguous: either a header or a C identifier.  The+-- C identifier case comes first in the alternatives below, so we pick+-- that one.+parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String+             -> Located SourceText+             -> Maybe (ForeignImport (GhcPass p))+parseCImport cconv safety nm str sourceText =+ listToMaybe $ map fst $ filter (null.snd) $+     readP_to_S parse str+ where+   parse = do+       skipSpaces+       r <- choice [+          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),+          string "wrapper" >> return (mk Nothing CWrapper),+          do optional (token "static" >> skipSpaces)+             ((mk Nothing <$> cimp nm) ++++              (do h <- munch1 hdr_char+                  skipSpaces+                  let src = mkFastString h+                  mk (Just (Header (SourceText src) src))+                      <$> cimp nm))+         ]+       skipSpaces+       return r++   token str = do _ <- string str+                  toks <- look+                  case toks of+                      c : _+                       | id_char c -> pfail+                      _            -> return ()++   mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n++   hdr_char c = not (isSpace c)+   -- header files are filenames, which can contain+   -- pretty much any char (depending on the platform),+   -- so just accept any non-space character+   id_first_char c = isAlpha    c || c == '_'+   id_char       c = isAlphaNum c || c == '_'++   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)+             +++ (do isFun <- case unLoc cconv of+                               CApiConv ->+                                  option True+                                         (do token "value"+                                             skipSpaces+                                             return False)+                               _ -> return True+                     cid' <- cid+                     return (CFunction (StaticTarget NoSourceText cid'+                                        Nothing isFun)))+          where+            cid = return nm ++++                  (do c  <- satisfy id_first_char+                      cs <-  many (satisfy id_char)+                      return (mkFastString (c:cs)))+++-- construct a foreign export declaration+--+mkExport :: Located CCallConv+         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)+         -> ( EpToken "export", TokDcolon)+         -> P (EpToken "foreign" -> HsDecl GhcPs)+mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) (texport, td)+ = return $ \tforeign -> ForD noExtField $+   ForeignExport { fd_e_ext = (tforeign, texport, td), fd_name = v, fd_sig_ty = ty+                 , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) }+  where+    entity' | nullFS entity = mkExtName (unLoc v)+            | otherwise     = entity++-- Supplying the ext_name in a foreign decl is optional; if it+-- isn't there, the Haskell name is assumed. Note that no transformation+-- of the Haskell name is then performed, so if you foreign export (++),+-- it's external name will be "++". Too bad; it's important because we don't+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)+--+mkExtName :: RdrName -> CLabelString+mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm)++--------------------------------------------------------------------------------+-- Help with module system imports/exports++data ImpExpSubSpec = ImpExpAbs+                   | ImpExpAll (EpToken "..")+                   | ImpExpList [LocatedA ImpExpQcSpec]+                   | ImpExpAllWith [LocatedA ImpExpQcSpec]++data ImpExpQcSpec = ImpExpQcName (Maybe ExplicitNamespaceKeyword) (LocatedN RdrName)+                  | ImpExpQcWildcard (EpToken "..") (EpToken ",")++mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec+               -> ImpExpSubSpec -> P (IE GhcPs)+mkModuleImpExp warning (top, tcp) (L l specname) subs = do+  case subs of+    ImpExpAbs+      | isVarNameSpace (rdrNameSpace name)+                       -> return $ IEVar warning+                           (L l (ieNameFromSpec specname)) Nothing+      | otherwise      -> IEThingAbs warning . L l <$> nameT <*> pure noExportDoc+    ImpExpAll tok      -> IEThingAll (warning, (top, tok, tcp)) . L l <$> nameT <*> pure noExportDoc+    ImpExpList xs      ->+      (\newName -> IEThingWith (warning, (top,NoEpTok,NoEpTok,tcp)) (L l newName)+        NoIEWildcard (wrapped xs)) <$> nameT <*> pure noExportDoc+    ImpExpAllWith xs                       ->+      do allowed <- getBit PatternSynonymsBit+         if allowed+          then+            let withs = map unLoc xs+                pos   = maybe NoIEWildcard IEWildcard+                          (findIndex isImpExpQcWildcard withs)+                (td,tc) = case find isImpExpQcWildcard withs of+                  Just (ImpExpQcWildcard td tc) -> (td,tc)+                  _ -> (NoEpTok, NoEpTok)+                ies :: [LocatedA (IEWrappedName GhcPs)]+                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs+            in (\newName+                        -> IEThingWith (warning, (top,td,tc,tcp)) (L l newName) pos ies)+               <$> nameT <*> pure noExportDoc+          else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+                 PsErrIllegalPatSynExport+  where+    noExportDoc :: Maybe (LHsDoc GhcPs)+    noExportDoc = Nothing++    name = ieNameVal specname+    nameT =+      if isVarNameSpace (rdrNameSpace name)+        then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+               (PsErrVarForTyCon name)+        else return $ ieNameFromSpec specname++    ieNameVal (ImpExpQcName _ ln) = unLoc ln+    ieNameVal ImpExpQcWildcard{}  = panic "ieNameVal got wildcard"++    ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs+    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)++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+      [] -> return ie+      (l:_) -> importSpecError (locA l)+  where+    importSpecError l =+      addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm++-- In the correct order+mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ImpExpSubSpec+mkImpExpSubSpec [] = return (ImpExpList [])+mkImpExpSubSpec [L _ (ImpExpQcWildcard td _tc)] =+  return (ImpExpAll td)+mkImpExpSubSpec xs =+  if (any (isImpExpQcWildcard . unLoc) xs)+    then return $ (ImpExpAllWith xs)+    else return $ (ImpExpList xs)++isImpExpQcWildcard :: ImpExpQcSpec -> Bool+isImpExpQcWildcard (ImpExpQcWildcard _ _) = True+isImpExpQcWildcard _                      = False++-----------------------------------------------------------------------------+-- Warnings and failures++warnPrepositiveQualifiedModule :: SrcSpan -> P ()+warnPrepositiveQualifiedModule span =+  addPsMessage span PsWarnImportPreQualified++failNotEnabledImportQualifiedPost :: SrcSpan -> P ()+failNotEnabledImportQualifiedPost loc =+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified++failImportQualifiedTwice :: SrcSpan -> P ()+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++failOpFewArgs :: MonadP m => LocatedN RdrName -> m a+failOpFewArgs (L loc op) =+  do { star_is_type <- getBit StarIsTypeBit+     ; let is_star_type = if star_is_type then StarIsType else StarIsNotType+     ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+         (PsErrOpFewArgs is_star_type op) }++requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m ()+requireExplicitNamespaces kw = do+  allowed <- getBit ExplicitNamespacesBit+  unless allowed $+    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++data PV_Context =+  PV_Context+    { pv_options :: ParserOpts+    , pv_details :: ParseContext -- See Note [Parser-Validator Details]+    }++data PV_Accum =+  PV_Accum+    { pv_warnings        :: Messages PsMessage+    , pv_errors          :: Messages PsMessage+    , pv_header_comments :: Strict.Maybe [LEpaComment]+    , pv_comment_q       :: [LEpaComment]+    }++data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum+  deriving (Foldable, Functor, Traversable)++-- During parsing, we make use of several monadic effects: reporting parse errors,+-- accumulating warnings, adding API annotations, and checking for extensions. These+-- effects are captured by the 'MonadP' type class.+--+-- Sometimes we need to postpone some of these effects to a later stage due to+-- ambiguities described in Note [Ambiguous syntactic categories].+-- We could use two layers of the P monad, one for each stage:+--+--   abParser :: forall x. DisambAB x => P (P x)+--+-- The outer layer of P consumes the input and builds the inner layer, which+-- validates the input. But this type is not particularly helpful, as it obscures+-- the fact that the inner layer of P never consumes any input.+--+-- For clarity, we introduce the notion of a parser-validator: a parser that does+-- not consume any input, but may fail or use other effects. Thus we have:+--+--   abParser :: forall x. DisambAB x => P (PV x)+--+newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }+  deriving (Functor)++instance Applicative PV where+  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)+  (<*>) = ap++instance Monad PV where+  m >>= f = PV $ \ctx acc ->+    case unPV m ctx acc of+      PV_Ok acc' a -> unPV (f a) ctx acc'+      PV_Failed acc' -> PV_Failed acc'++runPV :: PV a -> P a+runPV = runPV_details noParseContext++askParseContext :: PV ParseContext+askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details++runPV_details :: ParseContext -> PV a -> P a+runPV_details details m =+  P $ \s ->+    let+      pv_ctx = PV_Context+        { pv_options = options s+        , pv_details = details }+      pv_acc = PV_Accum+        { pv_warnings = warnings s+        , pv_errors   = errors s+        , pv_header_comments = header_comments s+        , pv_comment_q = comment_q s }+      mkPState acc' =+        s { warnings = pv_warnings acc'+          , errors   = pv_errors acc'+          , comment_q = pv_comment_q acc' }+    in+      case unPV m pv_ctx pv_acc of+        PV_Ok acc' a -> POk (mkPState acc') a+        PV_Failed acc' -> PFailed (mkPState acc')++instance MonadP PV where+  addError err =+    PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()+  addWarning w =+    PV $ \_ctx acc ->+      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed+      -- diagnostics.+      PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()+  addFatalError err =+    addError err >> PV (const PV_Failed)+  getParserOpts = PV $ \ctx acc -> PV_Ok acc $! pv_options ctx+  allocateCommentsP ss = PV $ \_ s ->+    if null (pv_comment_q s) then PV_Ok s emptyComments else  -- fast path+    let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in+      PV_Ok s {+         pv_comment_q = comment_q'+       } (EpaComments newAnns)+  allocatePriorCommentsP ss = PV $ \_ s ->+    let (header_comments', comment_q', newAnns)+          = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in+      PV_Ok s {+         pv_header_comments = header_comments',+         pv_comment_q = comment_q'+       } (EpaComments newAnns)+  allocateFinalCommentsP ss = PV $ \_ s ->+    let (header_comments', comment_q', newAnns)+          = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in+      PV_Ok s {+         pv_header_comments = header_comments',+         pv_comment_q = comment_q'+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)++{- Note [Parser-Validator Details]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set+depending on validation context. We use this in checkPattern to fix #984.++Consider this example, where the user has forgotten a 'do':++  f _ = do+    x <- computation+    case () of+      _ ->+        result <- computation+        case () of () -> undefined++GHC parses it as follows:++  f _ = do+    x <- computation+    (case () of+      _ ->+        result) <- computation+        case () of () -> undefined++Note that this fragment is parsed as a pattern:++  case () of+    _ ->+      result++We attempt to detect such cases and add a hint to the diagnostic messages:++  T984.hs:6:9:+    Parse error in pattern: case () of { _ -> result }+    Possibly caused by a missing 'do'?++The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed+out of the 'ParseContext', which are read by functions like 'patFail' when+constructing the 'PsParseErrorInPatDetails' data structure. When validating in a+context other than 'bindpat' (a pattern to the left of <-), we set the+details to 'noParseContext' and it has no effect on the diagnostic messages.++-}++-- | Hint about bang patterns, assuming @BangPatterns@ is off.+hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()+hintBangPat span e = do+    bang_on <- getBit BangPatBit+    unless bang_on $+      addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e++mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)+                 -> (EpaLocation, EpaLocation)+                 -> PV (LHsExpr GhcPs)++-- Tuple+mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do+    !cs <- getCommentsFor (locA l)+    return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity)+  where+    toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs+    toTupArg (Left ann) = missingTupArg ann+    toTupArg (Right a)  = Present noExtField a++-- Sum+-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =+--     return $ L l (ExplicitSum noExtField alt arity e)+mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) (o, c) = do+    let an = AnnExplicitSum o barsp barsa c+    !cs <- getCommentsFor (locA l)+    return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e)+mkSumOrTupleExpr l Boxed a@Sum{} _ =+    addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a++mkSumOrTuplePat+  :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> (EpaLocation, EpaLocation)+  -> PV (LocatedA (PatBuilder GhcPs))++-- Tuple+mkSumOrTuplePat l boxity (Tuple ps) anns = do+  ps' <- traverse toTupPat ps+  return $ L l (PatBuilderPat (TuplePat anns ps' boxity))+  where+    toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)+    -- Ignore the element location so that the error message refers to the+    -- entire tuple. See #19504 (and the discussion) for details.+    toTupPat p = case p of+      Left _ -> addFatalError $+                  mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat+      Right p' -> checkLPat p'++-- Sum+mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do+   p' <- checkLPat p+   let an = EpAnnSumPat anns barsb barsa+   return $ L l (PatBuilderPat (SumPat an p' alt arity))+mkSumOrTuplePat l Boxed a@Sum{} _ =+    addFatalError $+      mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a++mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs+mkLHsOpTy prom x op y =+  let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y+  in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)++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+  = 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, EpArrow arr) t++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+  = 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 ep = HsExplicitMult (pct, ep) t++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'+epTokenWidenR NoEpTok _ = NoEpTok+epTokenWidenR (EpTok l) (UnhelpfulSpan _) = EpTok l+epTokenWidenR (EpTok (EpaSpan s1)) s2 = EpTok (EpaSpan (combineSrcSpans s1 s2))+epTokenWidenR (EpTok EpaDelta{}) _ =+  -- Never happens because the parser does not produce EpaDelta.+  panic "epTokenWidenR: EpaDelta"++-----------------------------------------------------------------------------+-- Token symbols++starSym :: Bool -> FastString+starSym True = fsLit "★"+starSym False = fsLit "*"++-----------------------------------------+-- Bits and pieces for RecordDotSyntax.++mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)+  -> HsExpr GhcPs+mkRdrGetField arg field =+  HsGetField {+      gf_ext = NoExtField+    , gf_expr = arg+    , gf_field = field+    }++mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs+mkRdrProjection flds anns =+  HsProjection {+      proj_ext = anns+    , proj_flds = fmap unLoc flds+    }++mkRdrProjUpdate :: SrcSpanAnnA -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))+                -> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=")+                -> LHsRecProj GhcPs (LHsExpr GhcPs)+mkRdrProjUpdate loc (L l flds) arg isPun anns =+  L loc HsFieldBind {+      hfbAnn = anns+    , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)+    , hfbRHS = arg+    , hfbPun = isPun+  }++-----------------------------------------------------------------------------+-- Tuple and list punning++punsAllowed :: P Bool+punsAllowed = getBit ListTuplePunsBit++-- | Check whether @ListTuplePuns@ is enabled and return the first arg if it is,+-- the second arg otherwise.+punsIfElse :: a -> a -> P a+punsIfElse enabled disabled = do+  allowed <- punsAllowed+  pure (if allowed then enabled else disabled)++-- | Emit an error of type 'PsErrInvalidPun' with a location from @start@ to+-- @end@ if the extension @ListTuplePuns@ is disabled.+--+-- This is used in Parser.y to guard rules that require punning.+requireLTPuns :: PsErrPunDetails -> Located a -> Located b -> P ()+requireLTPuns err start end =+  unlessM punsAllowed $ do+    addError (mkPlainErrorMsgEnvelope loc (PsErrInvalidPun err))+  where+    loc = (combineSrcSpans (getLoc start) (getLoc end))++-- | Call a parser with a span and its comments given by a start and end token.+withCombinedComments ::+  HasLoc l1 =>+  HasLoc l2 =>+  l1 ->+  l2 ->+  (SrcSpan -> P a) ->+  P (LocatedA a)+withCombinedComments start end use = do+  cs <- getCommentsFor fullSpan+  a <- use fullSpan+  pure (L (EpAnn (spanAsAnchor fullSpan) noAnn cs) a)+  where+    fullSpan = combineSrcSpans (getHasLoc start) (getHasLoc end)++-- | Decide whether to parse tuple syntax @(Int, Double)@ in a type as a+-- type or data constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'(Int, Double)@, is handled+-- by 'mkExplicitTupleTy'.+mkTupleSyntaxTy :: EpToken "("+                -> [LocatedA (HsType GhcPs)]+                -> EpToken ")"+                -> P (HsType GhcPs)+mkTupleSyntaxTy parOpen args parClose =+  punsIfElse enabled disabled+  where+    enabled =+      HsTupleTy annParen HsBoxedOrConstraintTuple args+    disabled =+      HsExplicitTupleTy annsKeyword NotPromoted args++    annParen = AnnParens parOpen parClose+    annsKeyword = (NoEpTok, parOpen, parClose)++-- | Decide whether to parse tuple con syntax @(,)@ in a type as a+-- type or data constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'(,)@, is handled+-- by the rule @SIMPLEQUOTE sysdcon_nolist@ in @atype@.+mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName+mkTupleSyntaxTycon boxity n =+  punsIfElse+    (getRdrName (tupleTyCon boxity n))+    (getRdrName (tupleDataCon boxity n))++-- | Decide whether to parse list tycon syntax @[]@ in a type as a type or data+-- constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'[]@, is handled by+-- 'mkExplicitListTy'.+mkListSyntaxTy0 :: EpToken "["+                -> EpToken "]"+                -> SrcSpan+                -> P (HsType GhcPs)+mkListSyntaxTy0 brkOpen brkClose span =+  punsIfElse enabled disabled+  where+    enabled = HsTyVar noAnn NotPromoted rn++    -- attach the comments only to the RdrName since it's the innermost AST node+    rn = L (EpAnn fullLoc rdrNameAnn emptyComments) listTyCon_RDR++    disabled =+      HsExplicitListTy annsKeyword NotPromoted []++    rdrNameAnn = NameAnnOnly (NameSquare brkOpen brkClose) []+    annsKeyword = (NoEpTok, brkOpen, brkClose)+    fullLoc = EpaSpan span++-- | Decide whether to parse list type syntax @[Int]@ in a type as a+-- type or data constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'[Int]@, is handled+-- by 'mkExplicitListTy'.+mkListSyntaxTy1 :: EpToken "["+                -> LocatedA (HsType GhcPs)+                -> EpToken "]"+                -> P (HsType GhcPs)+mkListSyntaxTy1 brkOpen t brkClose =+  punsIfElse enabled disabled+  where+    enabled = HsListTy annParen t++    disabled =+      HsExplicitListTy annsKeyword NotPromoted [t]++    annsKeyword = (NoEpTok, brkOpen, brkClose)+    annParen = AnnParensSquare brkOpen brkClose++parseError :: HsExpr GhcPs+parseError = HsHole HoleError
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -53,27 +53,21 @@ import GHC.Hs  import GHC.Types.SrcLoc-import GHC.Utils.Panic-import GHC.Data.Bag  import Data.Semigroup import Data.Foldable import Data.Traversable-import Data.Maybe-import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE-import Control.Monad+import Control.Applicative import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer import Data.Functor.Identity-import qualified Data.Monoid  import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types-import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))+import GHC.Utils.Misc (mergeListsBy, filterOut, (<&&>)) import qualified GHC.Data.Strict as Strict  {- Note [Adding Haddock comments to the syntax tree]@@ -220,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@@ -243,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@@ -250,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:     --@@ -289,13 +289,13 @@     --      data C = MkC  -- ^ Comment on MkC     --      -- ^ Comment on C     ---    let layout_info = hsmodLayout (hsmodExt mod)-    hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod)+    let layout = hsmodLayout (hsmodExt mod)+    hsmodDecls' <- addHaddockInterleaveItems layout (mkDocHsDecl layout) (hsmodDecls mod)      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@@ -303,22 +303,34 @@ lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs lexLHsDocString = fmap lexHsDocString --- Only for module exports, not module imports.+-- | Only for module exports, not module imports. -- --    module M (a, b, c) where   -- use on this [LIE GhcPs] --    import I (a, b, c)         -- do not use here! -- -- Imports cannot have documentation comments anyway.-instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where+instance HasHaddock (LocatedLI [LocatedA (IE GhcPs)]) where   addHaddock (L l_exports exports) =     extendHdkA (locA l_exports) $ do-      exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports+      exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports       registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis       pure $ L l_exports exports'  -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. instance HasHaddock (LocatedA (IE GhcPs)) where-  addHaddock a = a <$ registerHdkA a+  addHaddock (L l_export ie ) =+    extendHdkA (locA l_export) $ liftHdkA $ do+      docs <- inLocRange (locRangeFrom (getBufPos (srcSpanEnd (locA l_export)))) $+        takeHdkComments mkDocPrev+      mb_doc <- selectDocString docs+      let mb_ldoc = lexLHsDocString <$> mb_doc+      let ie' = case ie of+            IEVar ext nm _                 -> IEVar ext nm mb_ldoc+            IEThingAbs ext nm _            -> IEThingAbs ext nm mb_ldoc+            IEThingAll ext nm _            -> IEThingAll ext nm mb_ldoc+            IEThingWith ext nm wild subs _ -> IEThingWith ext nm wild subs mb_ldoc+            x                              -> x+      pure $ L l_export ie'  {- Add Haddock items to a list of non-Haddock items. Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl).@@ -340,10 +352,10 @@  The inputs to addHaddockInterleaveItems are: -  * layout_info :: LayoutInfo GhcPs+  * layout :: EpLayout      In the example above, note that the indentation level inside the module is-    2 spaces. It would be represented as layout_info = VirtualBraces 2.+    2 spaces. It would be represented as layout = EpVirtualBraces 2.      It is used to delimit the search space for comments when processing     declarations. Here, we restrict indentation levels to >=(2+1), so that when@@ -352,7 +364,7 @@   * get_doc_item :: PsLocated HdkComment -> Maybe a      This is the function used to look up documentation comments.-    In the above example, get_doc_item = mkDocHsDecl layout_info,+    In the above example, get_doc_item = mkDocHsDecl layout,     and it will produce the following parts of the output:        DocD (DocCommentNext "Comment on D")@@ -372,25 +384,25 @@ addHaddockInterleaveItems   :: forall a.      HasHaddock a-  => LayoutInfo GhcPs+  => EpLayout   -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item   -> [a]           -- Unprocessed (non-documentation) items   -> HdkA [a]      -- Documentation items & processed non-documentation items-addHaddockInterleaveItems layout_info get_doc_item = go+addHaddockInterleaveItems layout get_doc_item = go   where     go :: [a] -> HdkA [a]     go [] = liftHdkA (takeHdkComments get_doc_item)     go (item : items) = do       docItems <- liftHdkA (takeHdkComments get_doc_item)-      item' <- with_layout_info (addHaddock item)+      item' <- with_layout (addHaddock item)       other_items <- go items       pure $ docItems ++ item':other_items -    with_layout_info :: HdkA a -> HdkA a-    with_layout_info = case layout_info of-      NoLayoutInfo -> id-      ExplicitBraces{} -> id-      VirtualBraces n ->+    with_layout :: HdkA a -> HdkA a+    with_layout = case layout of+      EpNoLayout -> id+      EpExplicitBraces{} -> id+      EpVirtualBraces n ->         let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }         in hoistHdkA (inLocRange loc_range) @@ -498,18 +510,18 @@   --      -- ^ Comment on the second method   --   addHaddock (TyClD _ decl)-    | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout,+    | ClassDecl { tcdCExt = (x, layout, NoAnnSortKey),                   tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,                   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 tcdLayout (mkDocHsDecl tcdLayout) $+          addHaddockInterleaveItems layout (mkDocHsDecl layout) $           flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])         pure $           let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls'-              decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout+              decl' = ClassDecl { tcdCExt = (x, layout, NoAnnSortKey)                                 , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs                                 , tcdSigs = tcdSigs'                                 , tcdMeths = tcdMeths'@@ -548,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 {@@ -578,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:     --@@ -698,202 +709,102 @@   addHaddock (L l_con_decl con_decl) =     extendHdkA (locA l_con_decl) $     case con_decl of-      ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do-        -- discardHasInnerDocs is ok because we don't need this info for GADTs.-        con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names))+      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 ts -> PrefixConGADT <$> addHaddock ts-            RecConGADT (L l_rec flds) arr -> do-              -- discardHasInnerDocs is ok because we don't need this info for GADTs.-              flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds-              pure $ RecConGADT (L l_rec flds') arr+            PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts+            RecConGADT arr (L l_rec flds) -> do+              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_dcolon, 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' }       ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->-        addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $-        case con_args of-          PrefixCon _ ts -> do-            con_doc' <- getConDoc (getLocA con_name)-            ts' <- traverse addHaddockConDeclFieldTy 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' }-          InfixCon t1 t2 -> do-            t1' <- addHaddockConDeclFieldTy t1-            con_doc' <- getConDoc (getLocA con_name)-            t2' <- addHaddockConDeclFieldTy 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-            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 = RecCon (L l_rec flds') }---- Keep track of documentation comments on the data constructor or any of its--- fields.------ See Note [Trailing comment on constructor declaration]-type ConHdkA = WriterT HasInnerDocs HdkA+        let+          -- See Note [Leading and trailing comments on H98 constructors]+          getTrailingLeading :: HdkM (LocatedA (ConDecl GhcPs))+          getTrailingLeading = do+            con_doc' <- getPrevNextDoc (locA l_con_decl)+            return $ L l_con_decl $+              ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args+                         , con_doc = lexLHsDocString <$> con_doc' } --- Does the data constructor declaration have any inner (non-trailing)--- documentation comments?------ Example when HasInnerDocs is True:------   data X =---      MkX       -- ^ inner comment---        Field1  -- ^ inner comment---        Field2  -- ^ inner comment---        Field3  -- ^ trailing comment------ Example when HasInnerDocs is False:------   data Y = MkY Field1 Field2 Field3  -- ^ trailing comment------ See Note [Trailing comment on constructor declaration]-newtype HasInnerDocs = HasInnerDocs Bool-  deriving (Semigroup, Monoid) via Data.Monoid.Any+          -- See Note [Leading and trailing comments on H98 constructors]+          getMixed :: HdkA (LocatedA (ConDecl GhcPs))+          getMixed =+            case con_args of+              PrefixCon ts -> do+                con_doc' <- getConDoc (getLocA con_name)+                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 ts' }+              InfixCon t1 t2 -> do+                t1' <- addHaddock t1+                con_doc' <- getConDoc (getLocA con_name)+                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 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',+                               con_args = RecCon (L l_rec flds') }+        in+          hoistHdkA+            (\m -> do { a <- onlyTrailingOrLeading (locA l_con_decl)+                      ; if a then getTrailingLeading else m })+            getMixed --- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it.------ We only do this when processing data declarations that use GADT syntax,--- because only the H98 syntax declarations have special treatment for the--- trailing documentation comment.------ See Note [Trailing comment on constructor declaration]-discardHasInnerDocs :: ConHdkA a -> HdkA a-discardHasInnerDocs = fmap fst . runWriterT+-- See Note [Leading and trailing comments on H98 constructors]+onlyTrailingOrLeading :: SrcSpan -> HdkM Bool+onlyTrailingOrLeading l = peekHdkM $ do+  leading <-+    inLocRange (locRangeTo (getBufPos (srcSpanStart l))) $+    takeHdkComments mkDocNext+  inner <-+    inLocRange (locRangeIn (getBufSpan l)) $+    takeHdkComments (\x -> mkDocNext x <|> mkDocPrev x)+  trailing <-+    inLocRange (locRangeFrom (getBufPos (srcSpanEnd l))) $+    takeHdkComments mkDocPrev+  return $ case (leading, inner, trailing) of+    (_:_, [], []) -> True  -- leading comment only+    ([], [], _:_) -> True  -- trailing comment only+    _             -> False  -- Get the documentation comment associated with the data constructor in a -- data/newtype declaration. getConDoc   :: SrcSpan  -- Location of the data constructor-  -> ConHdkA (Maybe (Located HsDocString))-getConDoc l =-  WriterT $ extendHdkA l $ liftHdkA $ do-    mDoc <- getPrevNextDoc l-    return (mDoc, HasInnerDocs (isJust mDoc))---- Add documentation comment to a data constructor field.--- Used for PrefixCon and InfixCon.-addHaddockConDeclFieldTy-  :: HsScaled GhcPs (LHsType GhcPs)-  -> ConHdkA (HsScaled GhcPs (LHsType GhcPs))-addHaddockConDeclFieldTy (HsScaled mult (L l t)) =-  WriterT $ extendHdkA (locA l) $ liftHdkA $ do-    mDoc <- getPrevNextDoc (locA l)-    return (HsScaled mult (mkLHsDocTy (L l t) mDoc),-            HasInnerDocs (isJust mDoc))---- Add documentation comment to a data constructor field.--- Used for RecCon.-addHaddockConDeclField-  :: LConDeclField GhcPs-  -> ConHdkA (LConDeclField GhcPs)-addHaddockConDeclField (L l_fld fld) =-  WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do-    cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)-    return (L l_fld (fld { cd_fld_doc }),-            HasInnerDocs (isJust cd_fld_doc))+  -> HdkA (Maybe (Located HsDocString))+getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l --- 1. Process a H98-syntax data constructor declaration in a context with no---    access to the trailing documentation comment (by running the provided---    ConHdkA computation).------ 2. Then grab the trailing comment (if it exists) and attach it where---    appropriate: either to the data constructor itself or to its last field,---    depending on HasInnerDocs.------ See Note [Trailing comment on constructor declaration]-addConTrailingDoc-  :: SrcLoc  -- The end of a data constructor declaration.-             -- Any docprev comment past this point is considered trailing.-  -> ConHdkA (LConDecl GhcPs)-  -> HdkA (LConDecl GhcPs)-addConTrailingDoc l_sep =-    hoistHdkA add_trailing_doc . runWriterT-  where-    add_trailing_doc-      :: HdkM (LConDecl GhcPs, HasInnerDocs)-      -> HdkM (LConDecl GhcPs)-    add_trailing_doc m = do-      (L l con_decl, HasInnerDocs has_inner_docs) <--        inLocRange (locRangeTo (getBufPos l_sep)) m-          -- inLocRange delimits the context so that the inner computation-          -- will not consume the trailing documentation comment.-      case con_decl of-        ConDeclH98{} -> do-          trailingDocs <--            inLocRange (locRangeFrom (getBufPos l_sep)) $-            takeHdkComments mkDocPrev-          if null trailingDocs-          then return (L l con_decl)-          else do-            if has_inner_docs then do-              let mk_doc_ty ::       HsScaled GhcPs (LHsType GhcPs)-                            -> HdkM (HsScaled GhcPs (LHsType GhcPs))-                  mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) =-                    -- Happens in the following case:-                    ---                    --    data T =-                    --      MkT-                    --        -- | Comment on SomeField-                    --        SomeField-                    --        -- ^ Another comment on SomeField? (rejected)-                    ---                    -- See tests/.../haddockExtraDocs.hs-                    x <$ reportExtraDocs trailingDocs-                  mk_doc_ty (HsScaled mult (L l' t)) = do-                    doc <- selectDocString trailingDocs-                    return $ HsScaled mult (mkLHsDocTy (L l' t) doc)-              let mk_doc_fld ::       LConDeclField GhcPs-                             -> HdkM (LConDeclField GhcPs)-                  mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) =-                    -- Happens in the following case:-                    ---                    --    data T =-                    --      MkT {-                    --        -- | Comment on SomeField-                    --        someField :: SomeField-                    --      } -- ^ Another comment on SomeField? (rejected)-                    ---                    -- See tests/.../haddockExtraDocs.hs-                    x <$ reportExtraDocs trailingDocs-                  mk_doc_fld (L l' con_fld) = do-                    doc <- selectDocString trailingDocs-                    return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc })-              con_args' <- case con_args con_decl of-                x@(PrefixCon _ ts) -> case nonEmpty ts of-                    Nothing -> x <$ reportExtraDocs trailingDocs-                    Just ts -> PrefixCon noTypeArgs . toList <$> mapLastM mk_doc_ty ts-                x@(RecCon (L l_rec flds)) -> case nonEmpty flds of-                    Nothing -> x <$ reportExtraDocs trailingDocs-                    Just flds -> RecCon . L l_rec . toList <$> mapLastM mk_doc_fld flds-                InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2-              return $ L l (con_decl{ con_args = con_args' })-            else do-              con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs))-              return $ L l (con_decl{ con_doc = con_doc' })-        _ -> panic "addConTrailingDoc: non-H98 ConDecl"+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 [Trailing comment on constructor declaration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Leading and trailing comments on H98 constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The trailing comment after a constructor declaration is associated with the-constructor itself when there are no other comments inside the declaration:+constructor itself when it is the only comment:     data T = MkT A B        -- ^ Comment on MkT    data T = MkT { x :: A } -- ^ Comment on MkT+   data T = A `MkT` B      -- ^ Comment on MkT  When there are other comments, the trailing comment applies to the last field: @@ -906,7 +817,58 @@          , b :: B   -- ^ Comment on b          , c :: C } -- ^ Comment on c -This makes the trailing comment context-sensitive. Example:+   data T =+       A      -- ^ Comment on A+      `MkT`   -- ^ Comment on MkT+       B      -- ^ Comment on B++When it comes to the leading comment, there is no such ambiguity in /prefix/+constructor declarations (plain or record syntax):++   data T =+    -- | Comment on MkT+    MkT A B++   data T =+    -- | Comment on MkT+    MkT+      -- | Comment on A+      A+      -- | Comment on B+      B++   data T =+    -- | Comment on MkT+    MkT { x :: A }++   data T =+     -- | Comment on MkT+     MkT {+      -- | Comment on a+      a :: A,+      -- | Comment on b+      b :: B,+      -- | Comment on c+      c :: C+    }++However, in /infix/ constructor declarations the leading comment is associated+with the constructor itself if it is the only comment, and with the first+field if there are other comments:++   data T =+    -- | Comment on MkT+    A `MkT` B++   data T =+    -- | Comment on A+    A+    -- | Comment on MkT+    `MkT`+    -- | Comment on B+    B++This makes the leading and trailing comments context-sensitive. Example:       data T =         -- | comment 1         MkT Int Bool -- ^ comment 2@@ -920,21 +882,28 @@  We implement this in two steps: -  1. Process the data constructor declaration in a delimited context where the-     trailing documentation comment is not visible. Delimiting the context is done-     in addConTrailingDoc.+  1. Gather information about available comments using `onlyTrailingOrLeading`.+     It inspects available comments but does not consume them, and returns a+     boolean that tells us what algorithm we should use+        True  <=>  expect a single leading/trailing comment+        False <=>  expect inner comments or more than one comment -     When processing the declaration, track whether the constructor or any of-     its fields have a documentation comment associated with them.-     This is done using WriterT HasInnerDocs, see ConHdkA.+  2. Collect the comments using the algorithm determined in the previous step -  2. Depending on whether HasInnerDocs is True or False, attach the-     trailing documentation comment to the data constructor itself-     or to its last field.+     a) `getTrailingLeading`:+            a single leading/trailing comment is applied to the entire+            constructor declaration as a whole; see the `con_doc` field+     b) `getMixed`:+            comments apply to individual parts of a constructor declaration,+            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@@ -1155,9 +1124,16 @@ -- A small wrapper over registerLocHdkA. -- -- See Note [Adding Haddock comments to the syntax tree].-registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()+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 hoistHdkA f (HdkA l m) = HdkA l (f m)@@ -1266,6 +1242,13 @@         Just item -> (item : items, other_hdk_comments)         Nothing -> (items, hdk_comment : other_hdk_comments) +-- Run a HdkM action and restore the original state.+peekHdkM :: HdkM a -> HdkM a+peekHdkM m =+  HdkM $ \r s ->+    case unHdkM m r s of+      (a, _) -> (a, s)+ -- Get the docnext or docprev comment for an AST node at the given source span. getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) getPrevNextDoc l = do@@ -1290,15 +1273,6 @@       reportExtraDocs extra_docs       return (Just doc) -selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a))-selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc)-  where-    select [] = return Nothing-    select [doc] = return (Just doc)-    select (doc : extra_docs) = do-      reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs-      return (Just doc)- reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs =   traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc))@@ -1309,11 +1283,11 @@ *                                                                      * ********************************************************************* -} -mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)-mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a+mkDocHsDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)+mkDocHsDecl layout a = fmap (DocD noExtField) <$> mkDocDecl layout a -mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)-mkDocDecl layout_info (L l_comment hdk_comment)+mkDocDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)+mkDocDecl layout (L l_comment hdk_comment)   | indent_mismatch = Nothing   | otherwise =     Just $ L (noAnnSrcSpan span) $@@ -1344,10 +1318,10 @@     --         class C a where     --           f :: a -> a     --         -- ^ indent mismatch-    indent_mismatch = case layout_info of-      NoLayoutInfo -> False-      ExplicitBraces{} -> False-      VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)+    indent_mismatch = case layout of+      EpNoLayout -> False+      EpExplicitBraces{} -> False+      EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)  mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) =@@ -1355,7 +1329,7 @@     HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc)     HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)     HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc)-    _ -> Nothing+    HdkCommentPrev doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc)   where l = noAnnSrcSpan span         span = mkSrcSpanPs l_comment @@ -1398,6 +1372,13 @@ locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l } locRangeTo Strict.Nothing = mempty +-- The location range within the specified span.+locRangeIn :: Strict.Maybe BufSpan -> LocRange+locRangeIn (Strict.Just l) =+  mempty { loc_range_from = StartLoc (bufSpanStart l)+         , loc_range_to   = EndLoc (bufSpanEnd l) }+locRangeIn Strict.Nothing = mempty+ -- Represents a predicate on BufPos: -- --   LowerLocBound |   BufPos -> Bool@@ -1482,7 +1463,7 @@  mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs mkLHsDocTy t Nothing = t-mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc)+mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t $ lexLHsDocString doc)  getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele =@@ -1509,7 +1490,7 @@   -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'   -- - 'partitionBindsAndSigs' does not discard this 'BufSpan'   mergeListsBy cmpBufSpanA [-    mapLL (\b -> ValD noExtField b) (bagToList all_bs),+    mapLL (\b -> ValD noExtField b) all_bs,     mapLL (\s -> SigD noExtField s) all_ss,     mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,     mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,@@ -1517,7 +1498,7 @@     mapLL (\d -> DocD noExtField d) all_docs   ] -cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering+cmpBufSpanA :: GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)  {- *********************************************************************@@ -1525,10 +1506,6 @@ *                   General purpose utilities                          * *                                                                      * ********************************************************************* -}---- Cons an element to a list, if exists.-mcons :: Maybe a -> [a] -> [a]-mcons = maybe id (:)  -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b]
+ compiler/GHC/Parser/String.hs view
@@ -0,0 +1,438 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module GHC.Parser.String (+  StringLexError (..),+  lexString,+  lexMultilineString,++  -- * Unicode smart quote helpers+  isDoubleSmartQuote,+  isSingleSmartQuote,+) where++import GHC.Prelude hiding (getChar)++import Control.Arrow ((>>>))+import Control.Monad (when)+import Data.Char (chr, ord)+import qualified Data.Foldable1 as Foldable1+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (listToMaybe, mapMaybe)+import GHC.Data.StringBuffer (StringBuffer)+import qualified GHC.Data.StringBuffer as StringBuffer+import GHC.Parser.CharClass (+  hexDigit,+  is_decdigit,+  is_hexdigit,+  is_octdigit,+  is_space,+  octDecDigit,+ )+import GHC.Parser.Errors.Types (LexErr (..))+import GHC.Utils.Panic (panic)++type BufPos = Int+data StringLexError = StringLexError LexErr BufPos+  deriving (Show, Eq)++lexString :: Int -> StringBuffer -> Either StringLexError String+lexString = lexStringWith processChars processChars+  where+    processChars :: HasChar c => [c] -> Either (c, LexErr) [c]+    processChars =+          collapseGaps+      >>> resolveEscapes++-- -----------------------------------------------------------------------------+-- Lexing interface++{-+Note [Lexing strings]+~~~~~~~~~~~~~~~~~~~~~++After verifying if a string is lexically valid with Alex, we still need to do+some post processing of the string, namely:+1. Collapse string gaps+2. Resolve escape characters++The problem: 'lexemeToString' is more performant than manually reading+characters from the StringBuffer. However, that completely erases the position+of each character, which we need in order to report the correct position for+error messages (e.g. when resolving escape characters).++So what we'll do is do two passes. The first pass is optimistic; just convert+to a plain String and process it. If this results in an error, we do a second+pass, this time where each character is annotated with its position. Now, the+error has all the information it needs.++Ideally, lexStringWith would take a single (forall c. HasChar c => ...) function,+but to help the specializer, we pass it in twice to concretize it for the two+types we actually use.+-}++-- | See Note [Lexing strings]+lexStringWith ::+  ([Char] -> Either (Char, LexErr) [Char])+  -> ([CharPos] -> Either (CharPos, LexErr) [CharPos])+  -> Int+  -> StringBuffer+  -> Either StringLexError String+lexStringWith processChars processCharsPos len buf =+  case processChars $ bufferChars buf len of+    Right s -> Right s+    Left _ ->+      case processCharsPos $ bufferLocatedChars buf len of+        Right _ -> panic "expected lex error on second pass"+        Left ((_, pos), e) -> Left $ StringLexError e pos++class HasChar c where+  getChar :: c -> Char+  setChar :: Char -> c -> c++instance HasChar Char where+  getChar = id+  setChar = const++instance HasChar (Char, x) where+  getChar = fst+  setChar c (_, x) = (c, x)++pattern Char :: HasChar c => Char -> c+pattern Char c <- (getChar -> c)+{-# COMPLETE Char #-}++bufferChars :: StringBuffer -> Int -> [Char]+bufferChars = StringBuffer.lexemeToString++type CharPos = (Char, BufPos)++bufferLocatedChars :: StringBuffer -> Int -> [CharPos]+bufferLocatedChars initialBuf len = go initialBuf+  where+    go buf+      | atEnd buf = []+      | otherwise  =+          let (c, buf') = StringBuffer.nextChar buf+           in (c, StringBuffer.cur buf) : go buf'++    atEnd buf = StringBuffer.byteDiff initialBuf buf >= len++-- -----------------------------------------------------------------------------+-- Lexing phases++-- | Collapse all string gaps in the given input.+--+-- Iterates through the input in `go` until we encounter a backslash. The+-- @stringchar Alex regex only allows backslashes in two places: escape codes+-- and string gaps.+--+--   * If the next character is a space, it has to be the start of a string gap+--     AND it must end, since the @gap Alex regex will only match if it ends.+--     Collapse the gap and continue the main iteration loop.+--+--   * Otherwise, this is an escape code. If it's an escape code, there are+--     ONLY three possibilities (see the @escape Alex regex):+--       1. The escape code is "\\"+--       2. The escape code is "\^\"+--       3. The escape code does not have a backslash, other than the initial+--          backslash+--+--     In the first two possibilities, just skip them and continue the main+--     iteration loop ("skip" as in "keep in the list as-is"). In the last one,+--     we can just skip the backslash, then continue the main iteration loop.+--     the rest of the escape code will be skipped as normal characters in the+--     string; no need to fully parse a proper escape code.+collapseGaps :: HasChar c => [c] -> [c]+collapseGaps = go+  where+    go = \case+      -- Match the start of a string gap + drop gap+      -- #25784: string gaps are semantically equivalent to "\&"+      c1@(Char '\\') : Char c : cs+        | is_space c -> c1 : setChar '&' c1 : go (dropGap cs)+      -- Match all possible escape characters that include a backslash+      c1@(Char '\\') : c2@(Char '\\') : cs+        -> c1 : c2 : go cs+      c1@(Char '\\') : c2@(Char '^') : c3@(Char '\\') : cs+        -> c1 : c2 : c3 : go cs+      -- Otherwise, just keep looping+      c : cs -> c : go cs+      [] -> []++    dropGap = \case+      Char '\\' : cs -> cs+      _ : cs -> dropGap cs+      -- Unreachable since gaps must end; see docstring+      [] -> panic "gap unexpectedly ended"++resolveEscapes :: HasChar c => [c] -> Either (c, LexErr) [c]+resolveEscapes = go dlistEmpty+  where+    go !acc = \case+      [] -> pure $ dlistToList acc+      Char '\\' : Char '&' : cs -> go acc cs+      backslash@(Char '\\') : cs ->+        case resolveEscapeChar cs of+          Right (esc, cs') -> go (acc `dlistSnoc` setChar esc backslash) cs'+          Left (c, e) -> Left (c, e)+      c : cs -> go (acc `dlistSnoc` c) cs++-- -----------------------------------------------------------------------------+-- Escape characters++-- | Resolve a escape character, after having just lexed a backslash.+-- Assumes escape character is valid.+resolveEscapeChar :: HasChar c => [c] -> Either (c, LexErr) (Char, [c])+resolveEscapeChar = \case+  Char 'a'  : cs -> pure ('\a', cs)+  Char 'b'  : cs -> pure ('\b', cs)+  Char 'f'  : cs -> pure ('\f', cs)+  Char 'n'  : cs -> pure ('\n', cs)+  Char 'r'  : cs -> pure ('\r', cs)+  Char 't'  : cs -> pure ('\t', cs)+  Char 'v'  : cs -> pure ('\v', cs)+  Char '\\' : cs -> pure ('\\', cs)+  Char '"'  : cs -> pure ('\"', cs)+  Char '\'' : cs -> pure ('\'', cs)+  -- escape codes+  Char 'x' : cs -> parseNum is_hexdigit 16 hexDigit cs+  Char 'o' : cs -> parseNum is_octdigit 8 octDecDigit cs+  cs@(Char c : _) | is_decdigit c -> parseNum is_decdigit 10 octDecDigit cs+  -- control characters (e.g. '\^M')+  Char '^' : Char c : cs -> pure (chr $ ord c - ord '@', cs)+  -- long form escapes (e.g. '\NUL')+  cs | Just (esc, cs') <- parseLongEscape cs -> pure (esc, cs')+  -- shouldn't happen+  Char c : _ -> panic $ "found unexpected escape character: " ++ show c+  [] -> panic "escape character unexpectedly ended"+  where+    parseNum isDigit base toDigit =+      let go x = \case+            ch@(Char c) : cs | isDigit c -> do+              let x' = x * base + toDigit c+              when (x' > 0x10ffff) $ Left (ch, LexNumEscapeRange)+              go x' cs+            cs -> pure (chr x, cs)+       in go 0++parseLongEscape :: HasChar c => [c] -> Maybe (Char, [c])+parseLongEscape cs = listToMaybe (mapMaybe tryParse longEscapeCodes)+  where+    tryParse (code, esc) =+      case splitAt (length code) cs of+        (pre, cs') | map getChar pre == code -> Just (esc, cs')+        _ -> Nothing++    longEscapeCodes =+      [ ("NUL", '\NUL')+      , ("SOH", '\SOH')+      , ("STX", '\STX')+      , ("ETX", '\ETX')+      , ("EOT", '\EOT')+      , ("ENQ", '\ENQ')+      , ("ACK", '\ACK')+      , ("BEL", '\BEL')+      , ("BS" , '\BS' )+      , ("HT" , '\HT' )+      , ("LF" , '\LF' )+      , ("VT" , '\VT' )+      , ("FF" , '\FF' )+      , ("CR" , '\CR' )+      , ("SO" , '\SO' )+      , ("SI" , '\SI' )+      , ("DLE", '\DLE')+      , ("DC1", '\DC1')+      , ("DC2", '\DC2')+      , ("DC3", '\DC3')+      , ("DC4", '\DC4')+      , ("NAK", '\NAK')+      , ("SYN", '\SYN')+      , ("ETB", '\ETB')+      , ("CAN", '\CAN')+      , ("EM" , '\EM' )+      , ("SUB", '\SUB')+      , ("ESC", '\ESC')+      , ("FS" , '\FS' )+      , ("GS" , '\GS' )+      , ("RS" , '\RS' )+      , ("US" , '\US' )+      , ("SP" , '\SP' )+      , ("DEL", '\DEL')+      ]++-- -----------------------------------------------------------------------------+-- Unicode Smart Quote detection (#21843)++isDoubleSmartQuote :: Char -> Bool+isDoubleSmartQuote = \case+  '“' -> True+  '”' -> True+  _ -> False++isSingleSmartQuote :: Char -> Bool+isSingleSmartQuote = \case+  '‘' -> True+  '’' -> True+  _ -> False++-- -----------------------------------------------------------------------------+-- Multiline strings++-- | See Note [Multiline string literals]+--+-- Assumes string is lexically valid. Skips the steps about splitting+-- and rejoining lines, and instead manually find newline characters,+-- for performance.+lexMultilineString :: Int -> StringBuffer -> Either StringLexError String+lexMultilineString = lexStringWith processChars processChars+  where+    processChars :: HasChar c => [c] -> Either (c, LexErr) [c]+    processChars =+          collapseGaps             -- Step 1+      >>> normalizeEOL+      >>> expandLeadingTabs        -- Step 3+      >>> rmCommonWhitespacePrefix -- Step 4+      >>> collapseOnlyWsLines      -- Step 5+      >>> rmFirstNewline           -- Step 7a+      >>> rmLastNewline            -- Step 7b+      >>> resolveEscapes           -- Step 8++    -- Normalize line endings to LF. The spec dictates that lines should be+    -- split on newline characters and rejoined with ``\n``. But because we+    -- aren't actually splitting/rejoining, we'll manually normalize here+    normalizeEOL :: HasChar c => [c] -> [c]+    normalizeEOL =+      let go = \case+            Char '\r' : c@(Char '\n') : cs -> c : go cs+            c@(Char '\r') : cs -> setChar '\n' c : go cs+            c@(Char '\f') : cs -> setChar '\n' c : go cs+            c : cs -> c : go cs+            [] -> []+       in go++    -- expands all tabs, since the lexer will verify that tabs can only appear+    -- as leading indentation+    expandLeadingTabs :: HasChar c => [c] -> [c]+    expandLeadingTabs =+      let go !col = \case+            c@(Char '\t') : cs ->+              let fill = 8 - (col `mod` 8)+               in replicate fill (setChar ' ' c) ++ go (col + fill) cs+            c : cs -> c : go (if getChar c == '\n' then 0 else col + 1) cs+            [] -> []+       in go 0++    rmCommonWhitespacePrefix :: HasChar c => [c] -> [c]+    rmCommonWhitespacePrefix cs0 =+      let commonWSPrefix = getCommonWsPrefix (map getChar cs0)+          go = \case+            c@(Char '\n') : cs -> c : go (dropLine commonWSPrefix cs)+            c : cs -> c : go cs+            [] -> []+          -- drop x characters from the string, or up to a newline, whichever+          -- comes first+          dropLine !x = \case+            cs | x <= 0 -> cs+            cs@(Char '\n' : _) -> cs+            _ : cs -> dropLine (x - 1) cs+            [] -> []+       in go cs0++    collapseOnlyWsLines :: HasChar c => [c] -> [c]+    collapseOnlyWsLines =+      let go = \case+            c@(Char '\n') : cs | Just cs' <- checkAllWs cs -> c : go cs'+            c : cs -> c : go cs+            [] -> []+          checkAllWs = \case+            -- got all the way to a newline or the end of the string, return+            cs@(Char '\n' : _) -> Just cs+            cs@[] -> Just cs+            -- found whitespace, continue+            Char c : cs | is_space c -> checkAllWs cs+            -- anything else, stop+            _ -> Nothing+       in go++    rmFirstNewline :: HasChar c => [c] -> [c]+    rmFirstNewline = \case+      Char '\n' : cs -> cs+      cs -> cs++    rmLastNewline :: HasChar c => [c] -> [c]+    rmLastNewline =+      let go = \case+            [] -> []+            [Char '\n'] -> []+            c : cs -> c : go cs+       in go++-- | See step 4 in Note [Multiline string literals]+--+-- Assumes tabs have already been expanded.+getCommonWsPrefix :: String -> Int+getCommonWsPrefix s =+  case NonEmpty.nonEmpty includedLines of+    Nothing -> 0+    Just ls -> Foldable1.minimum $ NonEmpty.map (length . takeWhile is_space) ls+  where+    includedLines =+        filter (not . all is_space) -- ignore whitespace-only lines+      . drop 1                      -- ignore first line in calculation+      $ lines s++{-+Note [Multiline string literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Multiline string literals were added following the acceptance of the+proposal: https://github.com/ghc-proposals/ghc-proposals/pull/569++Multiline string literals are syntax sugar for normal string literals,+with an extra post processing step. This all happens in the Lexer; that+is, HsMultilineString will contain the post-processed string. This matches+the same behavior as HsString, which contains the normalized string+(see Note [Literal source text]).++The canonical steps for post processing a multiline string are:+1. Collapse string gaps+2. Split the string by newlines+3. Convert leading tabs into spaces+    * In each line, any tabs preceding non-whitespace characters are replaced with spaces up to the next tab stop+4. Remove common whitespace prefix in every line except the first (see below)+5. If a line contains only whitespace, remove all of the whitespace+6. Join the string back with `\n` delimiters+7a. If the first character of the string is a newline, remove it+7b. If the last character of the string is a newline, remove it+8. Interpret escaped characters++The common whitespace prefix can be informally defined as "The longest+prefix of whitespace shared by all lines in the string, excluding the+first line and any whitespace-only lines".++It's more precisely defined with the following algorithm:++1. Take a list representing the lines in the string+2. Ignore the following elements in the list:+    * The first line (we want to ignore everything before the first newline)+    * Empty lines+    * Lines with only whitespace characters+3. Calculate the longest prefix of whitespace shared by all lines in the remaining list+-}++-- -----------------------------------------------------------------------------+-- DList++newtype DList a = DList ([a] -> [a])++dlistEmpty :: DList a+dlistEmpty = DList id++dlistToList :: DList a -> [a]+dlistToList (DList f) = f []++dlistSnoc :: DList a -> a -> DList a+dlistSnoc (DList f) x = DList (f . (x :))
compiler/GHC/Parser/Types.hs view
@@ -8,6 +8,7 @@    , pprSumOrTuple    , PatBuilder(..)    , DataConBuilder(..)+   , ExplicitNamespaceKeyword(..)    ) where @@ -27,9 +28,9 @@ import Language.Haskell.Syntax  data SumOrTuple b-  = Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation]+  = Sum ConTag Arity (LocatedA b) [EpToken "|"] [EpToken "|"]   -- ^ Last two are the locations of the '|' before and after the payload-  | Tuple [Either (EpAnn EpaLocation) (LocatedA b)]+  | Tuple [Either (EpAnn Bool) (LocatedA b)]  pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc pprSumOrTuple boxity = \case@@ -53,14 +54,20 @@ -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p   = PatBuilderPat (Pat p)-  | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p)+  | PatBuilderPar (EpToken "(") (LocatedA (PatBuilder p)) (EpToken ")")   | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))-  | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs)+  | PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs)   | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)-                    (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn])+                    (LocatedA (PatBuilder p)) ([EpToken "("], [EpToken ")"])   | PatBuilderVar (LocatedN RdrName)   | PatBuilderOverLit (HsOverLit GhcPs) +-- These instances are here so that they are not orphans+type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs)))             = EpAnnCO+type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW+type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs)))            = SrcSpanAnnA+type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))     = SrcSpanAnnA+ instance Outputable (PatBuilder GhcPs) where   ppr (PatBuilderPat p) = ppr p   ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p)@@ -104,4 +111,8 @@   ppr (InfixDataConBuilder lhs data_con rhs) =     ppr lhs <+> ppr data_con <+> ppr rhs -type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL+type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW++data ExplicitNamespaceKeyword+  = ExplicitTypeNamespace !(EpToken "type")+  | ExplicitDataNamespace !(EpToken "data")
compiler/GHC/Platform.hs view
@@ -17,6 +17,7 @@    , ByteOrder(..)    , target32Bit    , isARM+   , isPPC    , osElfTarget    , osMachOTarget    , osSubsectionsViaSymbols@@ -29,6 +30,7 @@    , platformInIntRange    , platformInWordRange    , platformCConvNeedsExtension+   , platformHasRTSLinker    , PlatformMisc(..)    , SseVersion (..)    , BmiVersion (..)@@ -73,12 +75,15 @@    , platformHasGnuNonexecStack       :: !Bool    , platformHasIdentDirective        :: !Bool    , platformHasSubsectionsViaSymbols :: !Bool+      -- ^ Enable Darwin .subsections_via_symbols directive+      --+      -- See Note [Subsections Via Symbols] in GHC.CmmToAsm.X86.Ppr    , platformIsCrossCompiling         :: !Bool    , platformLeadingUnderscore        :: !Bool             -- ^ Symbols need underscore prefix    , platformTablesNextToCode         :: !Bool       -- ^ Determines whether we will be compiling info tables that reside just       --   before the entry code, or with an indirection to the entry code. See-      --   TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h.+      --   TABLES_NEXT_TO_CODE in @rts/include/rts/storage/InfoTables.h@.    , platformHasLibm                  :: !Bool       -- ^ Some platforms require that we explicitly link against @libm@ if any       -- math-y things are used (which we assume to include all programs). See@@ -179,11 +184,6 @@ platformOS platform = case platformArchOS platform of    ArchOS _ os -> os -isARM :: Arch -> Bool-isARM (ArchARM {}) = True-isARM ArchAArch64  = True-isARM _ = False- -- | This predicate tells us whether the platform is 32-bit. target32Bit :: Platform -> Bool target32Bit p =@@ -191,34 +191,6 @@       PW4 -> True       PW8 -> False --- | This predicate tells us whether the OS supports ELF-like shared libraries.-osElfTarget :: OS -> Bool-osElfTarget OSLinux     = True-osElfTarget OSFreeBSD   = True-osElfTarget OSDragonFly = True-osElfTarget OSOpenBSD   = True-osElfTarget OSNetBSD    = True-osElfTarget OSSolaris2  = True-osElfTarget OSDarwin    = False-osElfTarget OSMinGW32   = False-osElfTarget OSKFreeBSD  = True-osElfTarget OSHaiku     = True-osElfTarget OSQNXNTO    = False-osElfTarget OSAIX       = False-osElfTarget OSHurd      = True-osElfTarget OSWasi      = False-osElfTarget OSGhcjs     = False-osElfTarget OSUnknown   = False- -- Defaulting to False is safe; it means don't rely on any- -- ELF-specific functionality.  It is important to have a default for- -- portability, otherwise we have to answer this question for every- -- new platform we compile on (even unreg).---- | This predicate tells us whether the OS support Mach-O shared libraries.-osMachOTarget :: OS -> Bool-osMachOTarget OSDarwin = True-osMachOTarget _ = False- osUsesFrameworks :: OS -> Bool osUsesFrameworks OSDarwin = True osUsesFrameworks _        = False@@ -272,7 +244,22 @@     | OSDarwin <- platformOS platform -> True   _            -> False +-- | Does this platform have an RTS linker?+platformHasRTSLinker :: Platform -> Bool+-- Note that we've inlined this logic in hadrian's+-- Settings.Builders.RunTest.inTreeCompilerArgs.+-- If you change this, be sure to change it too+platformHasRTSLinker p = case archOS_arch (platformArchOS p) of+  ArchPPC           -> False -- powerpc+  ArchPPC_64 ELF_V1 -> False -- powerpc64+  ArchPPC_64 ELF_V2 -> False -- powerpc64le+  ArchS390X         -> False+  ArchLoongArch64   -> False+  ArchJavaScript    -> False+  _                 -> True ++ -------------------------------------------------- -- Instruction sets --------------------------------------------------@@ -282,6 +269,7 @@    = SSE1    | SSE2    | SSE3+   | SSSE3    | SSE4    | SSE42    deriving (Eq, Ord)@@ -302,6 +290,7 @@   , platformMisc_ghcWithInterpreter   :: Bool   , platformMisc_libFFI               :: Bool   , platformMisc_llvmTarget           :: String+  , platformMisc_targetRTSLinkerOnlySupportsSharedLibs :: Bool   }  platformSOName :: Platform -> FilePath -> FilePath
+ 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/Reg.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MagicHash #-}+ -- | An architecture independent description of a register. --      This needs to stay architecture independent because it is used --      by NCGMonad and the register allocators, which are shared@@ -27,12 +29,17 @@ where  import GHC.Prelude+import GHC.Exts ( Int(I#), dataToTag# )  import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Platform.Reg.Class+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.Separate  as Separate+import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors+import GHC.Platform.ArchOS  -- | An identifier for a primitive real machine register. type RegNo@@ -53,72 +60,68 @@ --      Virtual regs can be of either class, so that info is attached. -- data VirtualReg-        = VirtualRegI  {-# UNPACK #-} !Unique-        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register-        | VirtualRegF  {-# UNPACK #-} !Unique-        | VirtualRegD  {-# UNPACK #-} !Unique--        deriving (Eq, Show)+   -- | Integer virtual register+   = VirtualRegI    { virtualRegUnique :: {-# UNPACK #-} !Unique }+   -- | High part of 2-word virtual register+   | VirtualRegHi   { virtualRegUnique :: {-# UNPACK #-} !Unique }+   -- | Double virtual register+   | VirtualRegD    { virtualRegUnique :: {-# UNPACK #-} !Unique }+   -- | 128-bit wide vector virtual register+   | VirtualRegV128 { virtualRegUnique :: {-# UNPACK #-} !Unique }+   deriving (Eq, Show) --- This is laborious, but necessary. We can't derive Ord because--- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the--- implementation. See Note [No Ord for Unique]+-- We can't derive Ord, because Unique doesn't have an Ord instance.+-- Note nonDetCmpUnique in the implementation. See Note [No Ord for Unique]. -- This is non-deterministic but we do not currently support deterministic -- code-generation. See Note [Unique Determinism and code generation] instance Ord VirtualReg where-  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b-  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b-  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b-  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b--  compare VirtualRegI{} _ = LT-  compare _ VirtualRegI{} = GT-  compare VirtualRegHi{} _ = LT-  compare _ VirtualRegHi{} = GT-  compare VirtualRegF{} _ = LT-  compare _ VirtualRegF{} = GT--+  compare vr1 vr2 =+    case compare (I# (dataToTag# vr1)) (I# (dataToTag# vr2)) of+      LT -> LT+      GT -> GT+      EQ -> nonDetCmpUnique (virtualRegUnique vr1) (virtualRegUnique vr2)  instance Uniquable VirtualReg where-        getUnique reg-         = case reg of-                VirtualRegI u   -> u-                VirtualRegHi u  -> u-                VirtualRegF u   -> u-                VirtualRegD u   -> u+        getUnique = virtualRegUnique  instance Outputable VirtualReg where         ppr reg          = case reg of-                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u-                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u-                -- this code is kinda wrong on x86-                -- because float and double occupy the same register set-                -- namely SSE2 register xmm0 .. xmm15-                VirtualRegF  u  -> text "%vFloat_"   <> pprUniqueAlways u-                VirtualRegD  u  -> text "%vDouble_"   <> pprUniqueAlways u-+                VirtualRegI    u -> text "%vI_"   <> pprUniqueAlways u+                VirtualRegHi   u -> text "%vHi_"  <> pprUniqueAlways u+                VirtualRegD    u -> text "%vDouble_" <> pprUniqueAlways u+                VirtualRegV128 u -> text "%vV128_"   <> pprUniqueAlways u   renameVirtualReg :: Unique -> VirtualReg -> VirtualReg-renameVirtualReg u r- = case r of-        VirtualRegI _   -> VirtualRegI  u-        VirtualRegHi _  -> VirtualRegHi u-        VirtualRegF _   -> VirtualRegF  u-        VirtualRegD _   -> VirtualRegD  u---classOfVirtualReg :: VirtualReg -> RegClass-classOfVirtualReg vr- = case vr of-        VirtualRegI{}   -> RcInteger-        VirtualRegHi{}  -> RcInteger-        VirtualRegF{}   -> RcFloat-        VirtualRegD{}   -> RcDouble-+renameVirtualReg u r = r { virtualRegUnique = u } +classOfVirtualReg :: Arch -> VirtualReg -> RegClass+classOfVirtualReg arch vr+  = case vr of+        VirtualRegI{} ->+          case regArch of+            Unified   ->   Unified.RcInteger+            Separate  ->  Separate.RcInteger+            NoVectors -> NoVectors.RcInteger+        VirtualRegHi{} ->+          case regArch of+            Unified   ->   Unified.RcInteger+            Separate  ->  Separate.RcInteger+            NoVectors -> NoVectors.RcInteger+        VirtualRegD{} ->+          case regArch of+            Unified   ->   Unified.RcFloatOrVector+            Separate  ->  Separate.RcFloat+            NoVectors -> NoVectors.RcFloat+        VirtualRegV128{} ->+          case regArch of+            Unified   ->  Unified.RcFloatOrVector+            Separate  -> Separate.RcVector+            NoVectors -> pprPanic "classOfVirtualReg VirtualRegV128"+                           ( text "arch:" <+> text ( show arch ) )+  where+    regArch = registerArch arch  -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform -- when supplied with the vreg for the lower-half of the quantity.
compiler/GHC/Platform/Reg/Class.hs view
@@ -1,33 +1,56 @@--- | An architecture independent description of a register's class.+{-# LANGUAGE LambdaCase #-} module GHC.Platform.Reg.Class-        ( RegClass (..) )-+  ( RegClass (..), RegArch(..), registerArch ) where  import GHC.Prelude -import GHC.Utils.Outputable as Outputable import GHC.Types.Unique-import GHC.Builtin.Uniques+import GHC.Builtin.Uniques ( mkRegClassUnique )+import GHC.Platform.ArchOS+import GHC.Utils.Outputable ( Outputable(ppr), text )   -- | The class of a register. --      Used in the register allocator. --      We treat all registers in a class as being interchangeable. ---data RegClass-        = RcInteger-        | RcFloat-        | RcDouble-        deriving Eq-+newtype RegClass = RegClass Int+  deriving ( Eq, Ord, Show )  instance Uniquable RegClass where-    getUnique RcInteger = mkRegClassUnique 0-    getUnique RcFloat   = mkRegClassUnique 1-    getUnique RcDouble  = mkRegClassUnique 2+  getUnique ( RegClass i ) = mkRegClassUnique i +-- | This instance is just used for the graph colouring register allocator.+-- Prefer using either 'GHC.Platform.Reg.Class.Separate.pprRegClass'+-- or 'GHC.Platform.Reg.Class.Unified.pprRegClass', which is more informative. instance Outputable RegClass where-    ppr RcInteger       = Outputable.text "I"-    ppr RcFloat         = Outputable.text "F"-    ppr RcDouble        = Outputable.text "D"+  ppr (RegClass i) = ppr i++-- | The register architecture of a given machine.+data RegArch+  -- | Floating-point and vector registers are unified (e.g. X86, AArch64).+  = Unified+  -- | Floating-point and vector registers are separate (e.g. RISC-V).+  | Separate+  -- | No vector registers.+  | NoVectors+  deriving ( Eq, Ord, Show )++instance Outputable RegArch where+  ppr regArch = text (show regArch)++-- | What is the register architecture of the given architecture?+registerArch :: Arch -> RegArch+registerArch arch =+  case arch of+    ArchX86       -> Unified+    ArchX86_64    -> Unified+    ArchPPC       -> Unified+    ArchPPC_64 {} -> Unified+    ArchAArch64   -> Unified+    -- Support for vector registers not yet implemented for RISC-V+    -- see panic in `getFreeRegs`.+    --ArchRISCV64   -> Separate+    ArchRISCV64   -> NoVectors+    _             -> NoVectors
+ compiler/GHC/Platform/Reg/Class/NoVectors.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Register classes for architectures which don't have any vector registers.+module GHC.Platform.Reg.Class.NoVectors+  ( RegClass ( RcInteger, RcFloat )+  , pprRegClass, allRegClasses+  )++where++import GHC.Utils.Outputable ( SDoc, text )+import GHC.Platform.Reg.Class ( RegClass(..) )++pattern RcInteger, RcFloat :: RegClass+pattern RcInteger = RegClass 0+pattern RcFloat   = RegClass 1+{-# COMPLETE RcInteger, RcFloat #-}++pprRegClass :: RegClass -> SDoc+pprRegClass = \case+  RcInteger -> text "I"+  RcFloat   -> text "F"++allRegClasses :: [RegClass]+allRegClasses = [RcInteger, RcFloat]
+ compiler/GHC/Platform/Reg/Class/Separate.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Register classes for architectures which have registers+-- for scalar floating-point values that are separate from all vector registers.+module GHC.Platform.Reg.Class.Separate+  ( RegClass ( RcInteger, RcFloat, RcVector )+  , pprRegClass, allRegClasses+  )++where++import GHC.Utils.Outputable ( SDoc, text )+import GHC.Platform.Reg.Class ( RegClass(..) )++pattern RcInteger, RcFloat, RcVector :: RegClass+pattern RcInteger = RegClass 0+pattern RcFloat   = RegClass 1+pattern RcVector  = RegClass 2+{-# COMPLETE RcInteger, RcFloat, RcVector #-}++pprRegClass :: RegClass -> SDoc+pprRegClass = \case+  RcInteger -> text "I"+  RcFloat   -> text "F"+  RcVector  -> text "V"++allRegClasses :: [RegClass]+allRegClasses = [RcInteger, RcFloat, RcVector]
+ compiler/GHC/Platform/Reg/Class/Unified.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Register classes for architectures which don't have separate registers+-- for scalar floating-point values separate from vector registers.+module GHC.Platform.Reg.Class.Unified+  ( RegClass ( RcInteger, RcFloatOrVector )+  , pprRegClass, allRegClasses+  )++where++import GHC.Utils.Outputable ( SDoc, text )+import GHC.Platform.Reg.Class ( RegClass(..) )++pattern RcInteger, RcFloatOrVector :: RegClass+pattern RcInteger       = RegClass 0+pattern RcFloatOrVector = RegClass 1+{-# COMPLETE RcInteger, RcFloatOrVector #-}++pprRegClass :: RegClass -> SDoc+pprRegClass = \case+  RcInteger       -> text "I"+  RcFloatOrVector -> text "F"++allRegClasses :: [RegClass]+allRegClasses = [RcInteger, RcFloatOrVector]
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/Wasm32.hs view
@@ -4,7 +4,6 @@  import GHC.Prelude --- TODO-#define MACHREGS_NO_REGS 1--- #define MACHREGS_wasm32 1+#define MACHREGS_NO_REGS 0+#define MACHREGS_wasm32 1 #include "CodeGen.Platform.h"
compiler/GHC/Platform/Ways.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  -- | Ways --@@ -31,6 +30,7 @@    , wayGeneralFlags    , wayUnsetGeneralFlags    , wayOptc+   , wayOptcxx    , wayOptl    , wayOptP    , wayDesc@@ -177,6 +177,9 @@ wayOptc _ WayDyn        = [] wayOptc _ WayProf       = ["-DPROFILING"] +wayOptcxx :: Platform -> Way -> [String]+wayOptcxx = wayOptc -- Use the same flags as C+ -- | Pass these options to linker when enabling this way wayOptl :: Platform -> Way -> [String] wayOptl _ (WayCustom {}) = []@@ -216,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@@ -238,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
@@ -2,6 +2,9 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] +-- See Note [Proxies for head and tail]+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}+ -- | Custom minimal GHC "Prelude" -- -- This module serves as a replacement for the "Prelude" module@@ -10,15 +13,20 @@  -- Every module in GHC --   * Is compiled with -XNoImplicitPrelude---   * Explicitly imports GHC.BasicPrelude or GHC.Prelude+--   * Explicitly imports GHC.Prelude.Basic or GHC.Prelude --   * The later provides some functionality with within ghc itself --     like pprTrace.  module GHC.Prelude.Basic-  (module X-  ,Applicative (..)-  ,module Bits-  ,shiftL, shiftR+  ( module X+  , Applicative (..)+  , module Bits+  , bit+  , shiftL, shiftR+  , setBit, clearBit+  , head, tail, unzip++  , strictGenericLength   ) where  @@ -50,29 +58,26 @@     extensions. -} -import Prelude as X hiding ((<>), Applicative(..))+import qualified Prelude+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) import Control.Applicative (Applicative(..))-import Data.Foldable as X (foldl')+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 (shiftL, shiftR)+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 (shiftL, shiftR)-# if defined(DEBUG)-import qualified Data.Bits as Bits (shiftL, shiftR)-# endif-#endif  {- Note [Default to unsafe shifts inside GHC]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The safe shifts can introduce branches which come at the cost of performance. We still want the additional-debugability for debug builds. So we define it as one or the+debuggability for debug builds. So we define it as one or the other depending on the DEBUG setting.  Why do we then continue on to re-export the rest of Data.Bits?@@ -102,3 +107,50 @@ shiftL = Bits.unsafeShiftL shiftR = Bits.unsafeShiftR #endif++{-# INLINE bit #-}+bit :: (Num a, Bits.Bits a) => Int -> a+bit = \ i -> 1 `shiftL` i+{-# INLINE setBit #-}+setBit :: (Num a, Bits.Bits a) => a -> Int -> a+setBit = \ x i -> x Bits..|. bit i+{-# INLINE clearBit #-}+clearBit :: (Num a, Bits.Bits a) => a -> Int -> a+clearBit = \ x i -> x Bits..&. Bits.complement (bit i)++{- Note [Proxies for head and tail]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-},+but the GHC codebase uses them fairly extensively and insists on building warning-free.+Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which+employs them, we define warning-less proxies and export them from GHC.Prelude.+-}++-- See Note [Proxies for head and tail]+head :: HasCallStack => [a] -> a+head = Prelude.head+{-# INLINE head #-}++-- See Note [Proxies for head and tail]+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
@@ -8,6 +8,7 @@    , substInteractiveContext    , replaceImportEnv    , icReaderEnv+   , icExtendGblRdrEnv    , icInteractiveModule    , icInScopeTTs    , icNamePprCtx@@ -18,7 +19,7 @@  import GHC.Hs -import GHC.Driver.Session+import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Plugins  import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )@@ -30,7 +31,7 @@ import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Types.Avail+import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name@@ -94,7 +95,7 @@    call to initTc in initTcInteractive, which in turn get the module    from it 'icInteractiveModule' field of the interactive context. -   The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says.+   The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says).   * The main trickiness is that the type environment (tcg_type_env) and    fixity envt (tcg_fix_env), now contain entities from all the@@ -114,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@@ -185,10 +231,13 @@ Note [icReaderEnv recalculation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The GlobalRdrEnv describing what’s in scope at the prompts consists-of all the imported things, followed by all the things defined on the prompt, with-shadowing. Defining new things on the prompt is easy: we shadow as needed and then extend the environment.  But changing the set of imports, which can happen later as well,-is tricky: we need to re-apply the shadowing from all the things defined at the prompt!+of all the imported things, followed by all the things defined on the prompt,+with shadowing. Defining new things on the prompt is easy: we shadow as needed,+and then extend the environment. +But changing the set of imports, which can happen later as well, is tricky+we need to re-apply the shadowing from all the things defined at the prompt!+ For example:      ghci> let empty = True@@ -196,22 +245,21 @@     ghci> empty   -- Still gets the 'empty' defined at the prompt     True --It would be correct ot re-construct the env from scratch based on+It would be correct to re-construct the env from scratch based on `ic_tythings`, but that'd be quite expensive if there are many entries in `ic_tythings` that shadow each other. -Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that-contians _just_ the things defined at the prompt, and use that in-`replaceImportEnv` to rebuild the full env.  Conveniently, `shadowNames` takes-such an `OccEnv` to denote the set of names to shadow.+Therefore we keep around a `GlobalRdrEnv` in `igre_prompt_env` that contains+_just_ the things defined at the prompt, and use that in `replaceImportEnv` to+rebuild the full env.  Conveniently, `shadowNames` takes such an `OccEnv`+to denote the set of names to shadow.  INVARIANT: Every `OccName` in `igre_prompt_env` is present unqualified as well-(else it would not be right to use pass `igre_prompt_env` to `shadowNames`.)+(else it would not be right to pass `igre_prompt_env` to `shadowNames`.) -The definition of the IcGlobalRdrEnv type should conceptually be in this module, and-made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type.--+The definition of the IcGlobalRdrEnv type should conceptually be in this module,+and made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type.+ -}  -- | Interactive context, recording information about the state of the@@ -267,8 +315,8 @@          ic_fix_env :: FixityEnv,             -- ^ Fixities declared in let statements -         ic_default :: Maybe [Type],-             -- ^ The current default types, set by a 'default' declaration+         ic_default :: DefaultEnv,+             -- ^ The current default classes and types, set by 'default' declarations           ic_resume :: [Resume],              -- ^ The stack of breakpoint contexts@@ -293,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.@@ -317,7 +365,7 @@        ic_fix_env    = emptyNameEnv,        ic_monad      = ioTyConName,  -- IO monad by default        ic_int_print  = printName,    -- System.IO.print by default-       ic_default    = Nothing,+       ic_default    = emptyDefaultEnv,        ic_resume     = [],        ic_cwd        = Nothing,        ic_plugins    = emptyPlugins@@ -328,7 +376,7 @@  icInteractiveModule :: InteractiveContext -> Module icInteractiveModule (InteractiveContext { ic_mod_index = index })-  = mkInteractiveModule index+  = mkInteractiveModule (show index)  -- | This function returns the list of visible TyThings (useful for -- e.g. showBindings).@@ -343,12 +391,11 @@   where     in_scope_unqualified thing = or         [ unQualOK gre-        | avail <- tyThingAvailInfo thing-        , name <- availNames avail+        | gre <- tyThingLocalGREs thing+        , let name = greName gre         , Just gre <- [lookupGRE_Name (icReaderEnv ictxt) name]         ] - -- | Get the NamePprCtx function based on the flags and this InteractiveContext icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)@@ -361,7 +408,7 @@ extendInteractiveContext :: InteractiveContext                          -> [TyThing]                          -> InstEnv -> [FamInst]-                         -> Maybe [Type]+                         -> DefaultEnv                          -> FixityEnv                          -> InteractiveContext extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env@@ -400,8 +447,11 @@  icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv icExtendIcGblRdrEnv igre tythings = IcGlobalRdrEnv-    { igre_env = igre_env igre `icExtendGblRdrEnv` tythings-    , igre_prompt_env = igre_prompt_env igre `icExtendGblRdrEnv` tythings+    { igre_env        = icExtendGblRdrEnv False (igre_env igre)        tythings+    , igre_prompt_env = icExtendGblRdrEnv True  (igre_prompt_env igre) tythings+        -- Pass 'True' <=> drop names that are only available qualified.+        -- This is done to maintain the invariant of Note [icReaderEnv recalculation]+        -- that igre_prompt_env should only contain Names that are available unqualified.     }  -- This is used by setContext in GHC.Runtime.Eval when the set of imports@@ -409,13 +459,14 @@ replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv replaceImportEnv igre import_env = igre { igre_env = new_env }   where-    import_env_shadowed = import_env `shadowNames` igre_prompt_env igre+    import_env_shadowed = shadowNames False import_env (igre_prompt_env igre)     new_env = import_env_shadowed `plusGlobalRdrEnv` igre_prompt_env igre --- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing--- later ones, and shadowing existing entries in the GlobalRdrEnv.-icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv-icExtendGblRdrEnv env tythings+-- | Add 'TyThings' to the 'GlobalRdrEnv', earlier ones in the list shadowing+-- later ones, and shadowing existing entries in the 'GlobalRdrEnv'.+icExtendGblRdrEnv :: Bool -- ^ discard names that are only available qualified?+                  -> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv+icExtendGblRdrEnv drop_only_qualified env tythings   = foldr add env tythings  -- Foldr makes things in the front of                             -- the list shadow things at the back   where@@ -424,12 +475,10 @@        | is_sub_bndr thing        = env        | otherwise-       = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)+       = foldl' extendGlobalRdrEnv env1 new_gres        where-          new_gres = concatMap availGreNames avail-          new_occs = occSetToEnv (mkOccSet (map occName new_gres))-          env1  = shadowNames env new_occs-          avail = tyThingAvailInfo thing+          new_gres = tyThingLocalGREs thing+          env1     = shadowNames drop_only_qualified env $ mkGlobalRdrEnv new_gres      -- Ugh! The new_tythings may include record selectors, since they     -- are not implicit-ids, and must appear in the TypeEnv.  But they
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.BreakInfo import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception@@ -35,23 +37,123 @@      , 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-       { breakNames :: [Name]-       , breakInfo :: Maybe BreakInfo++    -- | 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        }  -- | Essentially a GlobalRdrEnv, but with additional cached values to allow@@ -73,11 +175,10 @@        , resumeFinalIds  :: [Id]         -- [Id] to bind on completion        , resumeApStack   :: ForeignHValue -- The object from which we can get                                         -- value of the free variables.-       , resumeBreakInfo :: Maybe BreakInfo-                                        -- the breakpoint we stopped at-                                        -- (module, index)+       , resumeBreakpointId :: Maybe InternalBreakpointId+                                        -- ^ the internal breakpoint we stopped at                                         -- (Nothing <=> exception)-       , resumeSpan      :: SrcSpan      -- just a copy of the SrcSpan+       , resumeSpan      :: SrcSpan     -- just a copy of the SrcSpan                                         -- from the ModBreaks,                                         -- otherwise it's a pain to                                         -- fetch the ModDetails &@@ -90,9 +191,8 @@  type ResumeBindings = ([TyThing], IcGlobalRdrEnv) -data History-   = History {-        historyApStack   :: ForeignHValue,-        historyBreakInfo :: BreakInfo,-        historyEnclosingDecls :: [String]  -- declarations enclosing the breakpoint-   }+data History = History+  { historyApStack        :: ForeignHValue+  , historyBreakpointId   :: InternalBreakpointId -- ^ breakpoint identifier+  , historyEnclosingDecls :: [String]             -- ^ declarations enclosing the breakpoint+  }
− compiler/GHC/Runtime/Interpreter.hs 
@@ -1,783 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}---- | Interacting with the iserv interpreter, whether it is running on an--- external process or in the current process.----module GHC.Runtime.Interpreter-  ( module GHC.Runtime.Interpreter.Types--  -- * High-level interface to the interpreter-  , BCOOpts (..)-  , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)-  , resumeStmt-  , abandonStmt-  , evalIO-  , evalString-  , evalStringToIOString-  , mallocData-  , createBCOs-  , addSptEntry-  , mkCostCentres-  , costCentreStackInfo-  , newBreakArray-  , newModuleName-  , storeBreakpoint-  , breakpointStatus-  , getBreakpointVar-  , getClosure-  , getModBreaks-  , seqHValue-  , interpreterDynamic-  , interpreterProfiled--  -- * The object-code linker-  , initObjLinker-  , lookupSymbol-  , lookupClosure-  , loadDLL-  , loadArchive-  , loadObj-  , unloadObj-  , addLibrarySearchPath-  , removeLibrarySearchPath-  , resolveObjs-  , findSystemLibrary--  -- * Lower-level API using messages-  , interpCmd, Message(..), withIServ, withIServ_-  , stopInterp-  , iservCall, readIServ, writeIServ-  , purgeLookupSymbolCache-  , freeHValueRefs-  , mkFinalizedHValue-  , wormhole, wormholeRef-  , fromEvalResult-  ) where--import GHC.Prelude--import GHC.IO (catchException)--import GHC.Runtime.Interpreter.Types-import GHCi.Message-import GHCi.RemoteTypes-import GHCi.ResolvedBCO-import GHCi.BreakArray (BreakArray)-import GHC.Types.BreakInfo (BreakInfo(..))-import GHC.ByteCode.Types--import GHC.Linker.Types--import GHC.Data.Maybe-import GHC.Data.FastString--import GHC.Types.SrcLoc-import GHC.Types.Unique.FM-import GHC.Types.Basic--import GHC.Utils.Panic-import GHC.Utils.Exception as Ex-import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)-import GHC.Utils.Fingerprint-import GHC.Utils.Misc--import GHC.Unit.Module-import GHC.Unit.Module.ModIface-import GHC.Unit.Home.ModInfo-import GHC.Unit.Env--#if defined(HAVE_INTERNAL_INTERPRETER)-import GHCi.Run-import GHC.Platform.Ways-#endif--import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Catch as MC (mask, onException)-import Data.Binary-import Data.Binary.Put-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as LB-import Data.Array ((!))-import Data.IORef-import Foreign hiding (void)-import qualified GHC.Exts.Heap as Heap-import GHC.Stack.CCS (CostCentre,CostCentreStack)-import System.Exit-import GHC.IO.Handle.Types (Handle)-#if defined(mingw32_HOST_OS)-import Foreign.C-import GHC.IO.Handle.FD (fdToHandle)-# if defined(__IO_MANAGER_WINIO__)-import GHC.IO.SubSystem ((<!>))-import GHC.IO.Handle.Windows (handleToHANDLE)-import GHC.Event.Windows (associateHandle')-# endif-#else-import System.Posix as Posix-#endif-import System.Directory-import System.Process-import GHC.Conc (pseq, par)--{- Note [Remote GHCi]-   ~~~~~~~~~~~~~~~~~~-When the flag -fexternal-interpreter is given to GHC, interpreted code-is run in a separate process called iserv, and we communicate with the-external process over a pipe using Binary-encoded messages.--Motivation-~~~~~~~~~~--When the interpreted code is running in a separate process, it can-use a different "way", e.g. profiled or dynamic.  This means--- compiling Template Haskell code with -prof does not require-  building the code without -prof first--- when GHC itself is profiled, it can interpret unprofiled code,-  and the same applies to dynamic linking.--- An unprofiled GHCi can load and run profiled code, which means it-  can use the stack-trace functionality provided by profiling without-  taking the performance hit on the compiler that profiling would-  entail.--For other reasons see remote-GHCi on the wiki.--Implementation Overview-~~~~~~~~~~~~~~~~~~~~~~~--The main pieces are:--- libraries/ghci, containing:-  - types for talking about remote values (GHCi.RemoteTypes)-  - the message protocol (GHCi.Message),-  - implementation of the messages (GHCi.Run)-  - implementation of Template Haskell (GHCi.TH)-  - a few other things needed to run interpreted code--- top-level iserv directory, containing the codefor the external-  server.  This is a fairly simple wrapper, most of the functionality-  is provided by modules in libraries/ghci.--- This module which provides the interface to the server used-  by the rest of GHC.--GHC works with and without -fexternal-interpreter.  With the flag, all-interpreted code is run by the iserv binary.  Without the flag,-interpreted code is run in the same process as GHC.--Things that do not work with -fexternal-interpreter-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--dynCompileExpr cannot work, because we have no way to run code of an-unknown type in the remote process.  This API fails with an error-message if it is used with -fexternal-interpreter.--Other Notes on Remote GHCi-~~~~~~~~~~~~~~~~~~~~~~~~~~-  * This wiki page has an implementation overview:-    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter-  * Note [External GHCi pointers] in "GHC.Runtime.Interpreter"-  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs--}----- | Run a command in the interpreter's context.  With--- @-fexternal-interpreter@, the command is serialized and sent to an--- external iserv process, and the response is deserialized (hence the--- @Binary@ constraint).  With @-fno-external-interpreter@ we execute--- the command directly here.-interpCmd :: Binary a => Interp -> Message a -> IO a-interpCmd interp msg = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp     -> run msg -- Just run it directly-#endif-  ExternalInterp c i -> withIServ_ c i $ \iserv ->-    uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd]-      iservCall iserv msg----- Note [uninterruptibleMask_ and interpCmd]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If we receive an async exception, such as ^C, while communicating--- with the iserv process then we will be out-of-sync and not be able--- to recover.  Thus we use uninterruptibleMask_ during--- communication.  A ^C will be delivered to the iserv process (because--- signals get sent to the whole process group) which will interrupt--- the running computation and return an EvalException result.---- | Grab a lock on the 'IServ' and do something with it.--- Overloaded because this is used from TcM as well as IO.-withIServ-  :: (ExceptionMonad m)-  => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a-withIServ conf (IServ mIServState) action =-  MC.mask $ \restore -> do-    state <- liftIO $ takeMVar mIServState--    iserv <- case state of-      -- start the external iserv process if we haven't done so yet-      IServPending ->-         liftIO (spawnIServ conf)-           `MC.onException` (liftIO $ putMVar mIServState state)--      IServRunning inst -> return inst---    let iserv'  = iserv{ iservPendingFrees = [] }--    (iserv'',a) <- (do-      -- free any ForeignHValues that have been garbage collected.-      liftIO $ when (not (null (iservPendingFrees iserv))) $-        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))-      -- run the inner action-      restore $ action iserv')-          `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv'))-    liftIO $ putMVar mIServState (IServRunning iserv'')-    return a--withIServ_-  :: (MonadIO m, ExceptionMonad m)-  => IServConfig -> IServ -> (IServInstance -> m a) -> m a-withIServ_ conf iserv action = withIServ conf iserv $ \inst ->-   (inst,) <$> action inst---- -------------------------------------------------------------------------------- Wrappers around messages---- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for--- each of the results.-evalStmt-  :: Interp-  -> EvalOpts-  -> EvalExpr ForeignHValue-  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-evalStmt interp opts foreign_expr = do-  status <- withExpr foreign_expr $ \expr ->-    interpCmd interp (EvalStmt opts expr)-  handleEvalStatus interp status- where-  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a-  withExpr (EvalThis fhv) cont =-    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)-  withExpr (EvalApp fl fr) cont =-    withExpr fl $ \fl' ->-    withExpr fr $ \fr' ->-    cont (EvalApp fl' fr')--resumeStmt-  :: Interp-  -> EvalOpts-  -> ForeignRef (ResumeContext [HValueRef])-  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-resumeStmt interp opts resume_ctxt = do-  status <- withForeignRef resume_ctxt $ \rhv ->-    interpCmd interp (ResumeStmt opts rhv)-  handleEvalStatus interp status--abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()-abandonStmt interp resume_ctxt =-  withForeignRef resume_ctxt $ \rhv ->-    interpCmd interp (AbandonStmt rhv)--handleEvalStatus-  :: Interp-  -> EvalStatus [HValueRef]-  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-handleEvalStatus interp status =-  case status of-    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)-    EvalComplete alloc res ->-      EvalComplete alloc <$> addFinalizer res- where-  addFinalizer (EvalException e) = return (EvalException e)-  addFinalizer (EvalSuccess rs)  =-    EvalSuccess <$> mapM (mkFinalizedHValue interp) rs---- | Execute an action of type @IO ()@-evalIO :: Interp -> ForeignHValue -> IO ()-evalIO interp fhv =-  liftIO $ withForeignRef fhv $ \fhv ->-    interpCmd interp (EvalIO fhv) >>= fromEvalResult---- | Execute an action of type @IO String@-evalString :: Interp -> ForeignHValue -> IO String-evalString interp fhv =-  liftIO $ withForeignRef fhv $ \fhv ->-    interpCmd interp (EvalString fhv) >>= fromEvalResult---- | Execute an action of type @String -> IO String@-evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String-evalStringToIOString interp fhv str =-  liftIO $ withForeignRef fhv $ \fhv ->-    interpCmd interp (EvalStringToString fhv str) >>= fromEvalResult----- | Allocate and store the given bytes in memory, returning a pointer--- to the memory in the remote process.-mallocData :: Interp -> ByteString -> IO (RemotePtr ())-mallocData interp bs = interpCmd interp (MallocData bs)--mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]-mkCostCentres interp mod ccs =-  interpCmd interp (MkCostCentres mod ccs)--newtype BCOOpts = BCOOpts-  { bco_n_jobs :: Int -- ^ Number of parallel jobs doing BCO serialization-  }---- | Create a set of BCOs that may be mutually recursive.-createBCOs :: Interp -> BCOOpts -> [ResolvedBCO] -> IO [HValueRef]-createBCOs interp opts rbcos = do-  let n_jobs = bco_n_jobs opts-  -- Serializing ResolvedBCO is expensive, so if we support doing it in parallel-  if (n_jobs == 1)-    then-      interpCmd interp (CreateBCOs [runPut (put rbcos)])-    else do-      old_caps <- getNumCapabilities-      if old_caps == n_jobs-         then void $ evaluate puts-         else bracket_ (setNumCapabilities n_jobs)-                       (setNumCapabilities old_caps)-                       (void $ evaluate puts)-      interpCmd interp (CreateBCOs puts)- where-  puts = parMap doChunk (chunkList 100 rbcos)--  -- make sure we force the whole lazy ByteString-  doChunk c = pseq (LB.length bs) bs-    where bs = runPut (put c)--  -- We don't have the parallel package, so roll our own simple parMap-  parMap _ [] = []-  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))-    where fx = f x; fxs = parMap f xs--addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()-addSptEntry interp fpr ref =-  withForeignRef ref $ \val ->-    interpCmd interp (AddSptEntry fpr val)--costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]-costCentreStackInfo interp ccs =-  interpCmd interp (CostCentreStackInfo ccs)--newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)-newBreakArray interp size = do-  breakArray <- interpCmd interp (NewBreakArray size)-  mkFinalizedHValue interp breakArray--newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)-newModuleName interp mod_name =-  castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))--storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()-storeBreakpoint interp ref ix cnt = do                               -- #19157-  withForeignRef ref $ \breakarray ->-    interpCmd interp (SetupBreakpoint breakarray ix cnt)--breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool-breakpointStatus interp ref ix =-  withForeignRef ref $ \breakarray ->-    interpCmd interp (BreakpointStatus breakarray ix)--getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)-getBreakpointVar interp ref ix =-  withForeignRef ref $ \apStack -> do-    mb <- interpCmd interp (GetBreakpointVar apStack ix)-    mapM (mkFinalizedHValue interp) mb--getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)-getClosure interp ref =-  withForeignRef ref $ \hval -> do-    mb <- interpCmd interp (GetClosure hval)-    mapM (mkFinalizedHValue interp) mb---- | Send a Seq message to the iserv process to force a value      #2950-seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())-seqHValue interp unit_env ref =-  withForeignRef ref $ \hval -> do-    status <- interpCmd interp (Seq hval)-    handleSeqHValueStatus interp unit_env status---- | Process the result of a Seq or ResumeSeq message.             #2950-handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())-handleSeqHValueStatus interp unit_env eval_status =-  case eval_status of-    (EvalBreak is_exception _ ix mod_name resume_ctxt _) -> do-      -- A breakpoint was hit; inform the user and tell them-      -- which breakpoint was hit.-      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-      let hmi = expectJust "handleRunStatus" $-                  lookupHpt (ue_hpt unit_env) (mkModuleName mod_name)-          modl = mi_module (hm_iface hmi)-          bp | is_exception = Nothing-             | otherwise = Just (BreakInfo modl ix)-          sdocBpLoc = brackets . ppr . getSeqBpSpan-      putStrLn ("*** Ignoring breakpoint " ++-            (showSDocUnsafe $ sdocBpLoc bp))-      -- resume the seq (:force) processing in the iserv process-      withForeignRef resume_ctxt_fhv $ \hval -> do-        status <- interpCmd interp (ResumeSeq hval)-        handleSeqHValueStatus interp unit_env status-    (EvalComplete _ r) -> return r-  where-    getSeqBpSpan :: Maybe BreakInfo -> SrcSpan-    -- Just case: Stopped at a breakpoint, extract SrcSpan information-    -- from the breakpoint.-    getSeqBpSpan (Just BreakInfo{..}) =-      (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number-    -- Nothing case - should not occur!-    -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq-    getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")-    breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $-      lookupHpt (ue_hpt unit_env) (moduleName mod)----- -------------------------------------------------------------------------------- Interface to the object-code linker--initObjLinker :: Interp -> IO ()-initObjLinker interp = interpCmd interp InitLinker--lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))-lookupSymbol interp str = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))-#endif--  ExternalInterp c i -> withIServ c i $ \iserv -> do-    -- Profiling of GHCi showed a lot of time and allocation spent-    -- making cross-process LookupSymbol calls, so I added a GHC-side-    -- cache which sped things up quite a lot.  We have to be careful-    -- to purge this cache when unloading code though.-    let cache = iservLookupSymbolCache iserv-    case lookupUFM cache str of-      Just p -> return (iserv, Just p)-      Nothing -> do-        m <- uninterruptibleMask_ $-                 iservCall iserv (LookupSymbol (unpackFS str))-        case m of-          Nothing -> return (iserv, Nothing)-          Just r -> do-            let p      = fromRemotePtr r-                cache' = addToUFM cache str p-                iserv' = iserv {iservLookupSymbolCache = cache'}-            return (iserv', Just p)--lookupClosure :: Interp -> String -> IO (Maybe HValueRef)-lookupClosure interp str =-  interpCmd interp (LookupClosure str)--purgeLookupSymbolCache :: Interp -> IO ()-purgeLookupSymbolCache interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp -> pure ()-#endif-  ExternalInterp _ (IServ mstate) ->-    modifyMVar_ mstate $ \state -> pure $ case state of-      IServPending       -> state-      IServRunning iserv -> IServRunning-        (iserv { iservLookupSymbolCache = emptyUFM })----- | loadDLL loads a dynamic library using the OS's native linker--- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either--- an absolute pathname to the file, or a relative filename--- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL--- searches the standard locations for the appropriate library.------ Returns:------ Nothing      => success--- Just err_msg => failure-loadDLL :: Interp -> String -> IO (Maybe String)-loadDLL interp str = interpCmd interp (LoadDLL str)--loadArchive :: Interp -> String -> IO ()-loadArchive interp path = do-  path' <- canonicalizePath path -- Note [loadObj and relative paths]-  interpCmd interp (LoadArchive path')--loadObj :: Interp -> String -> IO ()-loadObj interp path = do-  path' <- canonicalizePath path -- Note [loadObj and relative paths]-  interpCmd interp (LoadObj path')--unloadObj :: Interp -> String -> IO ()-unloadObj interp path = do-  path' <- canonicalizePath path -- Note [loadObj and relative paths]-  interpCmd interp (UnloadObj path')---- Note [loadObj and relative paths]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- the iserv process might have a different current directory from the--- GHC process, so we must make paths absolute before sending them--- over.--addLibrarySearchPath :: Interp -> String -> IO (Ptr ())-addLibrarySearchPath interp str =-  fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str)--removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool-removeLibrarySearchPath interp p =-  interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p))--resolveObjs :: Interp -> IO SuccessFlag-resolveObjs interp = successIf <$> interpCmd interp ResolveObjs--findSystemLibrary :: Interp -> String -> IO (Maybe String)-findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)----- -------------------------------------------------------------------------------- Raw calls and messages---- | Send a 'Message' and receive the response from the iserv process-iservCall :: Binary a => IServInstance -> Message a -> IO a-iservCall iserv msg =-  remoteCall (iservPipe iserv) msg-    `catchException` \(e :: SomeException) -> handleIServFailure iserv e---- | Read a value from the iserv process-readIServ :: IServInstance -> Get a -> IO a-readIServ iserv get =-  readPipe (iservPipe iserv) get-    `catchException` \(e :: SomeException) -> handleIServFailure iserv e---- | Send a value to the iserv process-writeIServ :: IServInstance -> Put -> IO ()-writeIServ iserv put =-  writePipe (iservPipe iserv) put-    `catchException` \(e :: SomeException) -> handleIServFailure iserv e--handleIServFailure :: IServInstance -> SomeException -> IO a-handleIServFailure iserv e = do-  let proc = iservProcess iserv-  ex <- getProcessExitCode proc-  case ex of-    Just (ExitFailure n) ->-      throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))-    _ -> do-      terminateProcess proc-      _ <- waitForProcess proc-      throw e---- | Spawn an external interpreter-spawnIServ :: IServConfig -> IO IServInstance-spawnIServ conf = do-  iservConfTrace conf-  let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp-                                        ; return ph })-                             (iservConfHook conf)-  (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)-                                          (iservConfOpts    conf)-  lo_ref <- newIORef Nothing-  return $ IServInstance-    { iservPipe              = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }-    , iservProcess           = ph-    , iservLookupSymbolCache = emptyUFM-    , iservPendingFrees      = []-    }---- | Stop the interpreter-stopInterp :: Interp -> IO ()-stopInterp interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-    InternalInterp -> pure ()-#endif-    ExternalInterp _ (IServ mstate) ->-      MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do-        case state of-          IServPending    -> pure state -- already stopped-          IServRunning i  -> do-            ex <- getProcessExitCode (iservProcess i)-            if isJust ex-               then pure ()-               else iservCall i Shutdown-            pure IServPending--runWithPipes :: (CreateProcess -> IO ProcessHandle)-             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)-#if defined(mingw32_HOST_OS)-foreign import ccall "io.h _close"-   c__close :: CInt -> IO CInt--foreign import ccall unsafe "io.h _get_osfhandle"-   _get_osfhandle :: CInt -> IO CInt--runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle)-                  -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)-runWithPipesPOSIX createProc prog opts = do-    (rfd1, wfd1) <- createPipeFd -- we read on rfd1-    (rfd2, wfd2) <- createPipeFd -- we write on wfd2-    wh_client    <- _get_osfhandle wfd1-    rh_client    <- _get_osfhandle rfd2-    let args = show wh_client : show rh_client : opts-    ph <- createProc (proc prog args)-    rh <- mkHandle rfd1-    wh <- mkHandle wfd2-    return (ph, rh, wh)-      where mkHandle :: CInt -> IO Handle-            mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)--# if defined (__IO_MANAGER_WINIO__)-runWithPipesNative :: (CreateProcess -> IO ProcessHandle)-                   -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)-runWithPipesNative createProc prog opts = do-    (rh, wfd1) <- createPipe -- we read on rfd1-    (rfd2, wh) <- createPipe -- we write on wfd2-    wh_client    <- handleToHANDLE wfd1-    rh_client    <- handleToHANDLE rfd2-    -- Associate the handle with the current manager-    -- but don't touch the ones we're passing to the child-    -- since it needs to register the handle with its own manager.-    associateHandle' =<< handleToHANDLE rh-    associateHandle' =<< handleToHANDLE wh-    let args = show wh_client : show rh_client : opts-    ph <- createProc (proc prog args)-    return (ph, rh, wh)--runWithPipes = runWithPipesPOSIX <!> runWithPipesNative-# else-runWithPipes = runWithPipesPOSIX-# endif-#else-runWithPipes createProc prog opts = do-    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1-    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2-    setFdOption rfd1 CloseOnExec True-    setFdOption wfd2 CloseOnExec True-    let args = show wfd1 : show rfd2 : opts-    ph <- createProc (proc prog args)-    closeFd wfd1-    closeFd rfd2-    rh <- fdToHandle rfd1-    wh <- fdToHandle wfd2-    return (ph, rh, wh)-#endif---- ------------------------------------------------------------------------------{- Note [External GHCi pointers]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have the following ways to reference things in GHCi:--HValue---------HValue is a direct reference to a value in the local heap.  Obviously-we cannot use this to refer to things in the external process.---RemoteRef------------RemoteRef is a StablePtr to a heap-resident value.  When--fexternal-interpreter is used, this value resides in the external-process's heap.  RemoteRefs are mostly used to send pointers in-messages between GHC and iserv.--A RemoteRef must be explicitly freed when no longer required, using-freeHValueRefs, or by attaching a finalizer with mkForeignHValue.--To get from a RemoteRef to an HValue you can use 'wormholeRef', which-fails with an error message if -fexternal-interpreter is in use.--ForeignRef-------------A ForeignRef is a RemoteRef with a finalizer that will free the-'RemoteRef' when it is garbage collected.  We mostly use ForeignHValue-on the GHC side.--The finalizer adds the RemoteRef to the iservPendingFrees list in the-IServ record.  The next call to interpCmd will free any RemoteRefs in-the list.  It was done this way rather than calling interpCmd directly,-because I didn't want to have arbitrary threads calling interpCmd.  In-principle it would probably be ok, but it seems less hairy this way.--}---- | Creates a 'ForeignRef' that will automatically release the--- 'RemoteRef' when it is no longer referenced.-mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)-mkFinalizedHValue interp rref = do-   let hvref = toHValueRef rref--   free <- case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-      InternalInterp             -> return (freeRemoteRef hvref)-#endif-      ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state ->-       case state of-         IServPending {}   -> pure state -- already shut down-         IServRunning inst -> do-            let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst}-            pure (IServRunning inst')--   mkForeignRef rref free---freeHValueRefs :: Interp -> [HValueRef] -> IO ()-freeHValueRefs _ [] = return ()-freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs)---- | Convert a 'ForeignRef' to the value it references directly.  This--- only works when the interpreter is running in the same process as--- the compiler, so it fails when @-fexternal-interpreter@ is on.-wormhole :: Interp -> ForeignRef a -> IO a-wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r)---- | Convert an 'RemoteRef' to the value it references directly.  This--- only works when the interpreter is running in the same process as--- the compiler, so it fails when @-fexternal-interpreter@ is on.-wormholeRef :: Interp -> RemoteRef a -> IO a-wormholeRef interp _r = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp -> localRef _r-#endif-  ExternalInterp {}-    -> throwIO (InstallationError "this operation requires -fno-external-interpreter")---- -------------------------------------------------------------------------------- Misc utils--fromEvalResult :: EvalResult a -> IO a-fromEvalResult (EvalException e) = throwIO (fromSerializableException e)-fromEvalResult (EvalSuccess a) = return a--getModBreaks :: HomeModInfo -> ModBreaks-getModBreaks hmi-  | Just linkable <- homeModInfoByteCode hmi,-    [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable-  = fromMaybe emptyModBreaks (bc_breaks cbc)-  | otherwise-  = emptyModBreaks -- probably object code-  where-    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.-    onlyBCOs :: Unlinked -> Maybe CompiledByteCode-    onlyBCOs (BCOs cbc _) = Just cbc-    onlyBCOs _            = Nothing---- | Interpreter uses Profiling way-interpreterProfiled :: Interp -> Bool-interpreterProfiled interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp     -> hostIsProfiled-#endif-  ExternalInterp c _ -> iservConfProfiled c---- | Interpreter uses Dynamic way-interpreterDynamic :: Interp -> Bool-interpreterDynamic interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)-  InternalInterp     -> hostIsDynamic-#endif-  ExternalInterp c _ -> iservConfDynamic c
compiler/GHC/Runtime/Interpreter/Types.hs view
@@ -1,13 +1,44 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}  -- | Types used by the runtime interpreter module GHC.Runtime.Interpreter.Types    ( Interp(..)    , InterpInstance(..)-   , IServ(..)-   , IServInstance(..)+   , InterpProcess (..)+   , ExtInterp (..)+   , ExtInterpStatusVar+   , ExtInterpInstance (..)+   , ExtInterpState (..)+   , InterpStatus(..)+   -- * InterpSymbolCache+   , InterpSymbolCache(..)+   , mkInterpSymbolCache+   , lookupInterpSymbolCache+   , updateInterpSymbolCache+   , purgeInterpSymbolCache+   , InterpSymbol(..)+   , SuffixOrInterpreted(..)+   , interpSymbolName+   , interpSymbolSuffix+   , eliminateInterpSymbol+   , interpretedInterpSymbol+   , interpreterProfiled+   , interpreterDynamic++   -- * IServ+   , IServ    , IServConfig(..)-   , IServState(..)+   -- * JSInterp+   , JSInterp+   , JSInterpExtra (..)+   , JSInterpConfig (..)+   , JSState (..)+   , NodeJsSettings (..)+   , defaultNodeJsSettings+   , WasmInterp+   , WasmInterpConfig (..)    ) where @@ -16,12 +47,24 @@  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+import GHC.Unit.State+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 )+import System.IO+import GHC.Unit.Finder.Types (FinderCache, FinderOpts)  -- | Interpreter data Interp = Interp@@ -30,27 +73,49 @@    , interpLoader   :: !Loader       -- ^ Interpreter loader-  } +  , interpSymbolCache :: !InterpSymbolCache+      -- ^ LookupSymbol cache+  }  data InterpInstance-   = ExternalInterp !IServConfig !IServ -- ^ External interpreter+   = ExternalInterp !ExtInterp -- ^ External interpreter #if defined(HAVE_INTERNAL_INTERPRETER)-   | InternalInterp                     -- ^ Internal interpreter+   | InternalInterp            -- ^ Internal interpreter #endif +data ExtInterp+  = ExtIServ !IServ+  | ExtJS !JSInterp+  | ExtWasm !WasmInterp+ -- | External interpreter -- -- The external interpreter is spawned lazily (on first use) to avoid slowing -- down sessions that don't require it. The contents of the MVar reflects the -- state of the interpreter (running or not).-newtype IServ = IServ (MVar IServState)+data ExtInterpState cfg details = ExtInterpState+  { interpConfig :: !cfg+  , interpStatus :: !(ExtInterpStatusVar details)+  } --- | State of an external interpreter-data IServState-   = IServPending                 -- ^ Not spawned yet-   | IServRunning !IServInstance  -- ^ Running+type ExtInterpStatusVar d = MVar (InterpStatus (ExtInterpInstance d)) +type IServ    = ExtInterpState IServConfig    ()+type JSInterp = ExtInterpState JSInterpConfig JSInterpExtra+type WasmInterp = ExtInterpState WasmInterpConfig ()++data InterpProcess = InterpProcess+  { interpPipe   :: !Pipe           -- ^ Pipe to communicate with the server+  , interpHandle :: !ProcessHandle  -- ^ Process handle of the server+  , interpLock   :: !(MVar ())      -- ^ Lock to prevent concurrent access to the stream+  }++-- | Status of an external interpreter+data InterpStatus inst+   = InterpPending       -- ^ Not spawned yet+   | InterpRunning !inst -- ^ Running+ -- | Configuration needed to spawn an external interpreter data IServConfig = IServConfig   { iservConfProgram  :: !String   -- ^ External program to run@@ -61,14 +126,108 @@   , iservConfTrace    :: IO ()     -- ^ Trace action executed after spawn   } --- | External interpreter instance-data IServInstance = IServInstance-  { iservPipe              :: !Pipe-  , iservProcess           :: !ProcessHandle-  , iservLookupSymbolCache :: !(UniqFM FastString (Ptr ()))-  , iservPendingFrees      :: ![HValueRef]+-- | Common field between native external interpreter and the JS one+data ExtInterpInstance c = ExtInterpInstance+  { instProcess       :: {-# UNPACK #-} !InterpProcess+      -- ^ External interpreter process and its pipe (communication channel)++  , instPendingFrees  :: !(MVar [HValueRef])       -- ^ Values that need to be freed before the next command is sent.-      -- Threads can append values to this list asynchronously (by modifying the-      -- IServ state MVar).+      -- Finalizers for ForeignRefs can append values to this list+      -- asynchronously.++  , instExtra             :: !c+      -- ^ 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+------------------------++data JSInterpExtra = JSInterpExtra+  { instStdIn       :: !Handle         -- ^ Stdin for the process+  , instFinderCache :: !FinderCache+  , instFinderOpts  :: !FinderOpts+  , instJSState     :: !(MVar JSState) -- ^ Mutable state+  , instGhciUnitId  :: !UnitId         -- ^ GHCi unit-id+  }++data JSState = JSState+  { jsLinkState     :: !LinkPlan -- ^ Linker state of the interpreter+  , jsServerStarted :: !Bool     -- ^ Is the Haskell server started?+  }++-- | NodeJs configuration+data NodeJsSettings = NodeJsSettings+  { nodeProgram         :: FilePath        -- ^ location of node.js program+  , nodePath            :: Maybe FilePath  -- ^ value of NODE_PATH environment variable (search path for Node modules; GHCJS used to provide some)+  , nodeExtraArgs       :: [String]        -- ^ extra arguments to pass to node.js+  , nodeKeepAliveMaxMem :: Integer         -- ^ keep node.js (TH, GHCJSi) processes alive if they don't use more than this+  }++defaultNodeJsSettings :: NodeJsSettings+defaultNodeJsSettings = NodeJsSettings+  { nodeProgram         = "node"+  , nodePath            = Nothing+  , nodeExtraArgs       = []+  , nodeKeepAliveMaxMem = 536870912+  }+++data JSInterpConfig = JSInterpConfig+  { jsInterpNodeConfig  :: !NodeJsSettings  -- ^ NodeJS settings+  , jsInterpScript      :: !FilePath        -- ^ Path to "ghc-interp.js" script+  , jsInterpTmpFs       :: !TmpFs+  , jsInterpTmpDir      :: !TempDir+  , jsInterpLogger      :: !Logger+  , jsInterpCodegenCfg  :: !StgToJSConfig+  , jsInterpUnitEnv     :: !UnitEnv+  , jsInterpFinderOpts  :: !FinderOpts+  , jsInterpFinderCache :: !FinderCache+  }++------------------------+-- Wasm Stuff+------------------------++data WasmInterpConfig = WasmInterpConfig+  { 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+  , wasmInterpUnitState      :: !UnitState+  }
+ 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 (..)@@ -19,20 +20,22 @@   , sGlobalPackageDatabasePath   , sLdSupportsCompactUnwind   , sLdSupportsFilelist+  , sMergeObjsSupportsResponseFiles   , sLdIsGnuLd   , sGccSupportsNoPie   , sUseInplaceMinGW   , sArSupportsDashL   , sPgm_L   , sPgm_P+  , sPgm_JSP+  , sPgm_CmmP   , sPgm_F   , sPgm_c   , sPgm_cxx+  , sPgm_cpp   , sPgm_a   , sPgm_l   , sPgm_lm-  , sPgm_dll-  , sPgm_T   , sPgm_windres   , sPgm_ar   , sPgm_otool@@ -40,11 +43,15 @@   , sPgm_ranlib   , sPgm_lo   , sPgm_lc-  , sPgm_lcc+  , sPgm_las   , sPgm_i   , sOpt_L   , sOpt_P   , sOpt_P_fingerprint+  , sOpt_JSP+  , sOpt_JSP_fingerprint+  , sOpt_CmmP+  , sOpt_CmmP_fingerprint   , sOpt_F   , sOpt_c   , sOpt_cxx@@ -54,12 +61,12 @@   , sOpt_windres   , sOpt_lo   , sOpt_lc-  , sOpt_lcc   , sOpt_i   , sExtraGccViaCFlags   , sTargetPlatformString   , sGhcWithInterpreter   , sLibFFI+  , sTargetRTSLinkerOnlySupportsSharedLibs   ) where  import GHC.Prelude@@ -67,6 +74,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform+import GHC.Unit.Types  data Settings = Settings   { sGhcNameVersion    :: {-# UNPACk #-} !GhcNameVersion@@ -74,12 +82,15 @@   , 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. -- -- Probably should further split down by phase, or split between@@ -88,25 +99,32 @@   { toolSettings_ldSupportsCompactUnwind :: Bool   , toolSettings_ldSupportsFilelist      :: Bool   , toolSettings_ldSupportsSingleModule  :: Bool+  , toolSettings_mergeObjsSupportsResponseFiles :: Bool   , toolSettings_ldIsGnuLd               :: Bool   , toolSettings_ccSupportsNoPie         :: Bool   , toolSettings_useInplaceMinGW         :: Bool   , toolSettings_arSupportsDashL         :: Bool+  , toolSettings_cmmCppSupportsG0        :: Bool    -- commands for particular phases   , toolSettings_pgm_L       :: String-  , toolSettings_pgm_P       :: (String, [Option])+  , -- | The Haskell C preprocessor and default options (not added by -optP)+    toolSettings_pgm_P       :: (String, [Option])+  , -- | The JavaScript C preprocessor and default options (not added by -optP)+    toolSettings_pgm_JSP       :: (String, [Option])+  , -- | The C-- C Preprocessor and default options (not added by -optP)+    toolSettings_pgm_CmmP    :: (String, [Option])   , toolSettings_pgm_F       :: String   , toolSettings_pgm_c       :: String   , toolSettings_pgm_cxx     :: String+  , -- | The C preprocessor (distinct from the Haskell C preprocessor!)+    toolSettings_pgm_cpp     :: (String, [Option])   , toolSettings_pgm_a       :: (String, [Option])   , toolSettings_pgm_l       :: (String, [Option])   , toolSettings_pgm_lm      :: Maybe (String, [Option])     -- ^ N.B. On Windows we don't have a linker which supports object     -- merging, hence the 'Maybe'. See Note [Object merging] in     -- "GHC.Driver.Pipeline.Execute" for details.-  , toolSettings_pgm_dll     :: (String, [Option])-  , toolSettings_pgm_T       :: String   , toolSettings_pgm_windres :: String   , toolSettings_pgm_ar      :: String   , toolSettings_pgm_otool   :: String@@ -116,16 +134,24 @@     toolSettings_pgm_lo      :: (String, [Option])   , -- | LLVM: llc static compiler     toolSettings_pgm_lc      :: (String, [Option])-  , -- | LLVM: c compiler-    toolSettings_pgm_lcc     :: (String, [Option])+    -- | LLVM: assembler+  , toolSettings_pgm_las     :: (String, [Option])   , toolSettings_pgm_i       :: String    -- options for particular phases   , toolSettings_opt_L             :: [String]   , toolSettings_opt_P             :: [String]+  , toolSettings_opt_JSP           :: [String]+  , toolSettings_opt_CmmP          :: [String]   , -- | cached Fingerprint of sOpt_P     -- See Note [Repeated -optP hashing]-    toolSettings_opt_P_fingerprint :: Fingerprint+    toolSettings_opt_P_fingerprint   :: Fingerprint+  , -- | cached Fingerprint of sOpt_JSP+    -- See Note [Repeated -optP hashing]+    toolSettings_opt_JSP_fingerprint :: Fingerprint+  , -- | cached Fingerprint of sOpt_CmmP+    -- See Note [Repeated -optP hashing]+    toolSettings_opt_CmmP_fingerprint :: Fingerprint   , toolSettings_opt_F             :: [String]   , toolSettings_opt_c             :: [String]   , toolSettings_opt_cxx           :: [String]@@ -137,8 +163,7 @@     toolSettings_opt_lo            :: [String]   , -- | LLVM: llc static compiler     toolSettings_opt_lc            :: [String]-  , -- | LLVM: c compiler-    toolSettings_opt_lcc           :: [String]+  , toolSettings_opt_las           :: [String]   , -- | iserv options     toolSettings_opt_i             :: [String] @@ -190,6 +215,8 @@ sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings+sMergeObjsSupportsResponseFiles :: Settings -> Bool+sMergeObjsSupportsResponseFiles = toolSettings_mergeObjsSupportsResponseFiles . sToolSettings sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool@@ -203,22 +230,24 @@ sPgm_L = toolSettings_pgm_L . sToolSettings sPgm_P :: Settings -> (String, [Option]) sPgm_P = toolSettings_pgm_P . sToolSettings+sPgm_JSP :: Settings -> (String, [Option])+sPgm_JSP = toolSettings_pgm_JSP . sToolSettings+sPgm_CmmP :: Settings -> (String, [Option])+sPgm_CmmP = toolSettings_pgm_CmmP . sToolSettings sPgm_F :: Settings -> String sPgm_F = toolSettings_pgm_F . sToolSettings sPgm_c :: Settings -> String sPgm_c = toolSettings_pgm_c . sToolSettings sPgm_cxx :: Settings -> String sPgm_cxx = toolSettings_pgm_cxx . sToolSettings+sPgm_cpp :: Settings -> (String, [Option])+sPgm_cpp = toolSettings_pgm_cpp . sToolSettings sPgm_a :: Settings -> (String, [Option]) sPgm_a = toolSettings_pgm_a . sToolSettings sPgm_l :: Settings -> (String, [Option]) sPgm_l = toolSettings_pgm_l . sToolSettings sPgm_lm :: Settings -> Maybe (String, [Option]) sPgm_lm = toolSettings_pgm_lm . sToolSettings-sPgm_dll :: Settings -> (String, [Option])-sPgm_dll = toolSettings_pgm_dll . sToolSettings-sPgm_T :: Settings -> String-sPgm_T = toolSettings_pgm_T . sToolSettings sPgm_windres :: Settings -> String sPgm_windres = toolSettings_pgm_windres . sToolSettings sPgm_ar :: Settings -> String@@ -233,8 +262,8 @@ sPgm_lo = toolSettings_pgm_lo . sToolSettings sPgm_lc :: Settings -> (String, [Option]) sPgm_lc = toolSettings_pgm_lc . sToolSettings-sPgm_lcc :: Settings -> (String, [Option])-sPgm_lcc = toolSettings_pgm_lcc . sToolSettings+sPgm_las :: Settings -> (String, [Option])+sPgm_las = toolSettings_pgm_las . sToolSettings sPgm_i :: Settings -> String sPgm_i = toolSettings_pgm_i . sToolSettings sOpt_L :: Settings -> [String]@@ -243,6 +272,14 @@ sOpt_P = toolSettings_opt_P . sToolSettings sOpt_P_fingerprint :: Settings -> Fingerprint sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings+sOpt_JSP :: Settings -> [String]+sOpt_JSP = toolSettings_opt_JSP . sToolSettings+sOpt_JSP_fingerprint :: Settings -> Fingerprint+sOpt_JSP_fingerprint = toolSettings_opt_JSP_fingerprint . sToolSettings+sOpt_CmmP :: Settings -> [String]+sOpt_CmmP = toolSettings_opt_CmmP . sToolSettings+sOpt_CmmP_fingerprint :: Settings -> Fingerprint+sOpt_CmmP_fingerprint = toolSettings_opt_CmmP_fingerprint . sToolSettings sOpt_F :: Settings -> [String] sOpt_F = toolSettings_opt_F . sToolSettings sOpt_c :: Settings -> [String]@@ -261,8 +298,6 @@ sOpt_lo = toolSettings_opt_lo . sToolSettings sOpt_lc :: Settings -> [String] sOpt_lc = toolSettings_opt_lc . sToolSettings-sOpt_lcc :: Settings -> [String]-sOpt_lcc = toolSettings_opt_lcc . sToolSettings sOpt_i :: Settings -> [String] sOpt_i = toolSettings_opt_i . sToolSettings @@ -275,3 +310,6 @@ sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc++sTargetRTSLinkerOnlySupportsSharedLibs :: Settings -> Bool+sTargetRTSLinkerOnlySupportsSharedLibs = platformMisc_targetRTSLinkerOnlySupportsSharedLibs . sPlatformMisc
compiler/GHC/Settings/Constants.hs view
@@ -30,6 +30,27 @@ mAX_SOLVER_ITERATIONS :: Int mAX_SOLVER_ITERATIONS = 4 +-- | In case of loopy quantified constraints constraints,+--   how many times should we allow superclass expansions+--   Should be less than mAX_SOLVER_ITERATIONS+--   See Note [Expanding Recursive Superclasses and ExpansionFuel]+mAX_QC_FUEL :: Int+mAX_QC_FUEL = 3++-- | In case of loopy wanted constraints,+--   how many times should we allow superclass expansions+--   Should be less than mAX_GIVENS_FUEL+-- See Note [Expanding Recursive Superclasses and ExpansionFuel]+mAX_WANTEDS_FUEL :: Int+mAX_WANTEDS_FUEL = 1++-- | In case of loopy given constraints,+--   how many times should we allow superclass expansions+--   Should be less than max_SOLVER_ITERATIONS+-- See Note [Expanding Recursive Superclasses and ExpansionFuel]+mAX_GIVENS_FUEL :: Int+mAX_GIVENS_FUEL = 3+ wORD64_SIZE :: Int wORD64_SIZE = 8
+ 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,76 +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 it's own module we can avoid module loops.-module GHC.Stg.InferTags.TagSig--where--import GHC.Prelude--import GHC.Types.Var-import GHC.Utils.Outputable-import GHC.Utils.Binary-import GHC.Utils.Panic.Plain-import Data.Coerce--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)--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)--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/Lift/Types.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++-- This module declares some basic types used by GHC.Stg.Lift+-- We can import this module into GHC.Stg.Syntax, where the+-- type instance declarations for BinderP etc live++module GHC.Stg.Lift.Types(+   Skeleton(..),+   bothSk, altSk, rhsSk,++   BinderInfo(..),+   binderInfoBndr, binderInfoOccursAsArg+   ) where++import GHC.Prelude++import GHC.Types.Id+import GHC.Types.Demand+import GHC.Types.Var.Set++import GHC.Utils.Outputable++-- | Captures details of the syntax tree relevant to the cost model, such as+-- closures, multi-shot lambdas and case expressions.+data Skeleton+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton+  | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton+  | AltSk !Skeleton !Skeleton+  | BothSk !Skeleton !Skeleton+  | NilSk++bothSk :: Skeleton -> Skeleton -> Skeleton+bothSk NilSk b = b+bothSk a NilSk = a+bothSk a b     = BothSk a b++altSk :: Skeleton -> Skeleton -> Skeleton+altSk NilSk b = b+altSk a NilSk = a+altSk a b     = AltSk a b++rhsSk :: Card -> Skeleton -> Skeleton+rhsSk _        NilSk = NilSk+rhsSk body_dmd skel  = RhsSk body_dmd skel++-- | The type used in binder positions in 'GenStgExpr's.+data BinderInfo+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag+                           --   indicating whether it occurs as an argument+                           --   or in a nullary application+                           --   (see "GHC.Stg.Lift.Analysis#arg_occs").+  | BoringBinder !Id       -- ^ Every other kind of binder++-- | Gets the bound 'Id' out a 'BinderInfo'.+binderInfoBndr :: BinderInfo -> Id+binderInfoBndr (BoringBinder bndr)   = bndr+binderInfoBndr (BindsClosure bndr _) = bndr++-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating+-- occurrences as argument or in a nullary applications otherwise.+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool+binderInfoOccursAsArg BoringBinder{}     = Nothing+binderInfoOccursAsArg (BindsClosure _ b) = Just b++instance Outputable Skeleton where+  ppr NilSk = text ""+  ppr (AltSk l r) = vcat+    [ text "{ " <+> ppr l+    , text "ALT"+    , text "  " <+> ppr r+    , text "}"+    ]+  ppr (BothSk l r) = ppr l $$ ppr r+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)+  ppr (RhsSk card body) = hcat+    [ lambda+    , ppr card+    , dot+    , ppr body+    ]++instance Outputable BinderInfo where+  ppr = ppr . binderInfoBndr++instance OutputableBndr BinderInfo where+  pprBndr b = pprBndr b . binderInfoBndr+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr+  pprInfixOcc = pprInfixOcc . binderInfoBndr+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr+
compiler/GHC/Stg/Syntax.hs view
@@ -54,8 +54,12 @@          -- utils         stgRhsArity, freeVarsOfRhs,-        isDllConApp,         stgArgType,+        stgArgRep,+        stgArgRep1,+        stgArgRepU,+        stgArgRep_maybe,+         stgCaseBndrInScope,          -- ppr@@ -68,28 +72,34 @@  import GHC.Prelude -import GHC.Core     ( AltCon )+import GHC.Stg.EnforceEpt.TagSig( TagSig )+import GHC.Stg.Lift.Types+  -- To avoid having an orphan instances for BinderP, XLet etc+ import GHC.Types.CostCentre ( CostCentreStack )-import Data.ByteString ( ByteString )-import Data.Data   ( Data )-import Data.List   ( intersperse )++import GHC.Core     ( AltCon ) import GHC.Core.DataCon+import GHC.Core.TyCon    ( PrimRep(..), PrimOrVoidRep(..), TyCon )+import GHC.Core.Type     ( Type )+import GHC.Core.Ppr( {- instances -} )+ import GHC.Types.ForeignCall ( ForeignCall ) import GHC.Types.Id-import GHC.Types.Name        ( isDynLinkName ) import GHC.Types.Tickish     ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal     ( Literal, literalType )-import GHC.Unit.Module       ( Module )+import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe )+ import GHC.Utils.Outputable-import GHC.Platform-import GHC.Core.Ppr( {- instances -} )-import GHC.Builtin.PrimOps ( PrimOp, PrimCall )-import GHC.Core.TyCon    ( PrimRep(..), TyCon )-import GHC.Core.Type     ( Type )-import GHC.Types.RepType ( typePrimRep1, typePrimRep ) import GHC.Utils.Panic.Plain +import GHC.Builtin.PrimOps ( PrimOp, PrimCall )++import Data.ByteString ( ByteString )+import Data.Data   ( Data )+import Data.List   ( intersperse )+ {- ************************************************************************ *                                                                      *@@ -124,64 +134,39 @@   = StgVarArg  Id   | StgLitArg  Literal --- | Does this constructor application refer to anything in a different--- *Windows* DLL?--- If so, we can't allocate it statically-isDllConApp-  :: Platform-  -> Bool          -- is Opt_ExternalDynamicRefs enabled?-  -> Module-  -> DataCon-  -> [StgArg]-  -> Bool-isDllConApp platform ext_dyn_refs this_mod con args- | not ext_dyn_refs    = False- | platformOS platform == OSMinGW32-    = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args- | otherwise = False-  where-    -- NB: typePrimRep1 is legit because any free variables won't have-    -- unlifted type (there are no unlifted things at top level)-    is_dll_arg :: StgArg -> Bool-    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))-                             && isDynLinkName platform this_mod (idName v)-    is_dll_arg _             = False---- True of machine addresses; these are the things that don't work across DLLs.--- The key point here is that VoidRep comes out False, so that a top level--- nullary GADT constructor is False for isDllConApp------    data T a where---      T1 :: T Int------ gives------    T1 :: forall a. (a~Int) -> T a------ and hence the top-level binding------    $WT1 :: T Int---    $WT1 = T1 Int (Coercion (Refl Int))------ The coercion argument here gets VoidRep-isAddrRep :: PrimRep -> Bool-isAddrRep AddrRep     = True-isAddrRep LiftedRep   = True-isAddrRep UnliftedRep = True-isAddrRep _           = False- -- | Type of an @StgArg@ -- -- Very half baked because we have lost the type arguments.+--+-- This function should be avoided: in STG we aren't supposed to+-- look at types, but only PrimReps.+-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed. stgArgType :: StgArg -> Type stgArgType (StgVarArg v)   = idType v stgArgType (StgLitArg lit) = literalType lit +stgArgRep :: StgArg -> [PrimRep]+stgArgRep ty = typePrimRep (stgArgType ty)++stgArgRep_maybe :: StgArg -> Maybe [PrimRep]+stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)++-- | Assumes that the argument has at most one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.+-- See Note [VoidRep] in GHC.Types.RepType.+stgArgRep1 :: StgArg -> PrimOrVoidRep+stgArgRep1 ty = typePrimRep1 (stgArgType ty)++-- | Assumes that the argument has exactly one PrimRep.+-- See Note [VoidRep] in GHC.Types.RepType.+stgArgRepU :: StgArg -> PrimRep+stgArgRepU ty = typePrimRepU (stgArgType ty)+ -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- -- Case binders of unboxed tuple or unboxed sum type always dead after the--- unariser has run. See Note [Post-unarisation invariants].+-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise. stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool stgCaseBndrInScope alt_ty unarised =     case alt_ty of@@ -228,6 +213,52 @@  There are specialised forms of application, for constructors, primitives, and literals.++Note [Constructor applications in STG]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After the unarisation pass:+* In `StgConApp` and `StgRhsCon` and `StgAlt` we filter out the void arguments,+  leaving only non-void ones.+* In `StgApp` and `StgOpApp` we retain void arguments.++We can do this because we know that `StgConApp` and `StgRhsCon` are saturated applications,+so we lose no information by dropping those void args.  In contrast, in `StgApp` we need the+ void argument to compare the number of args in the call with the arity of the function.++This is an open design choice.  We could instead choose to treat all these applications+consistently (keeping the void args).  But for some reason we don't, and this Note simply+documents that design choice.++As an example, consider:++        data T a = MkT !Int a Void#++The wrapper's representation and the worker's representation (i.e. the+datacon's Core representation) are respectively:++        $WMkT :: Int  -> a -> Void# -> T a+        MkT   :: Int# -> a -> Void# -> T a++T would end up being used in STG post-unarise as:++  let x = MkT 1# y+  in ...+      case x of+        MkT int a -> ...++The Void# argument is dropped. In essence we only generate binders for runtime+relevant values.++We also flatten out unboxed tuples in this process. See the unarise+pass for details on how this is done. But as an example consider+`data S = MkS Bool (# Bool | Char #)` which when matched on would+result in an alternative with three binders like this++    MkS bool tag tpl_field ->++See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation]+for the details of this transformation.+ -}    | StgLit      Literal@@ -236,8 +267,8 @@         -- which can't be let-bound   | StgConApp   DataCon                 ConstructorNumber-                [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg])-                [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise+                [StgArg] -- Saturated. See Note [Constructor applications in STG]+                [[PrimRep]]   -- See Note [Representations in StgConApp] in GHC.Stg.Unarise    | StgOpApp    StgOp    -- Primitive op or foreign call                 [StgArg] -- Saturated.@@ -384,6 +415,7 @@         [BinderP pass]     -- ^ arguments; if empty, then not a function;                            --   as above, order is important.         (GenStgExpr pass)  -- ^ body+        Type               -- ^ result type  {- An example may be in order.  Consider:@@ -412,7 +444,8 @@                         -- are not allocated.         ConstructorNumber         [StgTickish]-        [StgArg]        -- Args+        [StgArg]        -- Saturated Args. See Note [Constructor applications in STG]+        Type            -- Type, for rewriting to an StgRhsClosure  -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'.@@ -430,14 +463,14 @@ -- implications on build time...  stgRhsArity :: StgRhs -> Int-stgRhsArity (StgRhsClosure _ _ _ bndrs _)+stgRhsArity (StgRhsClosure _ _ _ bndrs _ _)   = assert (all isId bndrs) $ length bndrs   -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon {}) = 0  freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet-freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]-freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs+freeVarsOfRhs (StgRhsCon _ _ _ _ args _) = mkDVarSet [ id | StgVarArg id <- args ]+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _ _) = fvs  {- ************************************************************************@@ -577,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.@@ -594,31 +627,40 @@   = 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)-type instance BinderP 'Vanilla = Id-type instance BinderP 'CodeGen = Id-type instance BinderP 'InferTagged = Id+type instance BinderP 'Vanilla            = Id+type instance BinderP 'CodeGen            = Id+type instance BinderP 'InferTagged        = Id+type instance BinderP 'InferTaggedBinders = (Id, TagSig)+type instance BinderP 'LiftLams           = BinderInfo  type family XRhsClosure (pass :: StgPass)-type instance XRhsClosure 'Vanilla = NoExtFieldSilent-type instance XRhsClosure 'InferTagged = NoExtFieldSilent+type instance XRhsClosure 'Vanilla            = NoExtFieldSilent+type instance XRhsClosure  'LiftLams          = DIdSet+type instance XRhsClosure 'InferTagged        = NoExtFieldSilent+type instance XRhsClosure 'InferTaggedBinders = XRhsClosure  'CodeGen -- | Code gen needs to track non-global free vars type instance XRhsClosure 'CodeGen = DIdSet + type family XLet (pass :: StgPass)-type instance XLet 'Vanilla = NoExtFieldSilent-type instance XLet 'InferTagged = NoExtFieldSilent-type instance XLet 'CodeGen = NoExtFieldSilent+type instance XLet 'Vanilla            = NoExtFieldSilent+type instance XLet 'LiftLams           = Skeleton+type instance XLet 'InferTagged        = NoExtFieldSilent+type instance XLet 'InferTaggedBinders = XLet 'CodeGen+type instance XLet 'CodeGen            = NoExtFieldSilent  type family XLetNoEscape (pass :: StgPass)-type instance XLetNoEscape 'Vanilla = NoExtFieldSilent-type instance XLetNoEscape 'InferTagged = NoExtFieldSilent-type instance XLetNoEscape 'CodeGen = NoExtFieldSilent+type instance XLetNoEscape 'Vanilla            = NoExtFieldSilent+type instance XLetNoEscape 'LiftLams           = Skeleton+type instance XLetNoEscape 'InferTagged        = NoExtFieldSilent+type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen+type instance XLetNoEscape 'CodeGen            = NoExtFieldSilent  {- @@ -630,24 +672,35 @@  This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. -A @ReEntrant@ closure may be entered multiple times, but should not be updated-or blackholed. An @Updatable@ closure should be updated after evaluation (and-may be blackholed during evaluation). A @SingleEntry@ closure will only be-entered once, and so need not be updated but may safely be blackholed. -} -data UpdateFlag = ReEntrant | Updatable | SingleEntry+data UpdateFlag+  = ReEntrant+      -- ^ A @ReEntrant@ closure may be entered multiple times, but should not+      -- be updated or blackholed.+  | Updatable+      -- ^ An @Updatable@ closure should be updated after evaluation (and may be+      -- blackholed during evaluation).+  | SingleEntry+      -- ^ A @SingleEntry@ closure will only be entered once, and so need not be+      -- updated but may safely be blackholed.+  | JumpedTo+      -- ^ A @JumpedTo@ (join-point) closure is entered once or multiple times+      -- but has no heap-allocated associated closure.+  deriving (Show,Eq)  instance Outputable UpdateFlag where     ppr u = char $ case u of                        ReEntrant   -> 'r'                        Updatable   -> 'u'                        SingleEntry -> 's'+                       JumpedTo    -> 'j'  isUpdatable :: UpdateFlag -> Bool isUpdatable ReEntrant   = False isUpdatable SingleEntry = False isUpdatable Updatable   = True+isUpdatable JumpedTo    = False  {- ************************************************************************@@ -815,10 +868,9 @@              , hang (text "} in ") 2 (pprStgExpr opts expr)              ] -   StgTick _tickish expr -> sdocOption sdocSuppressTicks $ \case+   StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case       True  -> pprStgExpr opts expr-      False -> pprStgExpr opts expr-        -- XXX sep [ ppr tickish, pprStgExpr opts expr ]+      False -> sep [ ppr tickish, pprStgExpr opts expr ]     -- Don't indent for a single case alternative.    StgCase expr bndr alt_type [alt]@@ -874,14 +926,14 @@  pprStgRhs :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc pprStgRhs opts rhs = case rhs of-   StgRhsClosure ext cc upd_flag args body+   StgRhsClosure ext cc upd_flag args body _       -> hang (hsep [ if stgSccEnabled opts then ppr cc else empty                     , ppUnlessOption sdocSuppressStgExts (ppr ext)                     , char '\\' <> ppr upd_flag, brackets (interppSP args)                     ])               4 (pprStgExpr opts body) -   StgRhsCon cc con mid _ticks args+   StgRhsCon cc con mid _ticks args _       -> hcat [ if stgSccEnabled opts then ppr cc <> space else empty               , case mid of                   NoNumber -> empty
+ compiler/GHC/StgToCmm/CgUtils.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.CgUtils (+        fixStgRegisters,+        baseRegOffset,+        get_Regtable_addr_from_offset,+        regTableOffset,+        get_GlobalReg_addr,++        -- * Streaming for CG+        CgStream+  ) where++import GHC.Prelude++import GHC.Platform.Regs+import GHC.Platform+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Utils.Panic+import GHC.Cmm.Dataflow.Label++import GHC.Data.Stream (Stream)+import GHC.Types.Unique.DSM (UniqDSMT)++-- -----------------------------------------------------------------------------+-- Streaming++-- | The Stream instantiation used for code generation.+-- Note the underlying monad is @UniqDSMT IO@, where @UniqDSMT@ is a transformer+-- that propagates a deterministic unique supply (essentially an incrementing+-- counter) from which new uniques are deterministically created during the+-- code generation stages following StgToCmm.+-- See Note [Object determinism].+type CgStream = Stream (UniqDSMT IO)+++-- -----------------------------------------------------------------------------+-- Information about global registers++baseRegOffset :: Platform -> GlobalReg -> Int+baseRegOffset platform reg = case reg of+   VanillaReg 1         -> pc_OFFSET_StgRegTable_rR1  constants+   VanillaReg 2         -> pc_OFFSET_StgRegTable_rR2  constants+   VanillaReg 3         -> pc_OFFSET_StgRegTable_rR3  constants+   VanillaReg 4         -> pc_OFFSET_StgRegTable_rR4  constants+   VanillaReg 5         -> pc_OFFSET_StgRegTable_rR5  constants+   VanillaReg 6         -> pc_OFFSET_StgRegTable_rR6  constants+   VanillaReg 7         -> pc_OFFSET_StgRegTable_rR7  constants+   VanillaReg 8         -> pc_OFFSET_StgRegTable_rR8  constants+   VanillaReg 9         -> pc_OFFSET_StgRegTable_rR9  constants+   VanillaReg 10        -> pc_OFFSET_StgRegTable_rR10 constants+   VanillaReg n         -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+   FloatReg  1          -> pc_OFFSET_StgRegTable_rF1 constants+   FloatReg  2          -> pc_OFFSET_StgRegTable_rF2 constants+   FloatReg  3          -> pc_OFFSET_StgRegTable_rF3 constants+   FloatReg  4          -> pc_OFFSET_StgRegTable_rF4 constants+   FloatReg  5          -> pc_OFFSET_StgRegTable_rF5 constants+   FloatReg  6          -> pc_OFFSET_StgRegTable_rF6 constants+   FloatReg  n          -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+   DoubleReg 1          -> pc_OFFSET_StgRegTable_rD1 constants+   DoubleReg 2          -> pc_OFFSET_StgRegTable_rD2 constants+   DoubleReg 3          -> pc_OFFSET_StgRegTable_rD3 constants+   DoubleReg 4          -> pc_OFFSET_StgRegTable_rD4 constants+   DoubleReg 5          -> pc_OFFSET_StgRegTable_rD5 constants+   DoubleReg 6          -> pc_OFFSET_StgRegTable_rD6 constants+   DoubleReg n          -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+   XmmReg 1             -> pc_OFFSET_StgRegTable_rXMM1 constants+   XmmReg 2             -> pc_OFFSET_StgRegTable_rXMM2 constants+   XmmReg 3             -> pc_OFFSET_StgRegTable_rXMM3 constants+   XmmReg 4             -> pc_OFFSET_StgRegTable_rXMM4 constants+   XmmReg 5             -> pc_OFFSET_StgRegTable_rXMM5 constants+   XmmReg 6             -> pc_OFFSET_StgRegTable_rXMM6 constants+   XmmReg n             -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+   YmmReg 1             -> pc_OFFSET_StgRegTable_rYMM1 constants+   YmmReg 2             -> pc_OFFSET_StgRegTable_rYMM2 constants+   YmmReg 3             -> pc_OFFSET_StgRegTable_rYMM3 constants+   YmmReg 4             -> pc_OFFSET_StgRegTable_rYMM4 constants+   YmmReg 5             -> pc_OFFSET_StgRegTable_rYMM5 constants+   YmmReg 6             -> pc_OFFSET_StgRegTable_rYMM6 constants+   YmmReg n             -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+   ZmmReg 1             -> pc_OFFSET_StgRegTable_rZMM1 constants+   ZmmReg 2             -> pc_OFFSET_StgRegTable_rZMM2 constants+   ZmmReg 3             -> pc_OFFSET_StgRegTable_rZMM3 constants+   ZmmReg 4             -> pc_OFFSET_StgRegTable_rZMM4 constants+   ZmmReg 5             -> pc_OFFSET_StgRegTable_rZMM5 constants+   ZmmReg 6             -> pc_OFFSET_StgRegTable_rZMM6 constants+   ZmmReg n             -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+   Sp                   -> pc_OFFSET_StgRegTable_rSp    constants+   SpLim                -> pc_OFFSET_StgRegTable_rSpLim constants+   LongReg 1            -> pc_OFFSET_StgRegTable_rL1    constants+   LongReg n            -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+   Hp                   -> pc_OFFSET_StgRegTable_rHp             constants+   HpLim                -> pc_OFFSET_StgRegTable_rHpLim          constants+   CCCS                 -> pc_OFFSET_StgRegTable_rCCCS           constants+   CurrentTSO           -> pc_OFFSET_StgRegTable_rCurrentTSO     constants+   CurrentNursery       -> pc_OFFSET_StgRegTable_rCurrentNursery constants+   HpAlloc              -> pc_OFFSET_StgRegTable_rHpAlloc        constants+   EagerBlackholeInfo   -> pc_OFFSET_stgEagerBlackholeInfo       constants+   GCEnter1             -> pc_OFFSET_stgGCEnter1                 constants+   GCFun                -> pc_OFFSET_stgGCFun                    constants+   BaseReg              -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"+   PicBaseReg           -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"+   MachSp               -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"+   UnwindReturnReg      -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"+ where+   !constants = platformConstants platform+++-- -----------------------------------------------------------------------------+--+-- STG/Cmm GlobalReg+--+-- -----------------------------------------------------------------------------++-- | We map STG registers onto appropriate CmmExprs.  Either they map+-- to real machine registers or stored as offsets from BaseReg.  Given+-- a GlobalReg, get_GlobalReg_addr always produces the+-- register table address for it.+get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr+get_GlobalReg_addr platform BaseReg = regTableOffset platform 0+get_GlobalReg_addr platform mid+    = get_Regtable_addr_from_offset platform (baseRegOffset platform mid)++-- Calculate a literal representing an offset into the register table.+-- Used when we don't have an actual BaseReg to offset from.+regTableOffset :: Platform -> Int -> CmmExpr+regTableOffset platform n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n))++get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr+get_Regtable_addr_from_offset platform offset =+    if haveRegBase platform+    then cmmRegOff (baseReg platform) offset+    else regTableOffset platform offset++-- | Fixup global registers so that they assign to locations within the+-- RegTable if they aren't pinned for the current target.+fixStgRegisters :: Platform -> GenCmmDecl d h (GenCmmGraph CmmNode) -> GenCmmDecl d h (GenCmmGraph CmmNode)+fixStgRegisters _ top@(CmmData _ _) = top++fixStgRegisters platform (CmmProc info lbl live graph) =+  let graph' = modifyGraph (mapGraphBlocks mapMap (fixStgRegBlock platform)) graph+  in CmmProc info lbl live graph'++fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block++fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x+fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt+  where+    fixAssign stmt =+      case stmt of+        CmmAssign (CmmGlobal reg_use) src+          -- MachSp isn't an STG register; it's merely here for tracking unwind+          -- information+          | reg == MachSp -> stmt+          | otherwise ->+            let baseAddr = get_GlobalReg_addr platform reg+            in case reg `elem` activeStgRegs platform of+                True  -> CmmAssign (CmmGlobal reg_use) src+                False -> CmmStore baseAddr src NaturallyAligned+          where reg = globalRegUse_reg reg_use+        other_stmt -> other_stmt++    fixExpr expr = case expr of+        -- MachSp isn't an STG; it's merely here for tracking unwind information+        CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr+        CmmReg (CmmGlobal reg_use) ->+            -- Replace register leaves with appropriate StixTrees for+            -- the given target.  MagicIds which map to a reg on this+            -- arch are left unchanged.  For the rest, BaseReg is taken+            -- to mean the address of the reg table in MainCapability,+            -- and for all others we generate an indirection to its+            -- location in the register table.+            let reg = globalRegUse_reg reg_use in+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False ->+                    let baseAddr = get_GlobalReg_addr platform reg+                    in case reg of+                        BaseReg -> baseAddr+                        _other  -> CmmLoad baseAddr+                                     (globalRegUse_type reg_use)+                                     NaturallyAligned++        CmmRegOff greg@(CmmGlobal reg) offset ->+            -- RegOf leaves are just a shorthand form. If the reg maps+            -- to a real reg, we keep the shorthand, otherwise, we just+            -- expand it and defer to the above code.+            -- NB: to ensure type correctness we need to ensure the Add+            --     as well as the Int need to be of the same size as the+            --     register.+            case globalRegUse_reg reg `elem` activeStgRegs platform of+                True  -> expr+                False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [+                                    fixExpr (CmmReg greg),+                                    CmmLit (CmmInt (fromIntegral offset)+                                                   (cmmRegWidth greg))]++        other_expr -> other_expr
compiler/GHC/StgToCmm/Config.hs view
@@ -11,6 +11,7 @@ import GHC.Utils.Outputable import GHC.Utils.TmpFs +import GHC.Cmm.MachOp ( FMASign(..) ) import GHC.Prelude  @@ -45,10 +46,10 @@   ---------------------------------- Flags --------------------------------------   , stgToCmmLoopification  :: !Bool              -- ^ Loopification enabled (cf @-floopification@)   , stgToCmmAlignCheck     :: !Bool              -- ^ Insert alignment check (cf @-falignment-sanitisation@)-  , stgToCmmOptHpc         :: !Bool              -- ^ perform code generation for code coverage   , stgToCmmFastPAPCalls   :: !Bool              -- ^   , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled   , stgToCmmEagerBlackHole :: !Bool              -- ^+  , stgToCmmOrigThunkInfo  :: !Bool              -- ^ Push @stg_orig_thunk_info@ frames during thunk update.   , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See Note [Mapping Info Tables to Source Positions]   , stgToCmmInfoTableMapWithFallback :: !Bool    -- ^ Include info tables with fallback source locations in the info table map   , stgToCmmInfoTableMapWithStack :: !Bool       -- ^ Include info tables for STACK closures in the info table map@@ -61,13 +62,20 @@   , stgToCmmDoBoundsCheck  :: !Bool              -- ^ decides whether to check array bounds in StgToCmm.Prim                                                  -- or not   , stgToCmmDoTagCheck     :: !Bool              -- ^ Verify tag inference predictions.+  , stgToCmmObjectDeterminism :: !Bool           -- ^ Enable deterministic code generation (more precisely, the deterministic unique-renaming pass in StgToCmm)   ------------------------------ Backend Flags -----------------------------------  , stgToCmmAllowBigArith             :: !Bool   -- ^ Allowed to emit larger than native size arithmetic (only LLVM and C backends)+  , stgToCmmAllowArith64              :: !Bool   -- ^ Allowed to emit 64-bit arithmetic operations+  , stgToCmmAllowQuot64               :: !Bool   -- ^ Allowed to emit 64-bit division operations   , stgToCmmAllowQuotRemInstr         :: !Bool   -- ^ Allowed to generate QuotRem instructions   , stgToCmmAllowQuotRem2             :: !Bool   -- ^ Allowed to generate QuotRem   , stgToCmmAllowExtendedAddSubInstrs :: !Bool   -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc.   , 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   ------------------------------ SIMD flags ------------------------------------   -- Each of these flags checks vector compatibility with the backend requested   -- during compilation. In essence, this means checking for @-fllvm@ which is
compiler/GHC/StgToCmm/Types.hs view
@@ -22,7 +22,6 @@  import GHC.Utils.Outputable - {- Note [Conveying CAF-info and LFInfo between modules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -53,7 +52,7 @@   #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging    Conservative assumption here is made when we import an Id without a-  LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported.+  LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.importedIdLFInfo.  So we arrange to always serialise this information into the interface file.  The moving parts are:@@ -75,10 +74,26 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in `Note [Conveying CAF-info and LFInfo between modules]`, imported unlifted nullary datacons must have their LambdaFormInfo set to-reflect the fact that they are evaluated . This is necessary as otherwise+reflect the fact that they are evaluated. This is necessary as otherwise references to them may be passed untagged to code that expects tagged-references.+references because of the unlifted nature of the argument. +For example, in++   type T :: UnliftedType+   data T = T1+          | T2++   f :: T -> Int+   f x = case x of T1 -> 1; T2 -> 2++`f` expects `x` to be evaluated and properly tagged due to its unliftedness.+We can guarantee all occurrences of `T1` and `T2` are considered evaluated and+are properly tagged by giving them the `LFCon` LambdaFormInfo which indicates+they are fully saturated constructor applications.+(The LambdaFormInfo is used to tag the pointer with the tag of the+constructor, in `litIdInfo`)+ What may be less obvious is that this must be done for not only datacon workers but also *wrappers*. The reason is found in this program from #23146:@@ -109,11 +124,9 @@ of the unlifted nature of its arguments by omitting handling of the zero tag when scrutinising them. -The fix is straightforward: extend the logic in `mkLFImported` to cover-(nullary) datacon wrappers as well as workers. This is safe because we-know that the wrapper of a nullary datacon will be in WHNF, even if it-includes equalities evidence (since such equalities are not runtime-relevant). This fixed #23146.+The fix is straightforward: ensure we always construct a /correct/ LFInfo for+datacon workers and wrappers, and populate the `lfInfo` with it. See+Note [LFInfo of DataCon workers and wrappers]. This fixed #23146.  See also Note [The LFInfo of Imported Ids] -}
+ compiler/GHC/StgToJS/Linker/Types.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.StgToJS.Linker.Types+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+-----------------------------------------------------------------------------++module GHC.StgToJS.Linker.Types+  ( JSLinkConfig (..)+  , LinkPlan (..)+  )+where++import GHC.StgToJS.Object++import GHC.Unit.Types+import GHC.Utils.Outputable (Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat))++import Data.Map.Strict      (Map)+import Data.Set             (Set)+import qualified Data.Set        as S++import System.IO++import Prelude++--------------------------------------------------------------------------------+-- Linker Config+--------------------------------------------------------------------------------++data JSLinkConfig = JSLinkConfig+  { lcNoJSExecutables :: !Bool         -- ^ Dont' build JS executables+  , lcNoHsMain        :: !Bool         -- ^ Don't generate Haskell main entry+  , lcNoRts           :: !Bool         -- ^ Don't dump the generated RTS+  , lcNoStats         :: !Bool         -- ^ Disable .stats file generation+  , lcForeignRefs     :: !Bool         -- ^ Dump .frefs (foreign references) files+  , lcCombineAll      :: !Bool         -- ^ Generate all.js (combined js) + wrappers+  , lcForceEmccRts    :: !Bool+      -- ^ Force the link with the emcc rts. Use this if you plan to dynamically+      -- load wasm modules made from C files (e.g. in iserv).+  , lcLinkCsources    :: !Bool+      -- ^ Link C sources (compiled to JS/Wasm) with Haskell code compiled to+      -- JS. This implies the use of the Emscripten RTS to load this code.+  }++data LinkPlan = LinkPlan+  { lkp_block_info :: Map Module LocatedBlockInfo+      -- ^ Block information++  , lkp_dep_blocks :: Set BlockRef+      -- ^ Blocks to link++  , lkp_archives   :: !(Set FilePath)+      -- ^ Archives to load JS and Cc sources from (JS code corresponding to+      -- Haskell code is handled with blocks above)++  , lkp_objs_js   :: !(Set FilePath)+      -- ^ JS objects to link++  , lkp_objs_cc   :: !(Set FilePath)+      -- ^ Cc objects to link+  }++instance Outputable LinkPlan where+  ppr s = hang (text "LinkPlan") 2 $ vcat+            -- Hidden because it's too verbose and it's not really part of the+            -- plan, just meta info used to retrieve actual block contents+            -- [ hcat [ text "Block info: ", ppr (lkp_block_info s)]+            [ hcat [ text "Blocks: ", ppr (S.size (lkp_dep_blocks s))]+            , hang (text "Archives:") 2 (vcat (fmap text (S.toList (lkp_archives s))))+            , hang (text "Extra JS objects:") 2 (vcat (fmap text (S.toList (lkp_objs_js s))))+            , hang (text "Extra Cc objects:") 2 (vcat (fmap text (S.toList (lkp_objs_cc s))))+            ]
+ compiler/GHC/StgToJS/Object.hs view
@@ -0,0 +1,802 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiWayIf                 #-}++-- only for DB.Binary instances on Module+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.StgToJS.Object+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Sylvain Henry  <sylvain.henry@iohk.io>+--                Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--  Serialization/deserialization of binary .o files for the JavaScript backend+--+-----------------------------------------------------------------------------++module GHC.StgToJS.Object+  ( ObjectKind(..)+  , getObjectKind+  , getObjectKindBS+  -- * JS object+  , JSOptions(..)+  , defaultJSOptions+  , getOptionsFromJsFile+  , writeJSObject+  , readJSObject+  , parseJSObject+  , parseJSObjectBS+  -- * HS object+  , putObject+  , getObjectHeader+  , getObjectBody+  , getObject+  , readObject+  , getObjectBlocks+  , readObjectBlocks+  , readObjectBlockInfo+  , isGlobalBlock+  , Object(..)+  , IndexEntry(..)+  , LocatedBlockInfo (..)+  , BlockInfo (..)+  , BlockDeps (..)+  , BlockLocation (..)+  , BlockId+  , BlockIds+  , BlockRef (..)+  , ExportedFun (..)+  )+where++import GHC.Prelude++import           Control.Monad++import           Data.Array+import qualified Data.ByteString          as B+import qualified Data.ByteString.Unsafe   as B+import           Data.Char (isSpace)+import           Data.Int+import           Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import           Data.List (sortOn)+import qualified Data.List as List+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Word+import           Data.Semigroup+import           System.IO++import GHC.Settings.Constants (hiVersion)++import GHC.JS.Ident+import qualified GHC.JS.Syntax as Sat+import GHC.StgToJS.Types++import GHC.Unit.Module++import GHC.Data.FastString++import GHC.Types.Unique.Map++import GHC.Utils.Binary hiding (SymbolTable)+import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep)+import GHC.Utils.Monad (mapMaybeM)+import GHC.Utils.Panic+import GHC.Utils.Misc (dropWhileEndLE)+import System.IO.Unsafe+import qualified Control.Exception as Exception++----------------------------------------------+-- The JS backend supports 3 kinds of objects:+--   1. HS objects: produced from Haskell sources+--   2. JS objects: produced from JS sources+--   3. Cc objects: produced by emcc (e.g. from C sources)+--+-- They all have a different header that allows them to be distinguished.+-- See ObjectKind type.+----------------------------------------------++-- | Different kinds of object (.o) supported by the JS backend+data ObjectKind+  = ObjJs -- ^ JavaScript source embedded in a .o+  | ObjHs -- ^ JS backend object for Haskell code+  | ObjCc -- ^ Wasm module object as produced by emcc+  deriving (Show,Eq,Ord)++-- | Get the kind of a file object, if any+getObjectKind :: FilePath -> IO (Maybe ObjectKind)+getObjectKind fp = withBinaryFile fp ReadMode $ \h -> do+  let !max_header_length = max (B.length jsHeader)+                           $ max (B.length wasmHeader)+                                 (B.length hsHeader)++  bs <- B.hGet h max_header_length+  pure $! getObjectKindBS bs++-- | Get the kind of an object stored in a bytestring, if any+getObjectKindBS :: B.ByteString -> Maybe ObjectKind+getObjectKindBS bs+  | jsHeader   `B.isPrefixOf` bs = Just ObjJs+  | hsHeader   `B.isPrefixOf` bs = Just ObjHs+  | wasmHeader `B.isPrefixOf` bs = Just ObjCc+  | otherwise                    = Nothing++-- Header added to JS sources to discriminate them from other object files.+-- They all have .o extension but JS sources have this header.+jsHeader :: B.ByteString+jsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_JS"#++hsHeader :: B.ByteString+hsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_HS"#++wasmHeader :: B.ByteString+wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"#++++------------------------------------------------+-- HS objects+--+--  file layout:+--   - magic "GHCJS_HS"+--   - compiler version tag+--   - module name+--   - offsets of string table+--   - dependencies+--   - offset of the index+--   - unit infos+--   - index+--   - string table+--+------------------------------------------------++-- | A HS object file+data Object = Object+  { objModuleName    :: !ModuleName+    -- ^ name of the module+  , objHandle        :: !ReadBinHandle+    -- ^ BinHandle that can be used to read the ObjBlocks+  , objPayloadOffset :: !(Bin ObjBlock)+    -- ^ Offset of the payload (units)+  , objBlockInfo     :: !BlockInfo+    -- ^ Information about blocks+  , objIndex         :: !Index+    -- ^ Block index: symbols per block and block offset in the object file+  }++type BlockId  = Int+type BlockIds = IntSet++-- | Information about blocks (linkable units)+data BlockInfo = BlockInfo+  { bi_module     :: !Module+      -- ^ Module they were generated from+  , bi_must_link  :: !BlockIds+      -- ^ blocks that always need to be linked when this object is loaded (e.g.+      -- everything that contains initializer code or foreign exports)+  , bi_exports    :: !(Map ExportedFun BlockId)+      -- ^ exported Haskell functions -> block+  , bi_block_deps :: !(Array BlockId BlockDeps)+      -- ^ dependencies of each block+  }++data LocatedBlockInfo = LocatedBlockInfo+  { lbi_loc  :: !BlockLocation -- ^ Where to find the blocks+  , lbi_info :: !BlockInfo     -- ^ Block information+  }++instance Outputable BlockInfo where+  ppr d = vcat+    [ hcat [ text "module: ", pprModule (bi_module d) ]+    , hcat [ text "exports: ", ppr (M.keys (bi_exports d)) ]+    ]++-- | Where are the blocks+data BlockLocation+  = ObjectFile  FilePath       -- ^ In an object file at path+  | ArchiveFile FilePath       -- ^ In a Ar file at path+  | InMemory    String Object  -- ^ In memory++instance Outputable BlockLocation where+  ppr = \case+    ObjectFile fp  -> hsep [text "ObjectFile", text fp]+    ArchiveFile fp -> hsep [text "ArchiveFile", text fp]+    InMemory s o   -> hsep [text "InMemory", text s, ppr (objModuleName o)]++-- | A @BlockRef@ is a pair of a module and the index of the block in the+-- object file+data BlockRef = BlockRef+  { block_ref_mod :: !Module  -- ^ Module+  , block_ref_idx :: !BlockId -- ^ Block index in the object file+  }+  deriving (Eq,Ord)++data BlockDeps = BlockDeps+  { blockBlockDeps       :: [BlockId]     -- ^ dependencies on blocks in this object+  , blockFunDeps         :: [ExportedFun] -- ^ dependencies on exported symbols in other objects+  -- , blockForeignExported :: [ExpFun]+  -- , blockForeignImported :: [ForeignRef]+  }++-- | we use the convention that the first block (0) is a module-global block+-- that's always included when something from the module is loaded. everything+-- in a module implicitly depends on the global block. The global block itself+-- can't have dependencies+isGlobalBlock :: BlockId -> Bool+isGlobalBlock n = n == 0++-- | Exported Functions+data ExportedFun = ExportedFun+  { funModule  :: !Module              -- ^ The module containing the function+  , funSymbol  :: !LexicalFastString   -- ^ The function+  } deriving (Eq, Ord)++instance Outputable ExportedFun where+  ppr (ExportedFun m f) = vcat+    [ hcat [ text "module: ", pprModule m ]+    , hcat [ text "symbol: ", ppr f ]+    ]++-- | Write an ObjBlock, except for the top level symbols which are stored in the+-- index+putObjBlock :: WriteBinHandle -> ObjBlock -> IO ()+putObjBlock bh (ObjBlock _syms b c d e f g) = do+    lazyPut bh b+    lazyPut bh c+    lazyPut bh d+    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 <- lazyGet bh+    c <- lazyGet bh+    d <- lazyGet bh+    e <- lazyGet bh+    f <- lazyGet bh+    g <- lazyGet bh+    pure $ ObjBlock+      { oiSymbols  = syms+      , oiClInfo   = b+      , oiStatic   = c+      , oiStat     = d+      , oiRaw      = e+      , oiFExports = f+      , oiFImports = g+      }+++-- | Serialized block indexes and their exported symbols+-- (the first block is module-global)+type Index = [IndexEntry]+data IndexEntry = IndexEntry+  { idxSymbols :: ![FastString]  -- ^ Symbols exported by a block+  , idxOffset  :: !(Bin ObjBlock) -- ^ Offset of the block in the object file+  }+++--------------------------------------------------------------------------------+-- Essential operations on Objects+--------------------------------------------------------------------------------++-- | Given a handle to a Binary payload, add the module, 'mod_name', its+-- dependencies, 'deps', and its linkable units to the payload.+putObject+  :: WriteBinHandle+  -> ModuleName -- ^ module+  -> BlockInfo  -- ^ block infos+  -> [ObjBlock] -- ^ linkable units and their symbols+  -> IO ()+putObject bh mod_name deps os = do+  putByteString bh hsHeader+  put_ bh (show hiVersion)++  -- we store the module name as a String because we don't want to have to+  -- decode the FastString table just to decode it when we're looking for an+  -- object in an archive.+  put_ bh (moduleNameString mod_name)++  (fs_tbl, fs_writer) <- initFastStringWriterTable+  let bh_fs = addWriterToUserData fs_writer bh++  forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do+    put_ bh_fs deps++    -- forward put the index+    forwardPut_ bh_fs (put_ bh_fs) $ do+      idx <- forM os $ \o -> do+        p <- tellBinWriter bh_fs+        -- write units without their symbols+        putObjBlock bh_fs o+        -- return symbols and offset to store in the index+        pure (oiSymbols o,p)+      pure idx++-- | Parse object header+getObjectHeader :: ReadBinHandle -> IO (Either String ModuleName)+getObjectHeader bh = do+  magic <- getByteString bh (B.length hsHeader)+  case magic == hsHeader of+    False -> pure (Left "invalid magic header for HS object")+    True  -> do+      is_correct_version <- ((== hiVersion) . read) <$> get bh+      case is_correct_version of+        False -> pure (Left "invalid header version")+        True  -> do+          mod_name <- get bh+          pure (Right (mkModuleName (mod_name)))+++-- | Parse object body. Must be called after a successful getObjectHeader+getObjectBody :: ReadBinHandle -> ModuleName -> IO Object+getObjectBody bh0 mod_name = do+  -- Read the string table+  dict <- forwardGet bh0 (getDictionary bh0)+  let bh = setReaderUserData bh0 $ newReadState (panic "No name allowed") (getDictFastString dict)++  block_info  <- get bh+  idx         <- forwardGet bh (get bh)+  payload_pos <- tellBinReader bh++  pure $ Object+    { objModuleName    = mod_name+    , objHandle        = bh+    , objPayloadOffset = payload_pos+    , objBlockInfo     = block_info+    , objIndex         = idx+    }++-- | Parse object+getObject :: ReadBinHandle -> IO (Maybe Object)+getObject bh = do+  getObjectHeader bh >>= \case+    Left _err      -> pure Nothing+    Right mod_name -> Just <$> getObjectBody bh mod_name++-- | Read object from file+--+-- The object is still in memory after this (see objHandle).+readObject :: FilePath -> IO (Maybe Object)+readObject file = do+  bh <- readBinMem file+  getObject bh++-- | Reads only the part necessary to get the block info+readObjectBlockInfo :: FilePath -> IO (Maybe BlockInfo)+readObjectBlockInfo file = do+  bh <- readBinMem file+  getObject bh >>= \case+    Just obj -> pure $! Just $! objBlockInfo obj+    Nothing  -> pure Nothing++-- | Get blocks in the object file, using the given filtering function+getObjectBlocks :: Object -> BlockIds -> IO [ObjBlock]+getObjectBlocks obj bids = mapMaybeM read_entry (zip (objIndex obj) [0..])+  where+    bh = objHandle obj+    read_entry (IndexEntry syms offset,i)+      | IS.member i bids = do+          seekBinReader bh offset+          Just <$> getObjBlock syms bh+      | otherwise = pure Nothing++-- | Read blocks in the object file, using the given filtering function+readObjectBlocks :: FilePath -> BlockIds -> IO [ObjBlock]+readObjectBlocks file bids = do+  readObject file >>= \case+    Nothing  -> pure []+    Just obj -> getObjectBlocks obj bids+++--------------------------------------------------------------------------------+-- Helper functions+--------------------------------------------------------------------------------++putEnum :: Enum a => WriteBinHandle -> a -> IO ()+putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n)+             | otherwise = put_ bh n+  where n = fromIntegral $ fromEnum x :: Word16++getEnum :: Enum a => ReadBinHandle -> IO a+getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16)++-- | Helper to convert Int to Int32+toI32 :: Int -> Int32+toI32 = fromIntegral++-- | Helper to convert Int32 to Int+fromI32 :: Int32 -> Int+fromI32 = fromIntegral+++--------------------------------------------------------------------------------+-- Binary Instances+--------------------------------------------------------------------------------++instance Binary IndexEntry where+  put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b+  get bh = IndexEntry <$> get bh <*> get bh++instance Binary BlockInfo where+  put_ bh (BlockInfo m r e b) = do+      put_ bh m+      put_ bh (map toI32 $ IS.toList r)+      put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e)+      put_ bh (elems b)+  get bh = BlockInfo <$> get bh+             <*> (IS.fromList . map fromI32 <$> get bh)+             <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh)+             <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh)++instance Binary BlockDeps where+  put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd+  get bh = BlockDeps <$> get bh <*> get bh++instance Binary ForeignJSRef where+  put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) =+    put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty+  get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh++instance Binary ExpFun where+  put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res+  get bh                        = ExpFun <$> get bh <*> get bh <*> get bh++instance Binary Sat.JStat where+  put_ bh (Sat.DeclStat i e)       = putByte bh 1  >> put_ bh i >> put_ bh e+  put_ bh (Sat.ReturnStat e)       = putByte bh 2  >> put_ bh e+  put_ bh (Sat.IfStat e s1 s2)     = putByte bh 3  >> put_ bh e  >> put_ bh s1 >> put_ bh s2+  put_ bh (Sat.WhileStat b e s)    = putByte bh 4  >> put_ bh b  >> put_ bh e  >> put_ bh s+  put_ bh (Sat.ForStat is c s bd)  = putByte bh 5 >> put_ bh is  >> put_ bh c >> put_ bh s >> put_ bh bd+  put_ bh (Sat.ForInStat b i e s)  = putByte bh 6  >> put_ bh b  >> put_ bh i  >> put_ bh e  >> put_ bh s+  put_ bh (Sat.SwitchStat e ss s)  = putByte bh 7  >> put_ bh e  >> put_ bh ss >> put_ bh s+  put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8  >> put_ bh s1 >> put_ bh i  >> put_ bh s2 >> put_ bh s3+  put_ bh (Sat.BlockStat xs)       = putByte bh 9  >> put_ bh xs+  put_ bh (Sat.ApplStat e es)      = putByte bh 10 >> put_ bh e  >> put_ bh es+  put_ bh (Sat.UOpStat o e)        = putByte bh 11 >> put_ bh o  >> put_ bh e+  put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2+  put_ bh (Sat.LabelStat l s)      = putByte bh 13 >> put_ bh l  >> put_ bh s+  put_ bh (Sat.BreakStat ml)       = putByte bh 14 >> put_ bh ml+  put_ bh (Sat.ContinueStat ml)    = putByte bh 15 >> put_ bh ml+  put_ bh (Sat.FuncStat i is b)    = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b+  get bh = getByte bh >>= \case+    1  -> Sat.DeclStat     <$> get bh <*> get bh+    2  -> Sat.ReturnStat   <$> get bh+    3  -> Sat.IfStat       <$> get bh <*> get bh <*> get bh+    4  -> Sat.WhileStat    <$> get bh <*> get bh <*> get bh+    5  -> Sat.ForStat      <$> get bh <*> get bh <*> get bh <*> get bh+    6  -> Sat.ForInStat    <$> get bh <*> get bh <*> get bh <*> get bh+    7  -> Sat.SwitchStat   <$> get bh <*> get bh <*> get bh+    8  -> Sat.TryStat      <$> get bh <*> get bh <*> get bh <*> get bh+    9  -> Sat.BlockStat    <$> get bh+    10 -> Sat.ApplStat     <$> get bh <*> get bh+    11 -> Sat.UOpStat      <$> get bh <*> get bh+    12 -> Sat.AssignStat   <$> get bh <*> get bh <*> get bh+    13 -> Sat.LabelStat    <$> get bh <*> get bh+    14 -> Sat.BreakStat    <$> get bh+    15 -> Sat.ContinueStat <$> get bh+    16 -> Sat.FuncStat     <$> get bh <*> get bh <*> get bh+    n -> error ("Binary get bh JStat: invalid tag: " ++ show n)+++instance Binary Sat.JExpr where+  put_ bh (Sat.ValExpr v)          = putByte bh 1 >> put_ bh v+  put_ bh (Sat.SelExpr e i)        = putByte bh 2 >> put_ bh e  >> put_ bh i+  put_ bh (Sat.IdxExpr e1 e2)      = putByte bh 3 >> put_ bh e1 >> put_ bh e2+  put_ bh (Sat.InfixExpr o e1 e2)  = putByte bh 4 >> put_ bh o  >> put_ bh e1 >> put_ bh e2+  put_ bh (Sat.UOpExpr o e)        = putByte bh 5 >> put_ bh o  >> put_ bh e+  put_ bh (Sat.IfExpr e1 e2 e3)    = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3+  put_ bh (Sat.ApplExpr e es)      = putByte bh 7 >> put_ bh e  >> put_ bh es+  get bh = getByte bh >>= \case+    1 -> Sat.ValExpr   <$> get bh+    2 -> Sat.SelExpr   <$> get bh <*> get bh+    3 -> Sat.IdxExpr   <$> get bh <*> get bh+    4 -> Sat.InfixExpr <$> get bh <*> get bh <*> get bh+    5 -> Sat.UOpExpr   <$> get bh <*> get bh+    6 -> Sat.IfExpr    <$> get bh <*> get bh <*> get bh+    7 -> Sat.ApplExpr  <$> get bh <*> get bh+    n -> error ("Binary get bh UnsatExpr: invalid tag: " ++ show n)+++instance Binary Sat.JVal where+  put_ bh (Sat.JVar i)      = putByte bh 1 >> put_ bh i+  put_ bh (Sat.JList es)    = putByte bh 2 >> put_ bh es+  put_ bh (Sat.JDouble d)   = putByte bh 3 >> put_ bh d+  put_ bh (Sat.JInt i)      = putByte bh 4 >> put_ bh i+  put_ bh (Sat.JStr xs)     = putByte bh 5 >> put_ bh xs+  put_ bh (Sat.JRegEx xs)   = putByte bh 6 >> put_ bh xs+  put_ bh (Sat.JBool b)     = putByte bh 7 >> put_ bh b+  put_ bh (Sat.JHash m)     = putByte bh 8 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)+  put_ bh (Sat.JFunc is s)  = putByte bh 9 >> put_ bh is >> put_ bh s+  get bh = getByte bh >>= \case+    1 -> Sat.JVar    <$> get bh+    2 -> Sat.JList   <$> get bh+    3 -> Sat.JDouble <$> get bh+    4 -> Sat.JInt    <$> get bh+    5 -> Sat.JStr    <$> get bh+    6 -> Sat.JRegEx  <$> get bh+    7 -> Sat.JBool   <$> get bh+    8 -> Sat.JHash . listToUniqMap <$> get bh+    9 -> Sat.JFunc   <$> get bh <*> get bh+    n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n)++instance Binary Ident where+  put_ bh (identFS -> xs) = put_ bh xs+  get  bh                 = name <$> get bh++instance Binary ClosureInfo where+  put_ bh (ClosureInfo v regs name layo typ static) = do+    put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static+  get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh++instance Binary JSFFIType where+  put_ bh = putEnum bh+  get bh = getEnum bh++instance Binary JSRep where+  put_ bh = putEnum bh+  get bh = getEnum bh++instance Binary CIRegs where+  put_ bh CIRegsUnknown       = putByte bh 1+  put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types+  get bh = getByte bh >>= \case+    1 -> pure CIRegsUnknown+    2 -> CIRegs <$> get bh <*> get bh+    n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n)++instance Binary Sat.Op where+  put_ bh = putEnum bh+  get bh = getEnum bh++instance Binary Sat.UOp where+  put_ bh = putEnum bh+  get bh = getEnum bh++instance Binary Sat.AOp where+  put_ bh = putEnum bh+  get bh = getEnum bh++-- 16 bit sizes should be enough...+instance Binary CILayout where+  put_ bh CILayoutVariable           = putByte bh 1+  put_ bh (CILayoutUnknown size)     = putByte bh 2 >> put_ bh size+  put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types+  get bh = getByte bh >>= \case+    1 -> pure CILayoutVariable+    2 -> CILayoutUnknown <$> get bh+    3 -> CILayoutFixed   <$> get bh <*> get bh+    n -> error ("Binary get bh CILayout: invalid tag: " ++ show n)++instance Binary CIStatic where+  put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs+  get bh = getByte bh >>= \case+    1 -> CIStaticRefs <$> get bh+    n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n)++instance Binary CIType where+  put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs+  put_ bh CIThunk            = putByte bh 2+  put_ bh (CICon conTag)     = putByte bh 3 >> put_ bh conTag+  put_ bh CIPap              = putByte bh 4+  put_ bh CIBlackhole        = putByte bh 5+  put_ bh CIStackFrame       = putByte bh 6+  get bh = getByte bh >>= \case+    1 -> CIFun <$> get bh <*> get bh+    2 -> pure CIThunk+    3 -> CICon <$> get bh+    4 -> pure CIPap+    5 -> pure CIBlackhole+    6 -> pure CIStackFrame+    n -> error ("Binary get bh CIType: invalid tag: " ++ show n)++instance Binary ExportedFun where+  put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb+  get bh = ExportedFun <$> get bh <*> get bh++instance Binary StaticInfo where+  put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc+  get bh = StaticInfo <$> get bh <*> get bh <*> get bh++instance Binary StaticVal where+  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 -> StaticApp SAKFun <$> get bh <*> get bh+    2 -> StaticApp SAKThunk <$> get bh <*> get bh+    3 -> StaticUnboxed <$> 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)++instance Binary StaticUnboxed where+  put_ bh (StaticUnboxedBool b)           = putByte bh 1 >> put_ bh b+  put_ bh (StaticUnboxedInt i)            = putByte bh 2 >> put_ bh i+  put_ bh (StaticUnboxedDouble d)         = putByte bh 3 >> put_ bh d+  put_ bh (StaticUnboxedString str)       = putByte bh 4 >> put_ bh str+  put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str+  get bh = getByte bh >>= \case+    1 -> StaticUnboxedBool         <$> get bh+    2 -> StaticUnboxedInt          <$> get bh+    3 -> StaticUnboxedDouble       <$> get bh+    4 -> StaticUnboxedString       <$> get bh+    5 -> StaticUnboxedStringOffset <$> get bh+    n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n)++instance Binary StaticArg where+  put_ bh (StaticObjArg i)      = putByte bh 1 >> put_ bh i+  put_ bh (StaticLitArg p)      = putByte bh 2 >> put_ bh p+  put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args+  get bh = getByte bh >>= \case+    1 -> StaticObjArg <$> get bh+    2 -> StaticLitArg <$> get bh+    3 -> StaticConArg <$> get bh <*> get bh+    n -> error ("Binary get bh StaticArg: invalid tag " ++ show n)++instance Binary StaticLit where+  put_ bh (BoolLit b)    = putByte bh 1 >> put_ bh b+  put_ bh (IntLit i)     = putByte bh 2 >> put_ bh i+  put_ bh NullLit        = putByte bh 3+  put_ bh (DoubleLit d)  = putByte bh 4 >> put_ bh d+  put_ bh (StringLit t)  = putByte bh 5 >> put_ bh t+  put_ bh (BinLit b)     = putByte bh 6 >> put_ bh b+  put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t+  get bh = getByte bh >>= \case+    1 -> BoolLit   <$> get bh+    2 -> IntLit    <$> get bh+    3 -> pure NullLit+    4 -> DoubleLit <$> get bh+    5 -> StringLit <$> get bh+    6 -> BinLit    <$> get bh+    7 -> LabelLit  <$> get bh <*> get bh+    n -> error ("Binary get bh StaticLit: invalid tag " ++ show n)+++------------------------------------------------+-- JS objects+------------------------------------------------++-- | Options obtained from pragmas in JS files+data JSOptions = JSOptions+  { enableCPP                  :: !Bool     -- ^ Enable CPP on the JS file+  , emccExtraOptions           :: ![String] -- ^ Pass additional options to emcc at link time+  , emccExportedFunctions      :: ![String] -- ^ Arguments for `-sEXPORTED_FUNCTIONS`+  , emccExportedRuntimeMethods :: ![String] -- ^ Arguments for `-sEXPORTED_RUNTIME_METHODS`+  }+  deriving (Eq, Ord)+++instance Binary JSOptions where+  put_ bh (JSOptions a b c d) = do+    put_ bh a+    put_ bh b+    put_ bh c+    put_ bh d+  get bh = JSOptions <$> get bh <*> get bh <*> get bh <*> get bh++instance Semigroup JSOptions where+  a <> b = JSOptions+    { enableCPP                  = enableCPP a || enableCPP b+    , emccExtraOptions           = emccExtraOptions a ++ emccExtraOptions b+    , emccExportedFunctions      = List.nub (List.sort (emccExportedFunctions a ++ emccExportedFunctions b))+    , emccExportedRuntimeMethods = List.nub (List.sort (emccExportedRuntimeMethods a ++ emccExportedRuntimeMethods b))+    }++defaultJSOptions :: JSOptions+defaultJSOptions = JSOptions+  { enableCPP                  = False+  , emccExtraOptions           = []+  , emccExportedRuntimeMethods = []+  , emccExportedFunctions      = []+  }++-- mimics `lines` implementation+splitOnComma :: String -> [String]+splitOnComma s = cons $ case break (== ',') s of+                                   (l, s') -> (l, case s' of+                                                    []      -> []+                                                    _:s''   -> splitOnComma s'')+  where+    cons ~(h, t)        =  h : t++++-- | Get the JS option pragmas from .js files+getJsOptions :: Handle -> IO JSOptions+getJsOptions handle = do+  hSetEncoding handle utf8+  let trim = dropWhileEndLE isSpace . dropWhile isSpace+  let go opts = do+        hIsEOF handle >>= \case+          True -> pure opts+          False -> do+            xs <- hGetLine handle+            if not ("//#OPTIONS:" `List.isPrefixOf` xs)+              then pure opts+              else do+                -- drop prefix and spaces+                let ys = trim (drop 11 xs)+                let opts' = if+                      | ys == "CPP"+                      -> opts {enableCPP = True}++                      | Just s <- List.stripPrefix "EMCC:EXPORTED_FUNCTIONS=" ys+                      , fns <- fmap trim (splitOnComma s)+                      -> opts { emccExportedFunctions = emccExportedFunctions opts ++ fns }++                      | Just s <- List.stripPrefix "EMCC:EXPORTED_RUNTIME_METHODS=" ys+                      , fns <- fmap trim (splitOnComma s)+                      -> opts { emccExportedRuntimeMethods = emccExportedRuntimeMethods opts ++ fns }++                      | Just s <- List.stripPrefix "EMCC:EXTRA=" ys+                      -> opts { emccExtraOptions = emccExtraOptions opts ++ [s] }++                      | otherwise+                      -> panic ("Unrecognized JS pragma: " ++ ys)++                go opts'+  go defaultJSOptions++-- | Parse option pragma in JS file+getOptionsFromJsFile :: FilePath     -- ^ Input file+                     -> IO JSOptions -- ^ Parsed options.+getOptionsFromJsFile filename+    = Exception.bracket+              (openBinaryFile filename ReadMode)+              hClose+              getJsOptions+++-- | Write a JS object (embed some handwritten JS code)+writeJSObject :: JSOptions -> B.ByteString -> FilePath -> IO ()+writeJSObject opts contents output_fn = do+  bh <- openBinMem (B.length contents + 1000)++  putByteString bh jsHeader+  put_ bh opts+  put_ bh contents++  writeBinMem bh output_fn+++-- | Read a JS object from BinHandle+parseJSObject :: ReadBinHandle -> IO (JSOptions, B.ByteString)+parseJSObject bh = do+  magic <- getByteString bh (B.length jsHeader)+  case magic == jsHeader of+    False -> panic "invalid magic header for JS object"+    True  -> do+      opts     <- get bh+      contents <- get bh+      pure (opts,contents)++-- | Read a JS object from ByteString+parseJSObjectBS :: B.ByteString -> IO (JSOptions, B.ByteString)+parseJSObjectBS bs = do+  bh <- unsafeUnpackBinBuffer bs+  parseJSObject bh++-- | Read a JS object from file+readJSObject :: FilePath -> IO (JSOptions, B.ByteString)+readJSObject input_fn = do+  bh <- readBinMem input_fn+  parseJSObject bh
+ compiler/GHC/StgToJS/Symbols.hs view
@@ -0,0 +1,1216 @@+{-# LANGUAGE OverloadedStrings #-}++-- | JS symbol generation+module GHC.StgToJS.Symbols where++import GHC.Prelude++import GHC.JS.JStg.Syntax+import GHC.JS.Ident++import GHC.Data.FastString+import GHC.Unit.Module+import GHC.Utils.Word64 (intToWord64)+import Data.ByteString (ByteString)+import Data.Word (Word64)+import qualified Data.ByteString.Char8   as BSC+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy    as BSL++import Data.Array+import Data.Semigroup ((<>))++-- | Hexadecimal representation of an int+--+-- Used for the sub indices.+intBS :: Int -> ByteString+intBS = word64BS . intToWord64++-- | Hexadecimal representation of a 64-bit word+--+-- Used for uniques. We could use base-62 as GHC usually does but this is likely+-- faster.+word64BS :: Word64 -> ByteString+word64BS = BSL.toStrict . BSB.toLazyByteString . BSB.word64Hex++-- | Return z-encoded unit:module+unitModuleStringZ :: Module -> ByteString+unitModuleStringZ mod = mconcat+  [ fastZStringToByteString (zEncodeFS (unitIdFS (moduleUnitId mod)))+  , BSC.pack "ZC" -- z-encoding for ":"+  , fastZStringToByteString (zEncodeFS (moduleNameFS (moduleName mod)))+  ]++-- | the global linkable unit of a module exports this symbol, depend on it to+--   include that unit (used for cost centres)+moduleGlobalSymbol :: Module -> FastString+moduleGlobalSymbol m = mkFastStringByteString $ mconcat+  [ hdB+  , unitModuleStringZ m+  , BSC.pack "_<global>"+  ]++moduleExportsSymbol :: Module -> FastString+moduleExportsSymbol m = mkFastStringByteString $ mconcat+  [ hdB+  , unitModuleStringZ m+  , BSC.pack "_<exports>"+  ]++-- | Make JS symbol corresponding to the given Haskell symbol in the given+-- module+mkJsSymbolBS :: Bool -> Module -> FastString -> ByteString+mkJsSymbolBS exported mod s = mconcat+  [ if exported then hdB else hddB+  , unitModuleStringZ mod+  , BSC.pack "zi" -- z-encoding of "."+  , fastZStringToByteString (zEncodeFS s)+  ]++-- | Make JS symbol corresponding to the given Haskell symbol in the given+-- module+mkJsSymbol :: Bool -> Module -> FastString -> FastString+mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s)++-- | Make JS symbol for given module and unique.+mkFreshJsSymbol :: Module -> Int -> FastString+mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat+  [ hddB+  , unitModuleStringZ mod+  , BSC.pack "_"+  , intBS i+  ]++-- | Make symbol "h$XYZ" or "h$$XYZ"+mkRawSymbol :: Bool -> FastString -> FastString+mkRawSymbol exported fs+  | exported  = mkFastStringByteString $ mconcat [ hdB,  bytesFS fs ]+  | otherwise = mkFastStringByteString $ mconcat [ hddB, bytesFS fs ]++-- | "h$$" constant string+hddB :: ByteString+hddB = BSC.pack "h$$"++-- | "h$" constant string+hdB :: ByteString+hdB = BSC.take 2 hddB++hd :: JStgExpr+hd = global hdStr++hdStr :: FastString+hdStr = mkFastStringByteString hdB++hdlB :: ByteString+hdlB = BSC.pack "h$l"++----------------------------------------- Runtime -------------------------------+hdApply :: JStgExpr+hdApply = global hdApplyStr++hdApplyStr :: FastString+hdApplyStr = fsLit "h$apply"++hdMoveRegs2 :: FastString+hdMoveRegs2 = fsLit "h$moveRegs2"++hdPapGen :: JStgExpr+hdPapGen = global hdPapGenStr++hdPapGenStr :: FastString+hdPapGenStr = fsLit "h$pap_gen"++hdSetReg :: JStgExpr+hdSetReg = global hdSetRegStr++hdSetRegStr :: FastString+hdSetRegStr = fsLit "h$setReg"++hdGetReg :: JStgExpr+hdGetReg = global hdGetRegStr++hdGetRegStr :: FastString+hdGetRegStr = fsLit "h$getReg"++hdResetRegisters :: Ident+hdResetRegisters = name "h$resetRegisters"++hdResetResultVars :: Ident+hdResetResultVars = name "h$resetResultVars"++hdInitClosure :: FastString+hdInitClosure = fsLit "h$init_closure"++hdRegs :: JStgExpr+hdRegs = global (identFS hdRegsStr)++hdRegsStr :: Ident+hdRegsStr = name "h$regs"++hdReturn :: JStgExpr+hdReturn = global (identFS hdReturnStr)++hdReturnStr :: Ident+hdReturnStr = name "h$return"++hdStack :: JStgExpr+hdStack = global (identFS hdStackStr)++hdStackStr :: Ident+hdStackStr = name "h$stack"++hdStackPtr :: JStgExpr+hdStackPtr = global (identFS hdStackPtrStr)++hdStackPtrStr :: Ident+hdStackPtrStr = name "h$sp"++hdBlackHoleTrap :: JStgExpr+hdBlackHoleTrap = global (identFS hdBlackHoleTrapStr)++hdBlackHoleTrapStr :: Ident+hdBlackHoleTrapStr = name "h$blackholeTrap"++hdBlockOnBlackHoleStr :: FastString+hdBlockOnBlackHoleStr = "h$blockOnBlackhole"++hdBlackHoleLNE :: JStgExpr+hdBlackHoleLNE = global (identFS hdBlackHoleLNEStr)++hdBlackHoleLNEStr :: Ident+hdBlackHoleLNEStr = name "h$bh_lne"++hdClosureTypeName :: JStgExpr+hdClosureTypeName = global (identFS hdClosureTypeNameStr)++hdClosureTypeNameStr :: Ident+hdClosureTypeNameStr = name "h$closureTypeName"++hdBh :: JStgExpr+hdBh = global hdBhStr++hdBhStr :: FastString+hdBhStr = fsLit "h$bh"++hdBlackHole :: JStgExpr+hdBlackHole = global (identFS hdBlackHoleStr)++hdBlackHoleStr :: Ident+hdBlackHoleStr = name "h$blackhole"++hdUpdFrame :: JStgExpr+hdUpdFrame = global (identFS hdUpdFrameStr)++hdUpdFrameStr :: Ident+hdUpdFrameStr = name $ fsLit "h$upd_frame"++hdCSel :: JStgExpr+hdCSel = global hdCSelStr++hdCSelStr :: FastString+hdCSelStr = "h$c_sel_"++hdEntry :: Ident+hdEntry = name hdEntryStr++hdEntryStr :: FastString+hdEntryStr = fsLit "h$e"++hdApGen :: JStgExpr+hdApGen = global (identFS hdApGenStr)++hdApGenStr :: Ident+hdApGenStr = name "h$ap_gen"++hdApGenFastStr :: Ident+hdApGenFastStr = name $ fsLit $ unpackFS (identFS hdApGenStr) ++ "_fast"++hdLog :: JStgExpr+hdLog = global hdLogStr++hdLogStr :: FastString+hdLogStr = fsLit "h$log"++hdMkFunctionPtr :: JStgExpr+hdMkFunctionPtr = global "h$mkFunctionPtr"++hdInitStatic :: JStgExpr+hdInitStatic = global (identFS hdInitStaticStr)++hdInitStaticStr :: Ident+hdInitStaticStr = name "h$initStatic"++hdHsSptInsert :: JStgExpr+hdHsSptInsert = global "h$hs_spt_insert"++hdCurrentThread :: JStgExpr+hdCurrentThread = global (identFS hdCurrentThreadStr)++hdCurrentThreadStr :: Ident+hdCurrentThreadStr = name "h$currentThread"++hdWakeupThread :: FastString+hdWakeupThread = fsLit "h$wakeupThread"++hdPaps :: JStgExpr+hdPaps = global hdPapsStr++hdPapsStr :: FastString+hdPapsStr = fsLit "h$paps"++hdPapStr_ :: FastString+hdPapStr_ = fsLit "h$pap_"++hdLazyEntryStr :: Ident+hdLazyEntryStr = name "h$lazy_e"++hdUnboxEntry :: JStgExpr+hdUnboxEntry = global (identFS hdUnboxEntryStr)++hdUnboxEntryStr :: Ident+hdUnboxEntryStr = name "h$unbox_e"++hdMaskFrame :: JStgExpr+hdMaskFrame = global (identFS hdMaskFrameStr)++hdMaskFrameStr :: Ident+hdMaskFrameStr = name "h$maskFrame"++hdUnMaskFrameStr :: Ident+hdUnMaskFrameStr = name "h$unmaskFrame"++hdReturnF :: JStgExpr+hdReturnF = global (identFS hdReturnFStr)++hdReturnFStr :: Ident+hdReturnFStr = name "h$returnf"++hdResumeEntryStr :: Ident+hdResumeEntryStr = name "h$resume_e"++hdFlushStdout :: JStgExpr+hdFlushStdout = global (identFS hdFlushStdoutStr)++hdFlushStdoutStr :: Ident+hdFlushStdoutStr = name "h$flushStdout"++hdFlushStdoutEntry :: JStgExpr+hdFlushStdoutEntry = global (identFS hdFlushStdoutEntryStr)++hdFlushStdoutEntryStr :: Ident+hdFlushStdoutEntryStr = name "h$flushStdout_e"++hdRunIOEntry :: JStgExpr+hdRunIOEntry = global (identFS hdRunIOEntryStr)++hdRunIOEntryStr :: Ident+hdRunIOEntryStr = name "h$runio_e"++hdReduce :: JStgExpr+hdReduce = global (identFS hdReduceStr)++hdReduceStr :: Ident+hdReduceStr = name "h$reduce"++hdThrowStr :: FastString+hdThrowStr = fsLit "h$throw"++hdRaiseAsyncFrame :: JStgExpr+hdRaiseAsyncFrame = global (identFS hdRaiseAsyncFrameStr)++hdRaiseAsyncFrameStr :: Ident+hdRaiseAsyncFrameStr = name "h$raiseAsync_frame"++hdRaiseAsyncEntry :: JStgExpr+hdRaiseAsyncEntry = global (identFS hdRaiseAsyncEntryStr)++hdRaiseAsyncEntryStr :: Ident+hdRaiseAsyncEntryStr = name "h$raiseAsync_e"++hdRaiseEntry :: JStgExpr+hdRaiseEntry = global (identFS hdRaiseEntryStr)++hdRaiseEntryStr :: Ident+hdRaiseEntryStr = name "h$raise_e"++hdKeepAliveEntry :: JStgExpr+hdKeepAliveEntry = global (identFS hdKeepAliveEntryStr)++hdKeepAliveEntryStr :: Ident+hdKeepAliveEntryStr = name "h$keepAlive_e"++hdSelect2Return :: JStgExpr+hdSelect2Return = global (identFS hdSelect2ReturnStr)++hdSelect2ReturnStr :: Ident+hdSelect2ReturnStr = name "h$select2_ret"++hdSelect2Entry :: JStgExpr+hdSelect2Entry = global (identFS hdSelect2EntryStr)++hdSelect2EntryStr :: Ident+hdSelect2EntryStr = name "h$select2_e"++hdSelect1Ret :: JStgExpr+hdSelect1Ret = global (identFS hdSelect1RetStr)++hdSelect1RetStr :: Ident+hdSelect1RetStr = name "h$select1_ret"++hdSelect1EntryStr :: Ident+hdSelect1EntryStr = name "h$select1_e"++hdStaticThunkStr :: FastString+hdStaticThunkStr = fsLit "h$static_thunk"++hdStaticThunksStr+  , hdStaticThunksArrStr+  , hdCAFsStr+  , hdCAFsResetStr :: Ident+hdStaticThunksStr    = name "h$staticThunks"+hdStaticThunksArrStr = name "h$staticThunksArr"+hdCAFsStr            = name "h$CAFs"+hdCAFsResetStr       = name "h$CAFsReset"++hdUpdThunkEntryStr :: Ident+hdUpdThunkEntryStr = name "h$upd_thunk_e"++hdAp3EntryStr :: Ident+hdAp3EntryStr = name "h$ap3_e"++hdAp2EntryStr :: Ident+hdAp2EntryStr = name "h$ap2_e"++hdAp1EntryStr :: Ident+hdAp1EntryStr = name "h$ap1_e"++hdDataToTagEntryStr :: Ident+hdDataToTagEntryStr = name "h$dataToTag_e"++hdTagToEnum :: FastString+hdTagToEnum = fsLit "h$tagToEnum"++hdCatchEntryStr :: Ident+hdCatchEntryStr = name "h$catch_e"++hdNoopStr :: Ident+hdNoopStr = name "h$noop"++hdNoopEntry :: JStgExpr+hdNoopEntry = global (identFS hdNoopEntryStr)++hdNoopEntryStr :: Ident+hdNoopEntryStr = name "h$noop_e"++hdC0 :: JStgExpr+hdC0 = global (identFS hdC0Str)++hdC :: JStgExpr+hdC = global (identFS hdCStr)++hdC0Str :: Ident+hdC0Str = name "h$c0"++hdCStr :: Ident+hdCStr = name "h$c"++hdData2Entry :: Ident+hdData2Entry = name "h$data2_e"++hdData1Entry :: Ident+hdData1Entry = name "h$data1_e"++hdTrueEntry :: Ident+hdTrueEntry = name "h$true_e"++hdFalseEntry :: Ident+hdFalseEntry = name "h$false_e"++hdDoneMainEntry :: JStgExpr+hdDoneMainEntry = global (identFS hdDoneMainEntryStr)++hdDoneMainEntryStr :: Ident+hdDoneMainEntryStr = name "h$doneMain_e"++hdDoneMain :: JStgExpr+hdDoneMain = global "h$doneMain"++hdDone :: Ident+hdDone = name "h$done"++hdExitProcess :: FastString+hdExitProcess = "h$exitProcess"++hdTraceAlloc :: FastString+hdTraceAlloc = fsLit "h$traceAlloc"++hdDebugAllocNotifyAlloc :: FastString+hdDebugAllocNotifyAlloc = fsLit "h$debugAlloc_notifyAlloc"++hdRtsTraceForeign+  , hdRtsProfiling+  , hdCtFun+  , hdCtCon+  , hdCtThunk+  , hdCtPap+  , hdCtBlackhole+  , hdCtStackFrame+  , hdCtVtPtr+  , hdVtVoid+  , hdVtInt+  , hdVtDouble+  , hdVtLong+  , hdVtAddr+  , hdVtObj+  , hdVtArr :: Ident+hdRtsTraceForeign = name "h$rts_traceForeign"+hdRtsProfiling    = name "h$rts_profiling"+hdCtFun           = name "h$ct_fun"+hdCtCon           = name "h$ct_con"+hdCtThunk         = name "h$ct_thunk"+hdCtPap           = name "h$ct_pap"+hdCtBlackhole     = name "h$ct_blackhole"+hdCtStackFrame    = name "h$ct_stackframe"+hdCtVtPtr         = name "h$vt_ptr"+hdVtVoid          = name "h$vt_void"+hdVtInt           = name "h$vt_int"+hdVtDouble        = name "h$vt_double"+hdVtLong          = name "h$vt_long"+hdVtAddr          = name "h$vt_addr"+hdVtObj           = name "h$vt_obj"+hdVtArr           = name "h$vt_arr"+++hdLoads :: Array Int Ident+hdLoads = listArray (1,32) [ name . mkFastStringByteString $ hdlB <> BSC.pack (show n)+                           | n <- [1..32::Int]+                           ]++----------------------------------------- Precompiled Aps ----------------------+hdAp00 :: JStgExpr+hdAp00 = global (identFS hdAp00Str)++hdAp00Str :: Ident+hdAp00Str = name "h$ap_0_0"++hdAp00FastStr :: FastString+hdAp00FastStr = fsLit "h$ap_0_0_fast"++hdAp11Fast :: FastString+hdAp11Fast = fsLit "h$ap_1_1_fast"++hdAp10 :: JStgExpr+hdAp10 = global "h$ap_1_0"++hdAp33FastStr :: FastString+hdAp33FastStr = fsLit "h$ap_3_3_fast"++hdAp22FastStr :: FastString+hdAp22FastStr = fsLit "h$ap_2_2_fast"++----------------------------------------- ByteArray -----------------------------+hdNewByteArrayStr :: FastString+hdNewByteArrayStr = "h$newByteArray"++hdCopyMutableByteArrayStr :: FastString+hdCopyMutableByteArrayStr = "h$copyMutableByteArray"++hdCheckOverlapByteArrayStr :: FastString+hdCheckOverlapByteArrayStr = "h$checkOverlapByteArray"++hdShrinkMutableCharArrayStr :: FastString+hdShrinkMutableCharArrayStr = "h$shrinkMutableCharArray"++----------------------------------------- EventLog -----------------------------+hdTraceEventStr :: FastString+hdTraceEventStr = "h$traceEvent"++hdTraceEventBinaryStr :: FastString+hdTraceEventBinaryStr = "h$traceEventBinary"++hdTraceMarkerStr :: FastString+hdTraceMarkerStr = "h$traceMarker"++----------------------------------------- FFI ----------------------------------+hdThrowJSException :: JStgExpr+hdThrowJSException = global $ fsLit "h$throwJSException"++hdUnboxFFIResult :: JStgExpr+hdUnboxFFIResult = global (identFS hdUnboxFFIResultStr)++hdUnboxFFIResultStr :: Ident+hdUnboxFFIResultStr = name "h$unboxFFIResult"++hdMkForeignCallback :: JStgExpr+hdMkForeignCallback = global $ fsLit "h$mkForeignCallback"++hdTraceForeign :: JStgExpr+hdTraceForeign = global $ fsLit "h$traceForeign"++hdBuildObject :: JStgExpr+hdBuildObject = global hdBuildObjectStr++hdBuildObjectStr :: FastString+hdBuildObjectStr = fsLit "h$buildObject"++hdCallDynamicStr :: FastString+hdCallDynamicStr = fsLit "h$callDynamic"++except :: JStgExpr+except = global $ identFS exceptStr++exceptStr :: Ident+exceptStr = name $ fsLit "except"++excepStr :: FastString+excepStr = fsLit "excep"++----------------------------------------- Accessors -----------------------------++-- for almost all other symbols that are faststrings we turn 'foo' into 'fooStr'+-- because these are overloaded with JStgExpr's. But for accessors we leave+-- these as FastStrings because they will become Idents after the refactor.+mv :: FastString+mv = fsLit "mv"++lngth :: FastString+lngth = fsLit "length"++-- | only for byte arrays. This is a JS byte array method+len :: FastString+len = fsLit "len"++slice :: FastString+slice = fsLit "slice"++this :: JStgExpr+this = global "this"++arr :: FastString+arr = fsLit "arr"++dv :: FastString+dv = fsLit "dv"++d1, d2, d3 :: JStgExpr+d1 = global d1Str+d2 = global d2Str+d3 = global d3Str++d1Str, d2Str, d3Str :: FastString+d1Str = fsLit "d1"+d2Str = fsLit "d2"+d3Str = fsLit "d3"++getInt16 :: FastString+getInt16 = "getInt16"++getUint16 :: FastString+getUint16 = "getUint16"++getInt32 :: FastString+getInt32 = "getInt32"++getUint32 :: FastString+getUint32 = "getUint32"++getFloat32 :: FastString+getFloat32 = "getFloat32"++getFloat64 :: FastString+getFloat64 = "getFloat64"++setInt16 :: FastString+setInt16 = "setInt16"++setUint16 :: FastString+setUint16 = "setUint16"++setInt32 :: FastString+setInt32 = "setInt32"++setUint32 :: FastString+setUint32 = "setUint32"++setFloat32 :: FastString+setFloat32 = "setFloat32"++setFloat64 :: FastString+setFloat64 = "setFloat64"++i3, u8, u1, f6, f3 :: FastString+i3 = "i3"+u8 = "u8"+u1 = "u1"+f6 = "f6"+f3 = "f3"++val :: FastString+val = fsLit "val"++label :: FastString+label = fsLit "label"++mask :: FastString+mask = fsLit "mask"++unMask :: FastString+unMask = fsLit "unmask"++resume :: FastString+resume = "resume"++f :: FastString+f = fsLit "f"++n :: FastString+n = fsLit "n"++hasOwnProperty :: FastString+hasOwnProperty = fsLit "hasOwnProperty"++hdCollectProps :: FastString+hdCollectProps = fsLit "h$collectProps"++replace :: FastString+replace = fsLit "replace"++substring :: FastString+substring = fsLit "substring"++trace :: FastString+trace = fsLit "trace"++apply :: FastString+apply = fsLit "apply"++----------------------------------------- STM ----------------------------------+hdMVar :: JStgExpr+hdMVar = global hdMVarStr++hdMVarStr :: FastString+hdMVarStr = fsLit "h$MVar"++hdTakeMVar :: JStgExpr+hdTakeMVar = global hdTakeMVarStr++hdTakeMVarStr :: FastString+hdTakeMVarStr = fsLit "h$takeMVar"++hdTryTakeMVarStr :: FastString+hdTryTakeMVarStr = fsLit "h$tryTakeMVar"++hdPutMVarStr :: FastString+hdPutMVarStr = fsLit "h$putMVar"++hdTryPutMVarStr :: FastString+hdTryPutMVarStr = fsLit "h$tryPutMVar"++hdNewTVar :: FastString+hdNewTVar = fsLit "h$newTVar"++hdReadTVar :: FastString+hdReadTVar = fsLit "h$readTVar"++hdReadTVarIO :: FastString+hdReadTVarIO = fsLit "h$readTVarIO"++hdWriteTVar :: FastString+hdWriteTVar = fsLit "h$writeTVar"++hdReadMVarStr :: FastString+hdReadMVarStr = fsLit "h$readMVar"++hdStmRemoveBlockedThreadStr :: FastString+hdStmRemoveBlockedThreadStr = fsLit "h$stmRemoveBlockedThread"++hdStmStartTransactionStr :: FastString+hdStmStartTransactionStr = fsLit "h$stmStartTransaction"++hdAtomicallyEntry :: JStgExpr+hdAtomicallyEntry = global (identFS hdAtomicallyEntryStr)++hdAtomicallyEntryStr :: Ident+hdAtomicallyEntryStr = name $ fsLit "h$atomically_e"++hdAtomicallyStr :: FastString+hdAtomicallyStr = "h$atomically"++hdStgResumeRetryEntry :: JStgExpr+hdStgResumeRetryEntry = global (identFS hdStgResumeRetryEntryStr)++hdStgResumeRetryEntryStr :: Ident+hdStgResumeRetryEntryStr = name $ fsLit "h$stmResumeRetry_e"++hdStmCommitTransactionStr :: FastString+hdStmCommitTransactionStr = fsLit "h$stmCommitTransaction"++hdStmValidateTransactionStr :: FastString+hdStmValidateTransactionStr = "h$stmValidateTransaction"++hdStmCatchRetryEntry :: JStgExpr+hdStmCatchRetryEntry = global (identFS hdStmCatchRetryEntryStr)++hdStmCatchRetryEntryStr :: Ident+hdStmCatchRetryEntryStr = name $ fsLit "h$stmCatchRetry_e"++hdStmRetryStr :: FastString+hdStmRetryStr = fsLit "h$stmRetry"++hdStmCatchRetryStr :: FastString+hdStmCatchRetryStr = fsLit "h$stmCatchRetry"++hdStmCatchEntry :: JStgExpr+hdStmCatchEntry = global (identFS hdStmCatchEntryStr)++hdCatchStmStr :: FastString+hdCatchStmStr = fsLit "h$catchStm"++hdStmCatchEntryStr :: Ident+hdStmCatchEntryStr = name $ fsLit "h$catchStm_e"++hdRetryInterrupted :: JStgExpr+hdRetryInterrupted = global (identFS hdRetryInterruptedStr)++hdRetryInterruptedStr :: Ident+hdRetryInterruptedStr = name $ fsLit "h$retryInterrupted"++hdMaskUnintFrame :: JStgExpr+hdMaskUnintFrame = global (identFS hdMaskUnintFrameStr)++hdMaskUnintFrameStr :: Ident+hdMaskUnintFrameStr = name $ fsLit "h$maskUnintFrame"++hdReschedule :: JStgExpr+hdReschedule = global (identFS hdRescheduleStr)++hdRescheduleStr :: Ident+hdRescheduleStr = name $ fsLit "h$reschedule"++hdRestoreThread :: JStgExpr+hdRestoreThread = global (identFS hdRestoreThreadStr)++hdRestoreThreadStr :: Ident+hdRestoreThreadStr = name $ fsLit "h$restoreThread"++hdFinishedThread :: FastString+hdFinishedThread = fsLit "h$finishThread"++----------------------------------------- Z-Encodings ---------------------------+hdPrimOpStr :: FastString+hdPrimOpStr = fsLit "h$primop_"++wrapperColonStr :: FastString+wrapperColonStr = fsLit "ghczuwrapperZC" -- equivalent non-z-encoding => ghc_wrapper:++hdInternalExceptionTypeDivZero :: JStgExpr+hdInternalExceptionTypeDivZero = global "h$ghczminternalZCGHCziInternalziExceptionziTypezidivZZeroException"++hdInternalExceptionTypeOverflow :: JStgExpr+hdInternalExceptionTypeOverflow = global "h$ghczminternalZCGHCziInternalziExceptionziTypezioverflowException"++hdInternalExceptionTypeUnderflow :: JStgExpr+hdInternalExceptionTypeUnderflow = global "h$ghczminternalZCGHCziInternalziExceptionziTypeziunderflowException"++hdInternalExceptionControlExceptionBaseNonTermination :: JStgExpr+hdInternalExceptionControlExceptionBaseNonTermination = global "h$ghczminternalZCGHCziInternalziControlziExceptionziBasezinonTermination"++hdGhcInternalIOHandleFlush :: JStgExpr+hdGhcInternalIOHandleFlush = global "h$ghczminternalZCGHCziInternalziIOziHandlezihFlush"++hdGhcInternalIOHandleFDStdout :: JStgExpr+hdGhcInternalIOHandleFDStdout = global "h$ghczminternalZCGHCziInternalziIOziHandleziFDzistdout"++hdGhcInternalJSPrimValConEntryStr :: FastString+hdGhcInternalJSPrimValConEntryStr = fsLit "h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e"++----------------------------------------- Profiling -----------------------------+hdBuildCCSPtrStr :: FastString+hdBuildCCSPtrStr = "h$buildCCSPtr"++hdClearCCSStr :: FastString+hdClearCCSStr = "h$clearCCS"++hdRestoreCCSStr :: FastString+hdRestoreCCSStr = fsLit "h$restoreCCS"++hdSetCcsEntry :: JStgExpr+hdSetCcsEntry = global (identFS hdSetCcsEntryStr)++hdSetCcsEntryStr :: Ident+hdSetCcsEntryStr = name $ fsLit "h$setCcs_e"++ccStr :: FastString+ccStr = fsLit "cc"+----------------------------------------- Others -------------------------------+unknown :: FastString+unknown = fsLit "<unknown>"++typeof :: FastString+typeof = fsLit "typeof"++throwStr :: FastString+throwStr = fsLit "throw"++hdCheckObj :: JStgExpr+hdCheckObj = global $ fsLit "h$checkObj"++console :: JStgExpr+console = global consoleStr++consoleStr :: FastString+consoleStr = fsLit "console"++arguments :: JStgExpr+arguments = global argumentsStr++argumentsStr :: FastString+argumentsStr = fsLit "arguments"++hdReportHeapOverflow :: JStgExpr+hdReportHeapOverflow = global (identFS hdReportHeapOverflowStr)++hdReportHeapOverflowStr :: Ident+hdReportHeapOverflowStr = name $ fsLit "h$reportHeapOverflow"++hdReportStackOverflow :: JStgExpr+hdReportStackOverflow = global (identFS hdReportStackOverflowStr)++hdReportStackOverflowStr :: Ident+hdReportStackOverflowStr = name $ fsLit "h$reportStackOverflow"++hdDumpRes :: JStgExpr+hdDumpRes = global (identFS hdDumpResStr)++hdDumpResStr :: Ident+hdDumpResStr = name $ fsLit "h$dumpRes"++ghcjsArray :: FastString+ghcjsArray = fsLit "__ghcjsArray"++----------------------------------------- Compact -------------------------------++hdCompactSize :: FastString+hdCompactSize = fsLit "h$compactSize"++hdCompactAddWithSharing :: FastString+hdCompactAddWithSharing = fsLit "h$compactAddWithSharing"++hdCompactAdd :: FastString+hdCompactAdd = fsLit "h$compactAdd"++hdCompactFixupPointers :: FastString+hdCompactFixupPointers = fsLit "h$compactFixupPointers"++hdCompactAllocateBlock :: FastString+hdCompactAllocateBlock = fsLit "h$compactAllocateBlock"++hdCompactGetNextBlock :: FastString+hdCompactGetNextBlock = fsLit "h$compactGetNextBlock"++hdCompactGetFirstBlock :: FastString+hdCompactGetFirstBlock = fsLit "h$compactGetFirstBlock"++hdCompactContainsAny :: FastString+hdCompactContainsAny = fsLit "h$compactContainsAny"++hdCompactContains :: FastString+hdCompactContains = fsLit "h$compactContains"++hdCompactResize :: FastString+hdCompactResize = fsLit "h$compactResize"++hdCompactNew :: FastString+hdCompactNew = fsLit "h$compactNew"++----------------------------------------- Stable Pointers -----------------------++hdStableNameInt :: FastString+hdStableNameInt = fsLit "h$stableNameInt"++hdMakeStableName :: FastString+hdMakeStableName = fsLit "h$makeStableName"++hdDeRefStablePtr :: FastString+hdDeRefStablePtr = fsLit "h$deRefStablePtr"++hdStablePtrBuf :: JStgExpr+hdStablePtrBuf = global "h$stablePtrBuf"++hdMakeStablePtrStr :: FastString+hdMakeStablePtrStr = fsLit "h$makeStablePtr"++------------------------------- Weak Pointers -----------------------------------++hdKeepAlive :: FastString+hdKeepAlive = fsLit "h$keepAlive"++hdFinalizeWeak :: FastString+hdFinalizeWeak = fsLit "h$finalizeWeak"++hdMakeWeakNoFinalizer :: FastString+hdMakeWeakNoFinalizer = fsLit "h$makeWeakNoFinalizer"++hdMakeWeak :: FastString+hdMakeWeak = fsLit "h$makeWeak"++------------------------------- Concurrency Primitives -------------------------++hdGetThreadLabel :: FastString+hdGetThreadLabel = fsLit "h$getThreadLabel"++hdListThreads :: FastString+hdListThreads = fsLit "h$listThreads"++hdThreadStatus :: FastString+hdThreadStatus = fsLit "h$threadStatus"++hdYield :: FastString+hdYield = fsLit "h$yield"++hdKillThread :: FastString+hdKillThread = fsLit "h$killThread"++hdFork :: FastString+hdFork = fsLit "h$fork"++------------------------------- Delay/Wait Ops ---------------------------------++hdWaitWrite :: FastString+hdWaitWrite = fsLit "h$waitWrite"++hdWaitRead :: FastString+hdWaitRead = fsLit "h$waitRead"++hdDelayThread :: FastString+hdDelayThread = fsLit "h$delayThread"++------------------------------- Exceptions --------------------------------------++hdCatchStr :: FastString+hdCatchStr = fsLit "h$catch"++hdMaskAsyncStr :: FastString+hdMaskAsyncStr = fsLit "h$maskAsync"++hdMaskUnintAsyncStr :: FastString+hdMaskUnintAsyncStr = fsLit "h$maskUnintAsync"++hdUnmaskAsyncStr :: FastString+hdUnmaskAsyncStr = fsLit "h$unmaskAsync"++------------------------------- Mutable variables --------------------------------------++hdMutVarStr :: FastString+hdMutVarStr = fsLit "h$MutVar"++hdAtomicModifyMutVar2Str :: FastString+hdAtomicModifyMutVar2Str = fsLit "h$atomicModifyMutVar2"++hdAtomicModifyMutVarStr :: FastString+hdAtomicModifyMutVarStr = fsLit "h$atomicModifyMutVar"++------------------------------- Addr# ------------------------------------------++hdComparePointerStr :: FastString+hdComparePointerStr = fsLit "h$comparePointer"++------------------------------- Byte Arrays -------------------------------------++hdCompareByteArraysStr :: FastString+hdCompareByteArraysStr = fsLit "h$compareByteArrays"++hdResizeMutableByteArrayStr :: FastString+hdResizeMutableByteArrayStr = fsLit "h$resizeMutableByteArray"++hdShrinkMutableByteArrayStr :: FastString+hdShrinkMutableByteArrayStr = fsLit "h$shrinkMutableByteArray"++------------------------------- Arrays ------------------------------------------++hdCopyMutableArrayStr :: FastString+hdCopyMutableArrayStr = fsLit "h$copyMutableArray"++hdNewArrayStr :: FastString+hdNewArrayStr = fsLit "h$newArray"++hdSliceArrayStr :: FastString+hdSliceArrayStr = fsLit "h$sliceArray"++------------------------------ Float --------------------------------------------++hdDecodeFloatIntStr :: FastString+hdDecodeFloatIntStr = fsLit "h$decodeFloatInt"++hdCastFloatToWord32Str :: FastString+hdCastFloatToWord32Str = fsLit "h$castFloatToWord32"++hdCastWord32ToFloatStr :: FastString+hdCastWord32ToFloatStr = fsLit "h$castWord32ToFloat"++------------------------------ Double -------------------------------------------++hdDecodeDouble2IntStr :: FastString+hdDecodeDouble2IntStr = fsLit "h$decodeDouble2Int"++hdDecodeDoubleInt64Str :: FastString+hdDecodeDoubleInt64Str = fsLit "h$decodeDoubleInt64"++hdCastDoubleToWord64Str :: FastString+hdCastDoubleToWord64Str = fsLit "h$castDoubleToWord64"++hdCastWord64ToDoubleStr :: FastString+hdCastWord64ToDoubleStr = fsLit "h$castWord64ToDouble"++------------------------------ Word -------------------------------------------++hdReverseWordStr :: FastString+hdReverseWordStr = fsLit "h$reverseWord"++hdClz8Str+  , hdClz16Str+  , hdClz32Str+  , hdClz64Str+  , hdCtz8Str+  , hdCtz16Str+  , hdCtz32Str+  , hdCtz64Str :: FastString++hdClz8Str  = fsLit "h$clz8"+hdClz16Str = fsLit "h$clz16"+hdClz32Str = fsLit "h$clz32"+hdClz64Str = fsLit "h$clz64"+hdCtz8Str  = fsLit "h$ctz8"+hdCtz16Str = fsLit "h$ctz16"+hdCtz32Str = fsLit "h$ctz32"+hdCtz64Str = fsLit "h$ctz64"++hdBSwap64Str :: FastString+hdBSwap64Str = "h$bswap64"++hdPExit8Str+  , hdPExit16Str+  , hdPExit32Str+  , hdPExit64Str+  , hdPDep8Str+  , hdPDep16Str+  , hdPDep32Str+  , hdPDep64Str :: FastString++hdPExit8Str  = fsLit "h$pext8"+hdPExit16Str = fsLit "h$pext16"+hdPExit32Str = fsLit "h$pext32"+hdPExit64Str = fsLit "h$pext64"+hdPDep8Str   = fsLit "h$pdep8"+hdPDep16Str  = fsLit "h$pdep16"+hdPDep32Str  = fsLit "h$pdep32"+hdPDep64Str  = fsLit "h$pdep64"++hdPopCntTab :: JStgExpr+hdPopCntTab = global "h$popCntTab"++hdPopCnt32Str :: FastString+hdPopCnt32Str = fsLit "h$popCnt32"++hdPopCnt64Str :: FastString+hdPopCnt64Str = fsLit "h$popCnt64"++hdQuotRem2Word32Str :: FastString+hdQuotRem2Word32Str = fsLit "h$quotRem2Word32"++hdQuotRemWord32Str :: FastString+hdQuotRemWord32Str = fsLit "h$quotRemWord32"++hdRemWord32Str :: FastString+hdRemWord32Str = fsLit "h$remWord32"++hdQuotWord32Str :: FastString+hdQuotWord32Str = fsLit "h$quotWord32"++hdMul2Word32Str :: FastString+hdMul2Word32Str = fsLit "h$mul2Word32"++hdMulImulStr :: FastString+hdMulImulStr = fsLit "Math.imul"++hdWordAdd2 :: FastString+hdWordAdd2 = fsLit "h$wordAdd2"++hdHsPlusWord64Str :: FastString+hdHsPlusWord64Str = fsLit "h$hs_plusWord64"++hdHsMinusWord64Str :: FastString+hdHsMinusWord64Str = fsLit "h$hs_minusWord64"++hdHsTimesWord64Str :: FastString+hdHsTimesWord64Str = fsLit "h$hs_timesWord64"++hdHsQuotWord64Str :: FastString+hdHsQuotWord64Str = fsLit "h$hs_quotWord64"++hdHsRemWord64Str :: FastString+hdHsRemWord64Str = fsLit "h$hs_remWord64"++hdHsUncheckedShiftRWord64Str :: FastString+hdHsUncheckedShiftRWord64Str = fsLit "h$hs_uncheckedShiftRWord64"++hdHsUncheckedShiftLWord64Str :: FastString+hdHsUncheckedShiftLWord64Str = fsLit "h$hs_uncheckedShiftLWord64"++hdHsPlusInt64Str :: FastString+hdHsPlusInt64Str = fsLit "h$hs_plusInt64"++hdHsMinusInt64Str :: FastString+hdHsMinusInt64Str = fsLit "h$hs_minusInt64"++hdHsTimesInt64Str :: FastString+hdHsTimesInt64Str = fsLit "h$hs_timesInt64"++hdHsQuotInt64Str :: FastString+hdHsQuotInt64Str = fsLit "h$hs_quotInt64"++hdHsRemInt64Str :: FastString+hdHsRemInt64Str = fsLit "h$hs_remInt64"++hdHsUncheckedShiftLLInt64Str :: FastString+hdHsUncheckedShiftLLInt64Str = fsLit "h$hs_uncheckedShiftLLInt64"++hdHsUncheckedShiftRAInt64Str :: FastString+hdHsUncheckedShiftRAInt64Str = fsLit "h$hs_uncheckedShiftRAInt64"++hdHsUncheckedShiftRLInt64Str :: FastString+hdHsUncheckedShiftRLInt64Str = fsLit "h$hs_uncheckedShiftRLInt64"++hdHsTimesInt2Str :: FastString+hdHsTimesInt2Str = fsLit "h$hs_timesInt2"++------------------------------ Linker -------------------------------------------++hdEncodeModifiedUtf8Str :: FastString+hdEncodeModifiedUtf8Str = fsLit "h$encodeModifiedUtf8"++hdRawStringDataStr :: FastString+hdRawStringDataStr = fsLit "h$rawStringData"++hdPStr :: FastString+hdPStr = fsLit "h$p"++hdDStr :: FastString+hdDStr = fsLit "h$d"++hdDiStr :: FastString+hdDiStr = fsLit "h$di"++hdStcStr :: FastString+hdStcStr = fsLit "h$stc"++hdStlStr :: FastString+hdStlStr = fsLit "h$stl"++hdStiStr :: FastString+hdStiStr = fsLit "h$sti"++------------------------------ Pack/Unpack --------------------------------------------++hdDecodeUtf8Z :: FastString+hdDecodeUtf8Z = fsLit "h$decodeUtf8z"
+ compiler/GHC/StgToJS/Types.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.StgToJS.Types+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- Module that holds the Types required for the StgToJS pass+-----------------------------------------------------------------------------++module GHC.StgToJS.Types where++import GHC.Prelude++import GHC.JS.JStg.Syntax+import GHC.JS.Ident+import qualified GHC.JS.Syntax as Sat+import GHC.JS.Make+import GHC.JS.Ppr () -- expose Outputable instances to downstream modules++import GHC.StgToJS.Symbols++import GHC.Stg.Syntax+import GHC.Core.TyCon+import GHC.Linker.Config++import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Var+import GHC.Types.ForeignCall++import Control.Monad.Trans.State.Strict+import GHC.Utils.Outputable (Outputable (..), text, SDocContext)++import GHC.Data.FastString+import GHC.Data.FastMutInt++import GHC.Unit.Module++import           Data.Array+import           Data.ByteString (ByteString)+import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BSC+import           Data.Char (toUpper)+import qualified Data.Map as M+import           Data.Monoid+import           Data.Set (Set)+import           Data.Word++-- | A State monad over IO holding the generator state.+type G = StateT GenState IO++-- | The JS code generator state+data GenState = GenState+  { gsSettings  :: !StgToJSConfig         -- ^ codegen settings, read-only+  , gsModule    :: !Module                -- ^ current module+  , gsId        :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator+  , gsIdents    :: !IdCache               -- ^ hash consing for identifiers from a Unique+  , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments+  , gsGroup     :: GenGroupState          -- ^ state for the current binding group+  , gsGlobal    :: [JStgStat]             -- ^ global (per module) statements (gets included when anything else from the module is used)+  }++-- | The JS code generator state relevant for the current binding group+data GenGroupState = GenGroupState+  { ggsToplevelStats :: [JStgStat]     -- ^ extra toplevel statements for the binding group+  , ggsClosureInfo   :: [ClosureInfo]  -- ^ closure metadata (info tables) for the binding group+  , ggsStatic        :: [StaticInfo]   -- ^ static (CAF) data in our binding group+  , ggsStack         :: [StackSlot]    -- ^ stack info for the current expression+  , ggsStackDepth    :: Int            -- ^ current stack depth+  , ggsExtraDeps     :: Set OtherSymb  -- ^ extra dependencies for the linkable unit that contains this group+  , ggsGlobalIdCache :: GlobalIdCache+  , ggsForeignRefs   :: [ForeignJSRef]+  }++-- | The Configuration record for the StgToJS pass+data StgToJSConfig = StgToJSConfig+  -- flags+  { csInlinePush      :: !Bool+  , csInlineBlackhole :: !Bool+  , csInlineLoadRegs  :: !Bool+  , csInlineEnter     :: !Bool+  , csInlineAlloc     :: !Bool+  , csPrettyRender    :: !Bool+  , csTraceRts        :: !Bool+  , csAssertRts       :: !Bool+  , csBoundsCheck     :: !Bool+  , csDebugAlloc      :: !Bool+  , csTraceForeign    :: !Bool+  , csProf            :: !Bool -- ^ Profiling enabled+  , csRuntimeAssert   :: !Bool -- ^ Enable runtime assertions+  -- settings+  , csContext         :: !SDocContext+  , csLinkerConfig    :: !LinkerConfig -- ^ Emscripten linker+  }++-- | Closure info table+data ClosureInfo = ClosureInfo+  { ciVar     :: Ident      -- ^ entry code identifier: infotable fields are stored as properties of this function+  , ciRegs    :: CIRegs     -- ^ size of the payload (in number of JS values)+  , ciName    :: FastString -- ^ friendly name for printing+  , ciLayout  :: CILayout   -- ^ heap/stack layout of the object+  , ciType    :: CIType     -- ^ type of the object, with extra info where required+  , ciStatic  :: CIStatic   -- ^ static references of this object+  }+  deriving stock (Eq, Show)++-- | Closure information, 'ClosureInfo', registers+data CIRegs+  = CIRegsUnknown                     -- ^ A value witnessing a state of unknown registers+  | CIRegs { ciRegsSkip  :: Int       -- ^ unused registers before actual args start+           , ciRegsTypes :: [JSRep]   -- ^ args+           }+  deriving stock (Eq, Ord, Show)++-- | Closure Information, 'ClosureInfo', layout+data CILayout+  = CILayoutVariable            -- ^ layout stored in object itself, first position from the start+  | CILayoutUnknown             -- ^ fixed size, but content unknown (for example stack apply frame)+      { layoutSize :: !Int+      }+  | CILayoutFixed               -- ^ whole layout known+      { layoutSize :: !Int      -- ^ closure size in array positions, including entry+      , layout     :: [JSRep]   -- ^ The list of JSReps to layout+      }+  deriving stock (Eq, Ord, Show)++-- | The type of 'ClosureInfo'+data CIType+  = CIFun { citArity :: !Int         -- ^ function arity+          , citRegs  :: !Int         -- ^ number of registers for the args+          }+  | CIThunk                          -- ^ The closure is a THUNK+  | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor+  | CIPap                            -- ^ The closure is a Partial Application+  | CIBlackhole                      -- ^ The closure is a black hole+  | CIStackFrame                     -- ^ The closure is a stack frame+  deriving stock (Eq, Ord, Show)++-- | Static references that must be kept alive+newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] }+  deriving stock   (Eq)+  deriving newtype (Semigroup, Monoid, Show)++-- | static refs: array = references, null = nothing to report+--   note: only works after all top-level objects have been created+instance ToJExpr CIStatic where+  toJExpr (CIStaticRefs [])  = null_ -- [je| null |]+  toJExpr (CIStaticRefs rs)  = toJExpr (map global rs)++-- | JS primitive representations+data JSRep+  = PtrV     -- ^ pointer = reference to heap object (closure object), lifted or not.+             -- Can also be some RTS object (e.g. TVar#, MVar#, MutVar#, Weak#)+  | VoidV    -- ^ no fields+  | DoubleV  -- ^ A Double: one field+  | IntV     -- ^ An Int (32bit because JS): one field+  | LongV    -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian)+  | AddrV    -- ^ a pointer not to the heap: two fields, array + index+  | ObjV     -- ^ some JS object, user supplied, be careful around these, can be anything+  | ArrV     -- ^ boxed array+  deriving stock (Eq, Ord, Enum, Bounded, Show)++instance ToJExpr JSRep where+  toJExpr = toJExpr . fromEnum++-- | The type of identifiers. These determine the suffix of generated functions+-- in JS Land. For example, the entry function for the 'Just' constructor is a+-- 'IdConEntry' which compiles to:+-- @+-- function h$ghczminternalZCGHCziInternalziMaybeziJust_con_e() { return h$rs() };+-- @+-- which just returns whatever the stack point is pointing to. Whereas the entry+-- function to 'Just' is an 'IdEntry' and does the work. It compiles to:+-- @+-- function h$ghczminternalZCGHCziInternalziMaybeziJust_e() {+--    var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2;+--    h$r1 = h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, h$$ghczminternalZCGHCziInternalziMaybezieta_8KXnScrCjF5);+--    return h$rs();+--    };+-- @+-- Which loads some payload from register 2, and applies the Constructor Entry+-- function for the Just to the payload, returns the result in register 1 and+-- returns whatever is on top of the stack+data IdType+  = IdPlain     -- ^ A plain identifier for values, no suffix added+  | IdEntry     -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId'+  | IdConEntry  -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId'+  deriving (Enum, Eq, Ord)++-- | Keys to differentiate Ident's in the ID Cache+data IdKey+  = IdKey !Word64 !Int !IdType+  deriving (Eq, Ord)++-- | Some other symbol+data OtherSymb+  = OtherSymb !Module !FastString+  deriving Eq++instance Ord OtherSymb where+  compare (OtherSymb m1 t1) (OtherSymb m2 t2)+    = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2++-- | The identifier cache indexed on 'IdKey' local to a module+newtype IdCache = IdCache (M.Map IdKey Ident)++-- | The global Identifier Cache+newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id))++-- | A Stack Slot is either known or unknown. We avoid maybe here for more+-- strictness.+data StackSlot+  = SlotId !Id !Int+  | SlotUnknown+  deriving (Eq, Ord)++data StaticInfo = StaticInfo+  { siVar    :: !FastString    -- ^ global object+  , siVal    :: !StaticVal     -- ^ static initialization+  , 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+  = StaticUnboxed !StaticUnboxed+    -- ^ unboxed constructor (Bool, Int, Double etc)+  | 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+  = StaticUnboxedBool         !Bool+  | StaticUnboxedInt          !Integer+  | StaticUnboxedDouble       !SaneDouble+  | StaticUnboxedString       !BS.ByteString+  | StaticUnboxedStringOffset !BS.ByteString+  deriving stock (Eq, Ord, Show)++-- | Static Arguments. Static Arguments are things that are statically+-- allocated, i.e., they exist at program startup. These are static heap objects+-- or literals or things that have been floated to the top level binding by ghc.+data StaticArg+  = StaticObjArg !FastString             -- ^ reference to a heap object+  | StaticLitArg !StaticLit              -- ^ literal+  | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor+  deriving stock (Eq, Show)++instance Outputable StaticArg where+  ppr x = text (show x)++-- | A Static literal value+data StaticLit+  = BoolLit   !Bool+  | IntLit    !Integer+  | NullLit+  | DoubleLit !SaneDouble -- should we actually use double here?+  | StringLit !FastString+  | BinLit    !BS.ByteString+  | LabelLit  !Bool !FastString -- ^ is function pointer, label (also used for string / binary init)+  deriving (Eq, Show)++instance Outputable StaticLit where+  ppr x = text (show x)++instance ToJExpr StaticLit where+  toJExpr (BoolLit b)           = toJExpr b+  toJExpr (IntLit i)            = toJExpr i+  toJExpr NullLit               = null_+  toJExpr (DoubleLit d)         = toJExpr (unSaneDouble d)+  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+data ForeignJSRef = ForeignJSRef+  { foreignRefSrcSpan  :: !FastString+  , foreignRefPattern  :: !FastString+  , foreignRefSafety   :: !Safety+  , foreignRefCConv    :: !CCallConv+  , foreignRefArgs     :: ![FastString]+  , foreignRefResult   :: !FastString+  }+  deriving (Show)++-- | data used to generate one ObjBlock in our object file+data LinkableUnit = LinkableUnit+  { luObjBlock     :: ObjBlock      -- ^ serializable unit info+  , luIdExports    :: [Id]          -- ^ exported names from haskell identifiers+  , luOtherExports :: [FastString]  -- ^ other exports+  , luIdDeps       :: [Id]          -- ^ identifiers this unit depends on+  , luPseudoIdDeps :: [Unique]      -- ^ pseudo-id identifiers this unit depends on (fixme)+  , luOtherDeps    :: [OtherSymb]   -- ^ symbols not from a haskell id that this unit depends on+  , luRequired     :: Bool          -- ^ always link this unit+  , luForeignRefs  :: [ForeignJSRef]+  }++-- | 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+  , oiStat     :: Sat.JStat       -- ^ the code+  , oiRaw      :: BS.ByteString  -- ^ raw JS code+  , oiFExports :: [ExpFun]+  , oiFImports :: [ForeignJSRef]+  }++data ExpFun = ExpFun+  { isIO   :: !Bool+  , args   :: [JSFFIType]+  , result :: !JSFFIType+  } deriving (Eq, Ord, Show)++-- | Types of FFI values+data JSFFIType+  = Int8Type+  | Int16Type+  | Int32Type+  | Int64Type+  | Word8Type+  | Word16Type+  | Word32Type+  | Word64Type+  | DoubleType+  | ByteArrayType+  | PtrType+  | RefType+  deriving (Show, Ord, Eq, Enum)+++-- | Typed expression+data TypedExpr = TypedExpr+  { typex_typ  :: !PrimRep+  , typex_expr :: [JStgExpr]+  }++instance Outputable TypedExpr where+  ppr (TypedExpr typ x) = ppr (typ, x)++-- | A Primop result is either an inlining of some JS payload, or a primitive+-- call to a JS function defined in Shim files in base.+data PrimRes+  = PrimInline JStgStat  -- ^ primop is inline, result is assigned directly+  | PRPrimCall JStgStat  -- ^ primop is async call, primop returns the next+                         -- function to run. result returned to stack top in+                         -- registers++data ExprResult+  = ExprCont+  | ExprInline+  deriving (Eq)++newtype ExprValData = ExprValData [JStgExpr]+  deriving newtype (Eq)++-- | A Closure is one of six types+data ClosureType+  = Thunk       -- ^ The closure is a THUNK+  | Fun         -- ^ The closure is a Function+  | Pap         -- ^ The closure is a Partial Application+  | Con         -- ^ The closure is a Constructor+  | Blackhole   -- ^ The closure is a Blackhole+  | StackFrame  -- ^ The closure is a stack frame+  deriving (Show, Eq, Ord, Enum, Bounded, Ix)++-- | Convert 'ClosureType' to an Int+ctNum :: ClosureType -> Int+ctNum Fun        = 1+ctNum Con        = 2+ctNum Thunk      = 0+ctNum Pap        = 3+ctNum Blackhole  = 5+ctNum StackFrame = -1++closureB :: ByteString+closureB = BSC.pack "_CLOSURE"++closureNames :: Array ClosureType Ident+closureNames = listArray (minBound, maxBound) [ name $ mk_names n+                                              | n <- enumFromTo minBound maxBound+                                              ]+  where+    mk_names :: ClosureType -> FastString+    mk_names nm = mkFastStringByteString+                  $  hdB+                  <> BSC.pack (map toUpper (show nm))+                  <> closureB++-- | Convert 'ClosureType' to a String+ctJsName :: ClosureType -> String+ctJsName = \case+  Thunk      -> "CLOSURE_TYPE_THUNK"+  Fun        -> "CLOSURE_TYPE_FUN"+  Pap        -> "CLOSURE_TYPE_PAP"+  Con        -> "CLOSURE_TYPE_CON"+  Blackhole  -> "CLOSURE_TYPE_BLACKHOLE"+  StackFrame -> "CLOSURE_TYPE_STACKFRAME"++instance ToJExpr ClosureType where+  toJExpr e = toJExpr (ctNum e)+++-- | A thread is in one of 4 states+data ThreadStatus+  = Running   -- ^ The thread is running+  | Blocked   -- ^ The thread is blocked+  | Finished  -- ^ The thread is done+  | Died      -- ^ The thread has died+  deriving (Show, Eq, Ord, Enum, Bounded)++-- | Convert the status of a thread in JS land to an Int+threadStatusNum :: ThreadStatus -> Int+threadStatusNum = \case+  Running  -> 0+  Blocked  -> 1+  Finished -> 16+  Died     -> 17++-- | convert the status of a thread in JS land to a string+threadStatusJsName :: ThreadStatus -> String+threadStatusJsName = \case+  Running  -> "THREAD_RUNNING"+  Blocked  -> "THREAD_BLOCKED"+  Finished -> "THREAD_FINISHED"+  Died     -> "THREAD_DIED"
compiler/GHC/SysTools/Terminal.hs view
@@ -17,16 +17,6 @@  import System.IO.Unsafe -#if defined(mingw32_HOST_OS) && !defined(WINAPI)-# if defined(i386_HOST_ARCH)-#  define WINAPI stdcall-# elif defined(x86_64_HOST_ARCH)-#  define WINAPI ccall-# else-#  error unknown architecture-# endif-#endif- -- | Does the controlling terminal support ANSI color sequences? -- This memoized to avoid thread-safety issues in ncurses (see #17922). stderrSupportsAnsiColors :: Bool@@ -84,10 +74,10 @@ setConsoleMode h mode = do   Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) -foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode+foreign import ccall unsafe "windows.h GetConsoleMode" c_GetConsoleMode   :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL -foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode+foreign import ccall unsafe "windows.h SetConsoleMode" c_SetConsoleMode   :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL  #endif
compiler/GHC/Tc/Errors/Hole/FitTypes.hs view
@@ -1,13 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} module GHC.Tc.Errors.Hole.FitTypes (-  TypedHole (..), HoleFit (..), HoleFitCandidate (..),-  CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..),+  TypedHole (..), HoleFit (..), TcHoleFit(..), HoleFitCandidate (..),   hfIsLcl, pprHoleFitCand   ) where  import GHC.Prelude -import GHC.Tc.Types import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcType @@ -48,7 +46,7 @@ instance Eq HoleFitCandidate where   IdHFCand i1 == IdHFCand i2 = i1 == i2   NameHFCand n1 == NameHFCand n2 = n1 == n2-  GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2+  GreHFCand gre1 == GreHFCand gre2 = greName gre1 == greName gre2   _ == _ = False  instance Outputable HoleFitCandidate where@@ -63,11 +61,11 @@   getName hfc = case hfc of                      IdHFCand cid -> idName cid                      NameHFCand cname -> cname-                     GreHFCand cgre -> greMangledName cgre+                     GreHFCand cgre -> greName cgre   getOccName hfc = case hfc of                      IdHFCand cid -> occName cid                      NameHFCand cname -> occName cname-                     GreHFCand cgre -> occName (greMangledName cgre)+                     GreHFCand cgre -> occName $ greName cgre  instance HasOccName HoleFitCandidate where   occName = getOccName@@ -79,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.@@ -90,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@@ -109,42 +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 ---- | A plugin for modifying the candidate hole fits *before* they're checked.-type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]---- | A plugin for modifying hole fits  *after* they've been found.-type FitPlugin =  TypedHole -> [HoleFit] -> TcM [HoleFit]---- | A HoleFitPlugin is a pair of candidate and fit plugins.-data HoleFitPlugin = HoleFitPlugin-  { candPlugin :: CandPlugin-  , fitPlugin :: FitPlugin }---- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can--- track internal state. Note the existential quantification, ensuring that--- the state cannot be modified from outside the plugin.-data HoleFitPluginR = forall s. HoleFitPluginR-  { hfPluginInit :: TcM (TcRef s)-    -- ^ Initializes the TcRef to be passed to the plugin-  , hfPluginRun :: TcRef s -> HoleFitPlugin-    -- ^ The function defining the plugin itself-  , hfPluginStop :: TcRef s -> TcM ()-    -- ^ Cleanup of state, guaranteed to be called even on error-  }
− compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot 
@@ -1,30 +0,0 @@--- This boot file is in place to break the loop where:--- + GHC.Tc.Types needs 'HoleFitPlugin',--- + which needs 'GHC.Tc.Errors.Hole.FitTypes'--- + which needs 'GHC.Tc.Types'-module GHC.Tc.Errors.Hole.FitTypes where--import GHC.Base (Int, Maybe)-import GHC.Types.Var (Id)-import GHC.Types.Name (Name)-import GHC.Types.Name.Reader (GlobalRdrElt)-import GHC.Tc.Utils.TcType (TcType)-import GHC.Hs.Doc (HsDocString)-import GHC.Utils.Outputable (SDoc)--data HoleFitCandidate-  = IdHFCand Id-  | NameHFCand Name-  | GreHFCand GlobalRdrElt--data HoleFitPlugin-data HoleFit =-  HoleFit { hfId   :: Id-          , hfCand :: HoleFitCandidate-          , hfType :: TcType-          , hfRefLvl :: Int-          , hfWrap :: [TcType]-          , hfMatches :: [TcType]-          , hfDoc :: Maybe [HsDocString]-          }- | RawHoleFit SDoc
+ compiler/GHC/Tc/Errors/Hole/Plugin.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ExistentialQuantification #-}+module GHC.Tc.Errors.Hole.Plugin(CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..)) where++import GHC.Tc.Errors.Hole.FitTypes+import GHC.Tc.Types ( TcRef, TcM )+++-- | A plugin for modifying the candidate hole fits *before* they're checked.+type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]++-- | A plugin for modifying hole fits  *after* they've been found.+type FitPlugin =  TypedHole -> [HoleFit] -> TcM [HoleFit]++-- | A HoleFitPlugin is a pair of candidate and fit plugins.+data HoleFitPlugin = HoleFitPlugin+  { candPlugin :: CandPlugin+  , fitPlugin :: FitPlugin }++-- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can+-- track internal state. Note the existential quantification, ensuring that+-- the state cannot be modified from outside the plugin.+data HoleFitPluginR = forall s. HoleFitPluginR+  { hfPluginInit :: TcM (TcRef s)+    -- ^ Initializes the TcRef to be passed to the plugin+  , hfPluginRun :: TcRef s -> HoleFitPlugin+    -- ^ The function defining the plugin itself+  , hfPluginStop :: TcRef s -> TcM ()+    -- ^ Cleanup of state, guaranteed to be called even on error+  }
+ compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot view
@@ -0,0 +1,6 @@+module GHC.Tc.Errors.Hole.Plugin where++-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Base ()++data HoleFitPlugin
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -1,4123 +1,7551 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage-{-# LANGUAGE InstanceSigs #-}--module GHC.Tc.Errors.Ppr-  ( pprTypeDoesNotHaveFixedRuntimeRep-  , pprScopeError-  ---  , tidySkolemInfo-  , tidySkolemInfoAnon-  ---  , pprHsDocContext-  , inHsDocContext-  , TcRnMessageOpts(..)-  )-  where--import GHC.Prelude--import GHC.Builtin.Names-import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon )--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 (coAxiomTyCon, coAxiomSingleBranch)-import GHC.Core.ConLike-import GHC.Core.FamInstEnv ( famInstAxiom )-import GHC.Core.InstEnv-import GHC.Core.TyCo.Rep (Type(..))-import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,-                          pprSourceTyCon, pprTyVars, pprWithTYPE)-import GHC.Core.PatSyn ( patSynName, pprPatSynType )-import GHC.Core.Predicate-import GHC.Core.Type--import GHC.Driver.Flags-import GHC.Driver.Backend-import GHC.Hs--import GHC.Tc.Errors.Types-import GHC.Tc.Types.Constraint-import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )-import GHC.Tc.Types.Origin-import GHC.Tc.Types.Rank (Rank(..))-import GHC.Tc.Utils.TcType--import GHC.Types.Error-import GHC.Types.FieldLabel (flIsOverloaded)-import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol)-import GHC.Types.Hint.Ppr () -- Outputable GhcHint-import GHC.Types.Basic-import GHC.Types.Error.Codes ( constructorCode )-import GHC.Types.Id-import GHC.Types.Name-import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance-                             , RdrName, rdrNameOcc, greMangledName )-import GHC.Types.Name.Set-import GHC.Types.SrcLoc-import GHC.Types.TyThing-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env--import GHC.Unit.State (pprWithUnitState, UnitState)-import GHC.Unit.Module-import GHC.Unit.Module.Warnings  ( pprWarningTxtForMsg )--import GHC.Data.Bag-import GHC.Data.FastString-import GHC.Data.List.SetOps ( nubOrdBy )-import GHC.Data.Maybe-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.Function (on)-import Data.List ( groupBy, sortBy, tails-                 , partition, unfoldr )-import Data.Ord ( comparing )-import Data.Bifunctor-import GHC.Types.Name.Env-import qualified Language.Haskell.TH as TH--data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not-                                       }--defaultTcRnMessageOpts :: TcRnMessageOpts-defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True }---instance Diagnostic TcRnMessage where-  type DiagnosticOpts TcRnMessage = TcRnMessageOpts-  defaultDiagnosticOpts = defaultTcRnMessageOpts-  diagnosticMessage opts = \case-    TcRnUnknownMessage (UnknownDiagnostic @e m)-      -> diagnosticMessage (defaultDiagnosticOpts @e) 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-      -> if tcOptsShowContext opts-         then main_msg `unionDecoratedSDoc` ctxt_msg-         else main_msg-      where-        main_msg = diagnosticMessage opts msg-        ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt)-    TcRnSolverReport msg _ _-      -> mkSimpleDecorated $ pprSolverReportWithCtxt msg-    TcRnRedundantConstraints redundants (info, show_info)-      -> mkSimpleDecorated $-         text "Redundant constraint" <> plural redundants <> colon-           <+> pprEvVarTheta redundants-         $$ if show_info then text "In" <+> ppr info else empty-    TcRnInaccessibleCode implic contra-      -> mkSimpleDecorated $-         hang (text "Inaccessible code in")-           2 (ppr (ic_info implic))-         $$ pprSolverReportWithCtxt contra-    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 name-      -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)]-    TcRnDodgyExports name-      -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)]-    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)]-    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-      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"-          | otherwise-          = text "Wildcard"-        how = case bad of-          WildcardNotLastInConstraint-            -> text "not allowed in a constraint"-          _ -> 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)") ]-    TcRnDuplicateFieldName fld_part dups-      -> mkSimpleDecorated $-           hsep [text "duplicate field name",-                 quotes (ppr (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 "The constructor has no labelled fields") ]-    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"-    TcRnIllegalHsBootFileDecl-      -> mkSimpleDecorated $-           text "Illegal declarations in an hs-boot file"-    TcRnRecursivePatternSynonym binds-      -> mkSimpleDecorated $-            hang (text "Recursive pattern synonym definition with following bindings:")-               2 (vcat $ map pprLBind . bagToList $ binds)-          where-            pprLoc loc = parens (text "defined at" <+> ppr loc)-            pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' 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"-    TcRnAbstractClassInst clas-      -> mkSimpleDecorated $-           text "Cannot define instance for abstract class" <+>-           quotes (ppr (className clas))-    TcRnNoClassInstHead tau-      -> mkSimpleDecorated $-           hang (text "Instance head is not headed by a class:") 2 (pprType tau)-    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)) ]-    TcRnVDQInTermType mb_ty-      -> mkSimpleDecorated $ vcat-           [ case mb_ty of-               Nothing -> main_msg-               Just ty -> hang (main_msg <> char ':') 2 (pprType ty)-           , text "(GHC does not yet support this)" ]-      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)-    TcRnIllegalClassInst tcf-      -> mkSimpleDecorated $-           vcat [ text "Illegal instance for a" <+> ppr tcf-                , text "A class instance must be for a class" ]-    TcRnOversaturatedVisibleKindArg ty-      -> mkSimpleDecorated $-           text "Illegal oversaturated visible kind argument:" <+>-           quotes (char '@' <> pprParendType ty)-    TcRnBadAssociatedType clas tc-      -> mkSimpleDecorated $-           hsep [ text "Class", quotes (ppr clas)-                , text "does not have an associated type", quotes (ppr tc) ]-    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 inst-      -> mkSimpleDecorated $-           hsep [ text "Orphan instance:"-                , pprInstanceHdr 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 $ pprWithExplicitKindsWhen 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 dup_things-      -> mkSimpleDecorated $-           hang (text "Multiple default declarations")-              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) (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"-    TcRnDuplicateExport child ie1 ie2-      -> mkSimpleDecorated $-           hsep [ quotes (ppr child)-                , 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 child-        parents = map ppr parent_names-    TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2-      -> mkSimpleDecorated $-           vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon-                , ppr_export child1 gre1 ie1-                , ppr_export child2 gre2 ie2-                ]-      where-        ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>-                                                quotes (ppr_name child))-                                            2 (pprNameProvenance gre))--        -- DuplicateRecordFields means that nameOccName might be a-        -- mangled $sel-prefixed thing, in which case show the correct OccName-        -- alone (but otherwise show the Name so it will have a module-        -- qualifier)-        ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl-                                   | otherwise         = ppr (flSelector fl)-        ppr_name (NormalGreName name) = ppr name-    TcRnAmbiguousField rupd parent_type-      -> mkSimpleDecorated $-          vcat [ text "The record update" <+> ppr rupd-                   <+> text "with type" <+> ppr parent_type-                   <+> text "is ambiguous."-               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."-               ]-    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 ])-    TcRnNoConstructorHasAllFields conflictingFields-      -> mkSimpleDecorated $-           hang (text "No constructor has all these fields:")-              2 (pprQuotedList conflictingFields)-    TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels-      -> mkSimpleDecorated $-           text "Cannot use a mixture of pattern synonym and record selectors" $$-           text "Record selectors defined by"-             <+> quotes (ppr data_name)-             <> colon-             <+> pprWithCommas ppr data_sels $$-           text "Pattern synonym selectors defined by"-             <+> quotes (ppr pat_name)-             <> colon-             <+> pprWithCommas ppr pat_syn_sels-    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-    TcRnNoPossibleParentForFields rbinds-      -> mkSimpleDecorated $-           hang (text "No type has all these fields:")-              2 (pprQuotedList fields)-         where fields = map (hfbLHS . unLoc) rbinds-    TcRnBadOverloadedRecordUpdate _rbinds-      -> mkSimpleDecorated $-           text "Record update is ambiguous, and requires a type signature"-    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 ct-      -> mkSimpleDecorated $-           quotes (ppr ct)-           <+> text "is not a unary constraint, as expected by a deriving clause"-    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-    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"--    TcRnSpecialClassInst cls because_safeHaskell-      -> mkSimpleDecorated $-            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-    TcRnForallIdentifier rdr_name-      -> mkSimpleDecorated $-            fsep [ text "The use of" <+> quotes (ppr rdr_name)-                                     <+> text "as an identifier",-                   text "will become an error in a future GHC release." ]-    TcRnTypeEqualityOutOfScope-      -> mkDecorated-           [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$-             text "Assuming it to stand for an equality constraint."-           , text "NB:" <+> (quotes (text "~") <+> text "used to be built-in syntax but now is a regular type operator" $$-                             text "exported from Data.Type.Equality and Prelude.") $$-             text "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 $ msg-        where-          msg-            -- We are in a type-level namespace,-            -- and the name is incorrectly at the term-level.-            | isValNameSpace ns-            = text "The" <+> what <+> text "does not live in the type-level namespace"--            -- We are in a term-level namespace,-            -- and the name is incorrectly at the type-level.-            | otherwise-            = text "Illegal term-level use of the" <+> what-          ns = nameNameSpace name-          what = pprNameSpace ns <+> quotes (ppr name)-    TcRnNotInScope err name imp_errs _-      -> mkSimpleDecorated $-           pprScopeError name err $$ vcat (map ppr imp_errs)-    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)---    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 Nothing ->-                  hang innerMsg 2 $ text "because its data constructor is not in scope"-                NewtypeDataConNotInScope (Just 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"-    TcRnNotARecordSelector field-      -> mkSimpleDecorated $-           hsep [quotes (ppr field), text "is not a record selector"]-    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"-    TcRnSplicePolymorphicLocalVar ident-      -> mkSimpleDecorated $-           text "Can't splice the polymorphic local variable" <+> quotes (ppr ident)-    TcRnIllegalDerivingItem hs_ty-      -> mkSimpleDecorated $-           text "Illegal deriving item" <+> quotes (ppr hs_ty)-    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 cannot appear nested inside a type"-    TcRnIllegalRecordSyntax ty-      -> mkSimpleDecorated $-           text "Record syntax is illegal here:" <+> ppr ty-    TcRnUnexpectedTypeSplice ty-      -> mkSimpleDecorated $-           text "Unexpected type splice:" <+> 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 pred-                                    -> text "it has an unpromotable context"-                                       <+> quotes (ppr pred)-                     FamDataConPE   -> text "it comes from a data family instance"-                     NoDataKindsDC  -> text "perhaps you intended to use DataKinds"-                     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"-          same_rec_group_msg = text "it is defined and used in the same recursive group"-    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"-    TcRnNameByTemplateHaskellQuote name -> mkSimpleDecorated $-      text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name-    TcRnIllegalBindingOfBuiltIn name -> mkSimpleDecorated $-       text "Illegal binding of built-in syntax:" <+> ppr name-    TcRnPragmaWarning {pragma_warning_occ, pragma_warning_msg, pragma_warning_import_mod, pragma_warning_defined_mod}-      -> mkSimpleDecorated $-        sep [ sep [ text "In the use of"-                <+> pprNonVarNameSpace (occNameSpace pragma_warning_occ)-                <+> quotes (ppr pragma_warning_occ)-                , parens impMsg <> colon ]-          , pprWarningTxtForMsg pragma_warning_msg ]-          where-            impMsg  = text "imported from" <+> ppr pragma_warning_import_mod <> extra-            extra | pragma_warning_import_mod == pragma_warning_defined_mod = empty-                  | otherwise = text ", but defined in" <+> ppr pragma_warning_defined_mod-    TcRnIllegalHsigDefaultMethods name meths-      -> mkSimpleDecorated $-        text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file"-    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)]-    TcRnNoExplicitAssocTypeOrDefaultDeclaration name-      -> mkSimpleDecorated $-        text "No explicit" <+> text "associated type"-          <+> text "or default declaration for"-          <+> quotes (ppr name)-    TcRnIllegalTypeData-      -> mkSimpleDecorated $-        text "Illegal type-level data declaration"-    TcRnTypeDataForbids feature-      -> mkSimpleDecorated $-        ppr feature <+> text "are not allowed in type data declarations."--    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 <+> pprWithExplicitKindsWhen 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--    TcRnTypedTHWithPolyType ty-      -> mkSimpleDecorated $-        vcat [ text "Illegal polytype:" <+> ppr ty-             , text "The type of a Typed Template Haskell expression must" <+>-               text "not have any quantification." ]-    TcRnSpliceThrewException 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"-    TcRnInvalidTopDecl _decl-      -> mkSimpleDecorated $-         text "Only function, value, annotation, and foreign import declarations may be added with addTopDecls"-    TcRnNonExactName 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.")-    TcRnAddInvalidCorePlugin plugin-      -> mkSimpleDecorated $-         hang-           (text "addCorePlugin: invalid plugin module "-              <+> text (show plugin)-           )-           2-           (text "Plugins in the current package can't be specified.")-    TcRnAddDocToNonLocalDefn doc_loc-      -> mkSimpleDecorated $-         text "Can't add documentation to" <+> ppr_loc doc_loc <+>-         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"--    TcRnFailedToLookupThInstName 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"-    TcRnCannotReifyInstance ty-      -> mkSimpleDecorated $-         hang (text "reifyInstances:" <+> quotes (ppr ty))-            2 (text "is not a class constraint or type family application")-    TcRnCannotReifyOutOfScopeThing 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-    TcRnCannotReifyThingNotInTypeEnv name-      -> mkSimpleDecorated $-         quotes (ppr name) <+> text "is not in the type environment at a reify"-    TcRnNoRolesAssociatedWithThing thing-      -> mkSimpleDecorated $-         text "No roles associated with" <+> (ppr thing)-    TcRnCannotRepresentType 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"-    TcRnRunSpliceFailure mCallingFnName (ConversionFail what reason)-      -> mkSimpleDecorated-           . addCallingFn-           . addSpliceInfo-           $ pprConversionFailReason reason-      where-        addCallingFn rest =-          case mCallingFnName of-            Nothing -> rest-            Just callingFn ->-              hang (text ("Error in a declaration passed to " ++ callingFn ++ ":"))-                 2 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))-    TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg-    TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc-    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))-             ]-    TcRnBadBootFamInstDecl {}-      -> mkSimpleDecorated $-        text "Illegal family instance in hs-boot file"-    TcRnIllegalFamilyInstance tycon-      -> mkSimpleDecorated $-        vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)-             , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]-    TcRnMissingClassAssoc name-      -> mkSimpleDecorated $-        text "Associated type" <+> quotes (ppr name) <+>-        text "must be inside a class instance"-    TcRnBadFamInstDecl tc_name-      -> mkSimpleDecorated $-        text "Illegal family instance for" <+> quotes (ppr tc_name)-    TcRnNotOpenFamily tc-      -> mkSimpleDecorated $-        text "Illegal instance for closed family" <+> quotes (ppr tc)-    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-    TcRnIllegalStaticFormInSplice e -> mkSimpleDecorated $-      sep [ text "static forms cannot be used in splices:"-          , nest 2 $ 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)))--    TcRnLoopySuperclassSolve wtd_loc wtd_pty ->-      mkSimpleDecorated $ vcat [ header, warning, user_manual ]-      where-        header, warning, user_manual :: SDoc-        header-          = vcat [ text "I am solving the constraint" <+> quotes (ppr wtd_pty) <> comma-                 , nest 2 $ pprCtOrigin (ctLocOrigin wtd_loc) <> comma-                 , text "in a way that might turn out to loop at runtime." ]-        warning-          = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ]-        user_manual =-          vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ]-    TcRnCannotDefaultConcrete frr-      -> mkSimpleDecorated $-         ppr (frr_context frr) $$-         text "cannot be assigned a fixed runtime representation," <+>-         text "not even by defaulting."--  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-    TcRnRedundantConstraints {}-      -> WarningWithFlag Opt_WarnRedundantConstraints-    TcRnInaccessibleCode {}-      -> 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-    TcRnDuplicateWarningDecls{}-      -> ErrorWithoutFlag-    TcRnSimplifierTooManyIterations{}-      -> ErrorWithoutFlag-    TcRnIllegalPatSynDecl{}-      -> ErrorWithoutFlag-    TcRnLinearPatSyn{}-      -> ErrorWithoutFlag-    TcRnEmptyRecordUpdate-      -> ErrorWithoutFlag-    TcRnIllegalFieldPunning{}-      -> ErrorWithoutFlag-    TcRnIllegalWildcardsInRecord{}-      -> ErrorWithoutFlag-    TcRnIllegalWildcardInType{}-      -> 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-    TcRnIllegalHsBootFileDecl-      -> ErrorWithoutFlag-    TcRnRecursivePatternSynonym{}-      -> ErrorWithoutFlag-    TcRnPartialTypeSigTyVarMismatch{}-      -> ErrorWithoutFlag-    TcRnPartialTypeSigBadQuantifier{}-      -> ErrorWithoutFlag-    TcRnMissingSignature what exported overridden-      -> WarningWithFlag $ missingSignatureWarningFlag what exported overridden-    TcRnPolymorphicBinderMissingSig{}-      -> WarningWithFlag Opt_WarnMissingLocalSignatures-    TcRnOverloadedSig{}-      -> ErrorWithoutFlag-    TcRnTupleConstraintInst{}-      -> ErrorWithoutFlag-    TcRnAbstractClassInst{}-      -> ErrorWithoutFlag-    TcRnNoClassInstHead{}-      -> ErrorWithoutFlag-    TcRnUserTypeError{}-      -> ErrorWithoutFlag-    TcRnConstraintInKind{}-      -> ErrorWithoutFlag-    TcRnUnboxedTupleOrSumTypeFuncArg{}-      -> ErrorWithoutFlag-    TcRnLinearFuncInKind{}-      -> ErrorWithoutFlag-    TcRnForAllEscapeError{}-      -> ErrorWithoutFlag-    TcRnVDQInTermType{}-      -> ErrorWithoutFlag-    TcRnBadQuantPredHead{}-      -> ErrorWithoutFlag-    TcRnIllegalTupleConstraint{}-      -> ErrorWithoutFlag-    TcRnNonTypeVarArgInConstraint{}-      -> ErrorWithoutFlag-    TcRnIllegalImplicitParam{}-      -> ErrorWithoutFlag-    TcRnIllegalConstraintSynonymOfKind{}-      -> ErrorWithoutFlag-    TcRnIllegalClassInst{}-      -> ErrorWithoutFlag-    TcRnOversaturatedVisibleKindArg{}-      -> ErrorWithoutFlag-    TcRnBadAssociatedType{}-      -> 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-    TcRnDuplicateExport{}-      -> WarningWithFlag Opt_WarnDuplicateExports-    TcRnExportedParentChildMismatch{}-      -> ErrorWithoutFlag-    TcRnConflictingExports{}-      -> ErrorWithoutFlag-    TcRnAmbiguousField{}-      -> WarningWithFlag Opt_WarnAmbiguousFields-    TcRnMissingFields{}-      -> WarningWithFlag Opt_WarnMissingFields-    TcRnFieldUpdateInvalidType{}-      -> ErrorWithoutFlag-    TcRnNoConstructorHasAllFields{}-      -> ErrorWithoutFlag-    TcRnMixedSelectors{}-      -> ErrorWithoutFlag-    TcRnMissingStrictFields{}-      -> ErrorWithoutFlag-    TcRnNoPossibleParentForFields{}-      -> ErrorWithoutFlag-    TcRnBadOverloadedRecordUpdate{}-      -> 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-    TcRnLazyGADTPattern-      -> ErrorWithoutFlag-    TcRnArrowProcGADTPattern-      -> ErrorWithoutFlag-    TcRnSpecialClassInst {}-      -> ErrorWithoutFlag-    TcRnForallIdentifier {}-      -> WarningWithFlag Opt_WarnForallIdentifier-    TcRnTypeEqualityOutOfScope-      -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope-    TcRnTypeEqualityRequiresOperators-      -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators-    TcRnIllegalTypeOperator {}-      -> ErrorWithoutFlag-    TcRnIllegalTypeOperatorDecl {}-      -> ErrorWithoutFlag-    TcRnGADTMonoLocalBinds {}-      -> WarningWithFlag Opt_WarnGADTMonoLocalBinds-    TcRnIncorrectNameSpace {}-      -> ErrorWithoutFlag-    TcRnNotInScope {}-      -> ErrorWithoutFlag-    TcRnUntickedPromotedThing {}-      -> WarningWithFlag Opt_WarnUntickedPromotedConstructors-    TcRnIllegalBuiltinSyntax {}-      -> ErrorWithoutFlag-    TcRnWarnDefaulting {}-      -> 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-    TcRnNotARecordSelector{}-      -> ErrorWithoutFlag-    TcRnRecSelectorEscapedTyVar{}-      -> ErrorWithoutFlag-    TcRnPatSynNotBidirectional{}-      -> ErrorWithoutFlag-    TcRnSplicePolymorphicLocalVar{}-      -> ErrorWithoutFlag-    TcRnIllegalDerivingItem{}-      -> ErrorWithoutFlag-    TcRnUnexpectedAnnotation{}-      -> ErrorWithoutFlag-    TcRnIllegalRecordSyntax{}-      -> ErrorWithoutFlag-    TcRnUnexpectedTypeSplice{}-      -> ErrorWithoutFlag-    TcRnInvalidVisibleKindArgument{}-      -> ErrorWithoutFlag-    TcRnTooManyBinders{}-      -> ErrorWithoutFlag-    TcRnDifferentNamesForTyVar{}-      -> ErrorWithoutFlag-    TcRnDisconnectedTyVar{}-      -> ErrorWithoutFlag-    TcRnInvalidReturnKind{}-      -> ErrorWithoutFlag-    TcRnClassKindNotConstraint{}-      -> ErrorWithoutFlag-    TcRnUnpromotableThing{}-      -> ErrorWithoutFlag-    TcRnMatchesHaveDiffNumArgs{}-      -> ErrorWithoutFlag-    TcRnCannotBindScopedTyVarInPatSig{}-      -> ErrorWithoutFlag-    TcRnCannotBindTyVarsInPatBind{}-      -> ErrorWithoutFlag-    TcRnTooManyTyArgsInConPattern{}-      -> ErrorWithoutFlag-    TcRnMultipleInlinePragmas{}-      -> WarningWithoutFlag-    TcRnUnexpectedPragmas{}-      -> WarningWithoutFlag-    TcRnNonOverloadedSpecialisePragma{}-      -> WarningWithoutFlag-    TcRnSpecialiseNotVisible{}-      -> WarningWithoutFlag-    TcRnNameByTemplateHaskellQuote{}-      -> ErrorWithoutFlag-    TcRnIllegalBindingOfBuiltIn{}-      -> ErrorWithoutFlag-    TcRnPragmaWarning{}-      -> WarningWithFlag Opt_WarnWarningsDeprecations-    TcRnIllegalHsigDefaultMethods{}-      -> ErrorWithoutFlag-    TcRnBadGenericMethod{}-      -> ErrorWithoutFlag-    TcRnWarningMinimalDefIncomplete{}-      -> WarningWithoutFlag-    TcRnDefaultMethodForPragmaLacksBinding{}-      -> ErrorWithoutFlag-    TcRnIgnoreSpecialisePragmaOnDefMethod{}-      -> WarningWithoutFlag-    TcRnBadMethodErr{}-      -> ErrorWithoutFlag-    TcRnNoExplicitAssocTypeOrDefaultDeclaration{}-      -> WarningWithFlag (Opt_WarnMissingMethods)-    TcRnIllegalTypeData-      -> ErrorWithoutFlag-    TcRnTypeDataForbids{}-      -> ErrorWithoutFlag-    TcRnIllegalNewtype{}-      -> ErrorWithoutFlag-    TcRnTypedTHWithPolyType{}-      -> ErrorWithoutFlag-    TcRnSpliceThrewException{}-      -> ErrorWithoutFlag-    TcRnInvalidTopDecl{}-      -> ErrorWithoutFlag-    TcRnNonExactName{}-      -> ErrorWithoutFlag-    TcRnAddInvalidCorePlugin{}-      -> ErrorWithoutFlag-    TcRnAddDocToNonLocalDefn{}-      -> ErrorWithoutFlag-    TcRnFailedToLookupThInstName{}-      -> ErrorWithoutFlag-    TcRnCannotReifyInstance{}-      -> ErrorWithoutFlag-    TcRnCannotReifyOutOfScopeThing{}-      -> ErrorWithoutFlag-    TcRnCannotReifyThingNotInTypeEnv{}-      -> ErrorWithoutFlag-    TcRnNoRolesAssociatedWithThing{}-      -> ErrorWithoutFlag-    TcRnCannotRepresentType{}-      -> ErrorWithoutFlag-    TcRnRunSpliceFailure{}-      -> ErrorWithoutFlag-    TcRnReportCustomQuasiError isError _-      -> if isError then ErrorWithoutFlag else WarningWithoutFlag-    TcRnInterfaceLookupError{}-      -> ErrorWithoutFlag-    TcRnUnsatisfiedMinimalDef{}-      -> WarningWithFlag (Opt_WarnMissingMethods)-    TcRnMisplacedInstSig{}-      -> ErrorWithoutFlag-    TcRnBadBootFamInstDecl{}-      -> ErrorWithoutFlag-    TcRnIllegalFamilyInstance{}-      -> ErrorWithoutFlag-    TcRnMissingClassAssoc{}-      -> ErrorWithoutFlag-    TcRnBadFamInstDecl{}-      -> ErrorWithoutFlag-    TcRnNotOpenFamily{}-      -> ErrorWithoutFlag-    TcRnNoRebindableSyntaxRecordDot{}-      -> ErrorWithoutFlag-    TcRnNoFieldPunsRecordDot{}-      -> ErrorWithoutFlag-    TcRnIllegalStaticExpression{}-      -> ErrorWithoutFlag-    TcRnIllegalStaticFormInSplice{}-      -> ErrorWithoutFlag-    TcRnListComprehensionDuplicateBinding{}-      -> ErrorWithoutFlag-    TcRnEmptyStmtsGroup{}-      -> ErrorWithoutFlag-    TcRnLastStmtNotExpr{}-      -> ErrorWithoutFlag-    TcRnUnexpectedStatementInContext{}-      -> ErrorWithoutFlag-    TcRnSectionWithoutParentheses{}-      -> ErrorWithoutFlag-    TcRnIllegalImplicitParameterBindings{}-      -> ErrorWithoutFlag-    TcRnIllegalTupleSection{}-      -> ErrorWithoutFlag-    TcRnLoopySuperclassSolve{}-      -> WarningWithFlag Opt_WarnLoopySuperclassSolve-    TcRnCannotDefaultConcrete{}-      -> 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 _ _ hints-      -> hints-    TcRnRedundantConstraints{}-      -> noHints-    TcRnInaccessibleCode{}-      -> 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-    TcRnDuplicateWarningDecls{}-      -> noHints-    TcRnSimplifierTooManyIterations{}-      -> [SuggestIncreaseSimplifierIterations]-    TcRnIllegalPatSynDecl{}-      -> noHints-    TcRnLinearPatSyn{}-      -> noHints-    TcRnEmptyRecordUpdate{}-      -> noHints-    TcRnIllegalFieldPunning{}-      -> [suggestExtension LangExt.NamedFieldPuns]-    TcRnIllegalWildcardsInRecord{}-      -> [suggestExtension LangExt.RecordWildCards]-    TcRnIllegalWildcardInType{}-      -> noHints-    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-    TcRnIllegalHsBootFileDecl-      -> noHints-    TcRnRecursivePatternSynonym{}-      -> noHints-    TcRnPartialTypeSigTyVarMismatch{}-      -> noHints-    TcRnPartialTypeSigBadQuantifier{}-      -> noHints-    TcRnMissingSignature {}-      -> noHints-    TcRnPolymorphicBinderMissingSig{}-      -> noHints-    TcRnOverloadedSig{}-      -> noHints-    TcRnTupleConstraintInst{}-      -> noHints-    TcRnAbstractClassInst{}-      -> noHints-    TcRnNoClassInstHead{}-      -> noHints-    TcRnUserTypeError{}-      -> noHints-    TcRnConstraintInKind{}-      -> noHints-    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _-      -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum]-    TcRnLinearFuncInKind{}-      -> noHints-    TcRnForAllEscapeError{}-      -> noHints-    TcRnVDQInTermType{}-      -> noHints-    TcRnBadQuantPredHead{}-      -> noHints-    TcRnIllegalTupleConstraint{}-      -> [suggestExtension LangExt.ConstraintKinds]-    TcRnNonTypeVarArgInConstraint{}-      -> [suggestExtension LangExt.FlexibleContexts]-    TcRnIllegalImplicitParam{}-      -> noHints-    TcRnIllegalConstraintSynonymOfKind{}-      -> [suggestExtension LangExt.ConstraintKinds]-    TcRnIllegalClassInst{}-      -> noHints-    TcRnOversaturatedVisibleKindArg{}-      -> noHints-    TcRnBadAssociatedType{}-      -> 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-    TcRnMonomorphicBindings bindings-      -> case bindings of-          []     -> noHints-          (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]-    TcRnOrphanInstance{}-      -> [SuggestFixOrphanInstance]-    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-    TcRnDuplicateExport{}-      -> noHints-    TcRnExportedParentChildMismatch{}-      -> noHints-    TcRnConflictingExports{}-      -> noHints-    TcRnAmbiguousField{}-      -> noHints-    TcRnMissingFields{}-      -> noHints-    TcRnFieldUpdateInvalidType{}-      -> noHints-    TcRnNoConstructorHasAllFields{}-      -> noHints-    TcRnMixedSelectors{}-      -> noHints-    TcRnMissingStrictFields{}-      -> noHints-    TcRnNoPossibleParentForFields{}-      -> noHints-    TcRnBadOverloadedRecordUpdate{}-      -> noHints-    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-    TcRnLazyGADTPattern-      -> noHints-    TcRnArrowProcGADTPattern-      -> noHints-    TcRnSpecialClassInst {}-      -> noHints-    TcRnForallIdentifier {}-      -> [SuggestRenameForall]-    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-    TcRnUntickedPromotedThing thing-      -> [SuggestAddTick thing]-    TcRnIllegalBuiltinSyntax {}-      -> noHints-    TcRnWarnDefaulting {}-      -> noHints-    TcRnForeignImportPrimExtNotSet{}-      -> [suggestExtension LangExt.GHCForeignImportPrim]-    TcRnForeignImportPrimSafeAnn{}-      -> noHints-    TcRnForeignFunctionImportAsValue{}-      -> noHints-    TcRnFunPtrImportWithoutAmpersand{}-      -> noHints-    TcRnIllegalForeignDeclBackend{}-      -> noHints-    TcRnUnsupportedCallConv{}-      -> noHints-    TcRnIllegalForeignType _ reason-      -> case reason of-           TypeCannotBeMarshaled _ why-             | NewtypeDataConNotInScope{} <- why -> [SuggestImportingDataCon]-             | UnliftedFFITypesNeeded <- why -> [suggestExtension LangExt.UnliftedFFITypes]-           _ -> noHints-    TcRnInvalidCIdentifier{}-      -> noHints-    TcRnExpectedValueId{}-      -> noHints-    TcRnNotARecordSelector{}-      -> noHints-    TcRnRecSelectorEscapedTyVar{}-      -> [SuggestPatternMatchingSyntax]-    TcRnPatSynNotBidirectional{}-      -> noHints-    TcRnSplicePolymorphicLocalVar{}-      -> noHints-    TcRnIllegalDerivingItem{}-      -> noHints-    TcRnUnexpectedAnnotation{}-      -> noHints-    TcRnIllegalRecordSyntax{}-      -> noHints-    TcRnUnexpectedTypeSplice{}-      -> 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-    TcRnMatchesHaveDiffNumArgs{}-      -> noHints-    TcRnCannotBindScopedTyVarInPatSig{}-      -> noHints-    TcRnCannotBindTyVarsInPatBind{}-      -> noHints-    TcRnTooManyTyArgsInConPattern{}-      -> noHints-    TcRnMultipleInlinePragmas{}-      -> noHints-    TcRnUnexpectedPragmas{}-      -> noHints-    TcRnNonOverloadedSpecialisePragma{}-      -> noHints-    TcRnSpecialiseNotVisible name-      -> [SuggestSpecialiseVisibilityHints name]-    TcRnNameByTemplateHaskellQuote{}-      -> noHints-    TcRnIllegalBindingOfBuiltIn{}-      -> noHints-    TcRnPragmaWarning{}-      -> noHints-    TcRnIllegalHsigDefaultMethods{}-      -> noHints-    TcRnBadGenericMethod{}-      -> noHints-    TcRnWarningMinimalDefIncomplete{}-      -> noHints-    TcRnDefaultMethodForPragmaLacksBinding{}-      -> noHints-    TcRnIgnoreSpecialisePragmaOnDefMethod{}-      -> noHints-    TcRnBadMethodErr{}-      -> noHints-    TcRnNoExplicitAssocTypeOrDefaultDeclaration{}-      -> noHints-    TcRnIllegalTypeData-      -> [suggestExtension LangExt.TypeData]-    TcRnTypeDataForbids{}-      -> noHints-    TcRnIllegalNewtype{}-      -> noHints-    TcRnTypedTHWithPolyType{}-      -> noHints-    TcRnSpliceThrewException{}-      -> noHints-    TcRnInvalidTopDecl{}-      -> noHints-    TcRnNonExactName{}-      -> noHints-    TcRnAddInvalidCorePlugin{}-      -> noHints-    TcRnAddDocToNonLocalDefn{}-      -> noHints-    TcRnFailedToLookupThInstName{}-      -> noHints-    TcRnCannotReifyInstance{}-      -> noHints-    TcRnCannotReifyOutOfScopeThing{}-      -> noHints-    TcRnCannotReifyThingNotInTypeEnv{}-      -> noHints-    TcRnNoRolesAssociatedWithThing{}-      -> noHints-    TcRnCannotRepresentType{}-      -> noHints-    TcRnRunSpliceFailure{}-      -> noHints-    TcRnReportCustomQuasiError{}-      -> noHints-    TcRnInterfaceLookupError{}-      -> noHints-    TcRnUnsatisfiedMinimalDef{}-      -> noHints-    TcRnMisplacedInstSig{}-      -> [suggestExtension LangExt.InstanceSigs]-    TcRnBadBootFamInstDecl{}-      -> noHints-    TcRnIllegalFamilyInstance{}-      -> noHints-    TcRnMissingClassAssoc{}-      -> noHints-    TcRnBadFamInstDecl{}-      -> [suggestExtension LangExt.TypeFamilies]-    TcRnNotOpenFamily{}-      -> noHints-    TcRnNoRebindableSyntaxRecordDot{}-      -> noHints-    TcRnNoFieldPunsRecordDot{}-      -> noHints-    TcRnIllegalStaticExpression{}-      -> [suggestExtension LangExt.StaticPointers]-    TcRnIllegalStaticFormInSplice{}-      -> 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]-    TcRnLoopySuperclassSolve wtd_loc wtd_pty-      -> [LoopySuperclassSolveHint wtd_pty cls_or_qc]-      where-        cls_or_qc :: ClsInstOrQC-        cls_or_qc = case ctLocOrigin wtd_loc of-          ScOrigin c_or_q _ -> c_or_q-          _                 -> IsClsInst -- shouldn't happen-    TcRnCannotDefaultConcrete{}-      -> [SuggestAddTypeSignatures UnnamedBinding]--  diagnosticCode = constructorCode---- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z",--- and so on.  The `and` stands for any `conjunction`, which is passed in.-commafyWith :: SDoc -> [SDoc] -> [SDoc]-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'--dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc-dodgy_msg kind tc ie-  = sep [ text "The" <+> kind <+> text "item"-                     <+> quotes (ppr ie)-                <+> text "suggests that",-          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",-          text "but it has none" ]--dodgy_msg_insert :: forall p . (Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) => IdP (GhcPass p) -> IE (GhcPass p)-dodgy_msg_insert tc = IEThingAll noAnn ii-  where-    ii :: LIEWrappedName (GhcPass p)-    ii = noLocA (IEName noExtField $ noLocA tc)--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) = tidyOpenType 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-  RecordFieldConstructor{} -> text "construction"-  RecordFieldPattern{}     -> text "pattern"-  RecordFieldUpdate        -> text "update"--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 flag is associated with the given missing signature?-missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag-missingSignatureWarningFlag (MissingTopLevelBindingSig {}) exported overridden-  | IsExported <- exported-  , not overridden-  = Opt_WarnMissingExportedSignatures-  | otherwise-  = Opt_WarnMissingSignatures-missingSignatureWarningFlag (MissingPatSynSig {}) exported overridden-  | IsExported <- exported-  , not overridden-  = Opt_WarnMissingExportedPatternSynonymSignatures-  | otherwise-  = Opt_WarnMissingPatternSynonymSignatures-missingSignatureWarningFlag (MissingTyConKindSig {}) _ _-  = Opt_WarnMissingKindSignatures--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)--{- *********************************************************************-*                                                                      *-              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 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 })-  = hang (pprMismatchMsg ctxt mismatch_msg)-     2 (vcat ( maybe empty (pprTyVarInfo ctxt) tv_info-             : maybe empty pprCoercibleMsg coercible_info-             : map pprAmbiguityInfo ambig_infos ))-pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =-  vcat (map make_msg frr_origs)-  where-    -- 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.-          -> isConcrete (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 it 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 _ (UntouchableVariable tv implic)-  | Implic { ic_given = given, ic_info = skol_info } <- implic-  = 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 (getLclEnvLoc (ic_env implic)) ]-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 (getLclEnvLoc (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 (getLclEnvLoc (ic_env implic)) ] ]-  where-    what = text $ levelString $-           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel--pprCannotUnifyVariableReason ctxt-  (OccursCheck-    { occursCheckInterestingTyVars = interesting_tvs-    , occursCheckAmbiguityInfos    = ambig_infos })-  = ppr_interesting_tyVars interesting_tvs-  $$ vcat (map pprAmbiguityInfo ambig_infos)-  where-    ppr_interesting_tyVars [] = empty-    ppr_interesting_tyVars (tv:tvs) =-      hang (text "Type variable kinds:") 2 $-      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))-                (tv:tvs))-    tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)-pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info)-  = pprTyVarInfo ctxt tv_info-pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg)-  = pprTyVarInfo ctxt tv_info-  $$ maybe empty pprCoercibleMsg mb_coercible_msg--pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc-pprMismatchMsg ctxt-  (BasicMismatch { mismatch_ea   = ea-                 , mismatch_item = item-                 , mismatch_ty1  = ty1  -- 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_ppr_explicit_kinds = ppr_explicit_kinds-                  , 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 $ pprWithExplicitKindsWhen ppr_explicit_kinds 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--    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"-    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----{- *********************************************************************-*                                                                      *-                 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) =-  hang (text "NB: We cannot know what roles the parameters to" <+>-          quotes (ppr ty) <+> text "have;")-       2 (text "we must assume that the role is nominal")-pprCoercibleMsg (TyConIsAbstract tc) =-  hsep [ text "NB: The type constructor"-       , quotes (pprSourceTyCon tc)-       , text "is abstract" ]-pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) =-  hang (text "The data constructor" <+> quotes (ppr $ dataConName dc))-    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)-           , text "is not in scope" ])--pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc-pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =-  sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->-    if printExplicitCoercions-       || not (cty1 `pickyEqType` cty2)-      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 }) =-  mk_msg tv1 $$ case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 }-  where-    mk_msg tv = case tcTyVarDetails tv of-      SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])]-      RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"-      MetaTv {}     -> empty--pprAmbiguityInfo :: AmbiguityInfo -> SDoc-pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg-  where--    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]-        || any isRuntimeUnkSkol ambig_tvs-        = vcat [ text "Cannot resolve unknown runtime type"-                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs-               , text "Use :print or :force to determine these types"]--        | not (null ambig_tvs)-        = pp_ambig (text "type") ambig_tvs--        | otherwise-        = pp_ambig (text "kind") ambig_kvs--    pp_ambig what tkvs-      | prepend_msg -- "Ambiguous type variable 't0'"-      = text "Ambiguous" <+> what <+> text "variable"-        <> plural tkvs <+> pprQuotedList tkvs--      | otherwise -- "The type variable 't0' is ambiguous"-      = text "The" <+> what <+> text "variable" <> plural tkvs-        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"-pprAmbiguityInfo (NonInjectiveTyFam tc) =-  text "NB:" <+> quotes (ppr tc)-  <+> text "is a non-injective type family"--pprSameOccInfo :: SameOccInfo -> SDoc-pprSameOccInfo (SameOcc same_pkg n1 n2) =-  text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)-  where-    ppr_from same_pkg nm-      | 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)-  = 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))-    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 greMangledName 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-  where-    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))--scopeErrorHints :: NotInScopeError -> [GhcHint]-scopeErrorHints scope_err =-  case scope_err of-    NotInScope             -> noHints-    NoExactName {}         -> [SuggestDumpSlices]-    SameName {}            -> [SuggestDumpSlices]-    MissingBinding _ hints -> hints-    NoTopLevelBinding      -> noHints-    UnknownSubordinate {}  -> noHints--{- *********************************************************************-*                                                                      *-                  Outputting ImportError messages-*                                                                      *-**********************************************************************-}--instance Outputable ImportError where-  ppr (MissingModule mod_name) =-    hsep-      [ text "NB: no module named"-      , quotes (ppr mod_name)-      , text "is imported."-      ]-  ppr  (ModulesDoNotExport mods occ_name)-    | mod NE.:| [] <- mods-    = hsep-        [ text "NB: the module"-        , quotes (ppr mod)-        , text "does not export"-        , quotes (ppr occ_name) <> dot ]-    | otherwise-    = hsep-        [ text "NB: neither"-        , quotedListWithNor (map ppr $ NE.toList mods)-        , text "export"-        , quotes (ppr occ_name) <> dot ]--{- *********************************************************************-*                                                                      *-             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 (getLclEnvLoc (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 = lclEnvInGeneratedCode (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 HsExpansion].--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 af w arg res) -- Look under  c => t-      | isInvisibleFunArg af-      = 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 ->-    text "RecGadtC must have at least one constructor name"-  GadtNoCons ->-    text "GadtC 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"+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage+{-# LANGUAGE InstanceSigs #-}++module GHC.Tc.Errors.Ppr+  ( pprTypeDoesNotHaveFixedRuntimeRep+  , pprScopeError+  , 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
@@ -1,4045 +1,7064 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}--module GHC.Tc.Errors.Types (-  -- * Main types-    TcRnMessage(..)-  , mkTcRnUnknownMessage-  , TcRnMessageDetailed(..)-  , TypeDataForbids(..)-  , ErrInfo(..)-  , FixedRuntimeRepProvenance(..)-  , pprFixedRuntimeRepProvenance-  , ShadowedNameProvenance(..)-  , RecordFieldPart(..)-  , IllegalNewtypeReason(..)-  , InjectivityErrReason(..)-  , HasKinds(..)-  , hasKinds-  , SuggestUndecidableInstances(..)-  , suggestUndecidableInstances-  , SuggestUnliftedTypes(..)-  , DataSort(..), ppDataSort-  , AllowedDataResKind(..)-  , NotClosedReason(..)-  , SuggestPartialTypeSignatures(..)-  , suggestPartialTypeSignatures-  , DeriveInstanceErrReason(..)-  , UsingGeneralizedNewtypeDeriving(..)-  , usingGeneralizedNewtypeDeriving-  , DeriveAnyClassEnabled(..)-  , deriveAnyClassEnabled-  , DeriveInstanceBadConstructor(..)-  , HasWildcard(..)-  , hasWildcard-  , BadAnonWildcardContext(..)-  , SoleExtraConstraintWildcardAllowed(..)-  , DeriveGenericsErrReason(..)-  , HasAssociatedDataFamInsts(..)-  , hasAssociatedDataFamInsts-  , AssociatedTyLastVarInKind(..)-  , associatedTyLastVarInKind-  , AssociatedTyNotParamOverLastTyVar(..)-  , associatedTyNotParamOverLastTyVar-  , MissingSignature(..)-  , Exported(..)-  , HsDocContext(..)-  , FixedRuntimeRepErrorInfo(..)--  , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc--  , SolverReport(..), SolverReportSupplementary(..)-  , SolverReportWithCtxt(..)-  , SolverReportErrCtxt(..)-  , getUserGivens, discardProvCtxtGivens-  , TcSolverReportMsg(..)-  , CannotUnifyVariableReason(..)-  , MismatchMsg(..)-  , MismatchEA(..)-  , mkPlainMismatchMsg, mkBasicMismatchMsg-  , WhenMatching(..)-  , ExpectedActualInfo(..)-  , TyVarInfo(..), SameOccInfo(..)-  , AmbiguityInfo(..)-  , CND_Extra(..)-  , FitsMbSuppressed(..)-  , ValidHoleFits(..), noValidHoleFits-  , HoleFitDispConfig(..)-  , RelevantBindings(..), pprRelevantBindings-  , PromotionErr(..), pprPECategory, peCategory-  , NotInScopeError(..), mkTcRnNotInScope-  , ImportError(..)-  , HoleError(..)-  , CoercibleMsg(..)-  , PotentialInstances(..)-  , UnsupportedCallConvention(..)-  , ExpectedBackends-  , ArgOrResult(..)-  , MatchArgsContext(..), MatchArgBadMatches(..)-  , ConversionFailReason(..)-  , UnrepresentableTypeDescr(..)-  , LookupTHInstNameErrReason(..)-  , SplicePhase(..)-  , THDeclDescriptor(..)-  , RunSpliceFailReason(..)-  , ThingBeingConverted(..)-  , IllegalDecls(..)-  , EmptyStatementGroupErrReason(..)-  , UnexpectedStatement(..)-  ) where--import GHC.Prelude--import GHC.Hs-import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo, TcTyThing)-import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit)-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Evidence (EvBindsVar)-import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)-                           , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing-                           , FixedRuntimeRepOrigin(..) )-import GHC.Tc.Types.Rank (Rank)-import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)-import GHC.Types.Error-import GHC.Types.Hint (UntickedPromotedThing(..))-import GHC.Types.ForeignCall (CLabelString)-import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan)-import qualified GHC.Types.Name.Occurrence as OccName-import GHC.Types.Name.Reader-import GHC.Types.SrcLoc-import GHC.Types.TyThing (TyThing)-import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar)-import GHC.Types.Var.Env (TidyEnv)-import GHC.Types.Var.Set (TyVarSet, VarSet)-import GHC.Unit.Types (Module)-import GHC.Utils.Outputable-import GHC.Core.Class (Class, ClassMinimalDef)-import GHC.Core.Coercion.Axiom (CoAxBranch)-import GHC.Core.ConLike (ConLike)-import GHC.Core.DataCon (DataCon)-import GHC.Core.FamInstEnv (FamInst)-import GHC.Core.InstEnv (ClsInst)-import GHC.Core.PatSyn (PatSyn)-import GHC.Core.Predicate (EqRel, predTypeEqRel)-import GHC.Core.TyCon (TyCon, TyConFlavour)-import GHC.Core.Type (Kind, Type, ThetaType, PredType)-import GHC.Driver.Backend (Backend)-import GHC.Unit.State (UnitState)-import GHC.Types.Basic-import GHC.Utils.Misc (capitalise, filterOut)-import qualified GHC.LanguageExtensions as LangExt-import GHC.Data.FastString (FastString)-import GHC.Exception.Type (SomeException)--import Language.Haskell.Syntax.Basic (FieldLabelString(..))--import qualified Data.List.NonEmpty as NE-import           Data.Typeable (Typeable)-import GHC.Unit.Module.Warnings (WarningTxt)-import qualified Language.Haskell.TH.Syntax as TH--import GHC.Generics ( Generic )--{--Note [Migrating TcM Messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--As part of #18516, we are slowly migrating the diagnostic messages emitted-and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted-some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions-that accepted 3 SDocs an input: one for the important part of the message,-one for the context and one for any supplementary information. Consider the following:--    • Couldn't match expected type ‘Int’ with actual type ‘Char’-    • In the expression: x4-      In a stmt of a 'do' block: return (x2, x4)-      In the expression:--Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match"-as the important part, "In the expression" as the context and "In a stmt..In the expression"-as the supplementary, with the context and supplementary usually smashed together so that-the final message would be composed only by two SDoc (which would then be bulleted like in-the example).--In order for us to smooth out the migration to the new diagnostic infrastructure, we-introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose-of bridging the two worlds together without breaking the external API or the existing-format of messages reported by GHC.--Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden-diagnostic API inside Tc.Utils.Monad, enabling further refactorings.--In the future, once the conversion will be complete and we will successfully eradicate-any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and-existence of these two types, which for now remain a "necessary evil".---}---- 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-    -- ^ Extra context associated to the error.-  , errInfoSupplementary :: !SDoc-    -- ^ Extra supplementary info 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-  deriving Generic--mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts)-                     => a -> TcRnMessage-mkTcRnUnknownMessage diag = TcRnUnknownMessage (UnknownDiagnostic diag)---- | An error which might arise during typechecking/renaming.-data TcRnMessage where-  {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins-      to provide custom diagnostic messages originated during typechecking/renaming.-  -}-  TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage--  {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed-      to be provided in order to qualify a diagnostic and where it was originated (and why).-      It carries an extra 'UnitState' which can be used to pretty-print some names-      and it wraps a 'TcRnMessageDetailed', which includes any extra context associated-      with this diagnostic.-  -}-  TcRnMessageWithInfo :: !UnitState-                      -- ^ The 'UnitState' will allow us to pretty-print-                      -- some diagnostics with more detail.-                      -> !TcRnMessageDetailed-                      -> TcRnMessage--  {-| TcRnWithHsDocContext annotates an error message with the context in which-      it originated.-  -}-  TcRnWithHsDocContext :: !HsDocContext-                       -> !TcRnMessage-                       -> TcRnMessage--  {-| TcRnSolverReport is the constructor used to report unsolved constraints-      after constraint solving, as well as other errors such as hole fit errors.--      See the documentation of the 'TcSolverReportMsg' datatype for an overview-      of the different errors.-  -}-  TcRnSolverReport :: SolverReportWithCtxt-                   -> DiagnosticReason-                   -> [GhcHint]-                   -> TcRnMessage-    -- TODO: split up TcRnSolverReport into several components,-    -- so that we can compute the reason and hints, as opposed-    -- to having to pass them here.--  {-| TcRnRedundantConstraints is a warning that is emitted when a binding-      has a user-written type signature which contains superfluous constraints.--      Example:--        f :: (Eq a, Ord a) => a -> a -> a-        f x y = (x < y) || x == y-          -- `Eq a` is superfluous: the `Ord a` constraint suffices.--      Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296.-  -}-  TcRnRedundantConstraints :: [Id]-                           -> (SkolemInfoAnon, Bool)-                              -- ^ The contextual skolem info.-                              -- The boolean controls whether we-                              -- want to show it in the user message.-                              -- (Nice to keep track of the info in either case,-                              -- for other users of the GHC API.)-                           -> TcRnMessage--  {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern-      match is inaccessible, because the constraint solver has detected a contradiction.--      Example:--        data B a where { MkTrue :: B True; MkFalse :: B False }--        foo :: B False -> Bool-        foo MkFalse = False-        foo MkTrue  = True -- Inaccessible: requires True ~ False--    Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167.-  -}-  TcRnInaccessibleCode :: Implication          -- ^ The implication containing a contradiction.-                       -> SolverReportWithCtxt -- ^ The contradiction.-                       -> TcRnMessage--  {-| A type which was expected to have a fixed runtime representation-      does not have a fixed runtime representation.--      Example:--        data D (a :: TYPE r) = MkD a--      Test cases: T11724, T18534,-                  RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype,-                  RepPolyPatSynRes, T20423-  -}-  TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type-                                     -> !FixedRuntimeRepProvenance-                                     -> !ErrInfo -- Extra info accumulated in the TcM monad-                                     -> TcRnMessage--  {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when-      a Template Haskell quote implicitly uses 'lift'.--     Example:-       warning1 :: Lift t => t -> Q Exp-       warning1 x = [| x |]--     Test cases: th/T17804-  -}-  TcRnImplicitLift :: Name -> !ErrInfo -> TcRnMessage-  {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds)-      that occurs if a pattern binding binds no variables at all, unless it is a-      lone wild-card pattern, or a banged pattern.--     Example:-        Just _ = rhs3    -- Warning: unused pattern binding-        (_, _) = rhs4    -- Warning: unused pattern binding-        _  = rhs3        -- No warning: lone wild-card pattern-        !() = rhs4       -- No warning: banged pattern; behaves like seq--     Test cases: rename/{T13646,T17c,T17e,T7085}-  -}-  TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage-  {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when-      a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported-      abstractly, i.e. 'T'.--     Test cases: rename/should_compile/T7167-  -}-  TcRnDodgyImports :: RdrName -> TcRnMessage-  {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype-      'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a-      type/data family.--     Example:-       module Foo (-           T(..)  -- Warning: T is a type synonym-         , A(..)  -- Warning: A is a type family-         , C(..)  -- Warning: C is a data family-         ) where--       type T = Int-       type family A :: * -> *-       data family C :: * -> *--     Test cases: warnings/should_compile/DodgyExports01-  -}-  TcRnDodgyExports :: Name -> TcRnMessage-  {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when-      an import declaration does not explicitly list all the names brought into scope.--     Test cases: rename/should_compile/T4489-  -}-  TcRnMissingImportList :: IE GhcPs -> TcRnMessage-  {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled-      with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the-      reason the module was inferred to be unsafe. This warning is not raised if the-      -fplugin-trustworthy flag is passed.--     Test cases: plugins/T19926-  -}-  TcRnUnsafeDueToPlugin :: TcRnMessage-  {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks-      an associated 'RealSrcSpan'.--     Test cases: None-  -}-  TcRnModMissingRealSrcSpan :: Module -> TcRnMessage-  {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs-      when an identifier required by a signature is not exported by the module-      or signature that is being used as a substitution for that signature.--      Example(s): None--     Test cases: backpack/should_fail/bkpfail36-  -}-  TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage-  {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that-      occurs when an identifier which is necessary for implementing a module-      signature is not exported from that signature.--      Example(s): None--     Test cases: backpack/should_fail/bkpfail30-                 backpack/should_fail/bkpfail31-                 backpack/should_fail/bkpfail34-  -}-  TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage--  {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever-      an inner-scope value has the same name as an outer-scope value, i.e. the inner-      value shadows the outer one. This can catch typographical errors that turn into-      hard-to-find bugs. The warning is suppressed for names beginning with an underscore.--      Examples(s):-        f = ... let f = id in ... f ...  -- NOT OK, 'f' is shadowed-        f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore--     Test cases: typecheck/should_compile/T10971a-                 rename/should_compile/rn039-                 rename/should_compile/rn064-                 rename/should_compile/T1972-                 rename/should_fail/T2723-                 rename/should_compile/T3262-                 driver/werror-  -}-  TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage--  {-| TcRnDuplicateWarningDecls is an error that occurs whenever-      a warning is declared twice.--      Examples(s):-        None.--     Test cases:-        None.-  -}-  TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage--  {-| TcRnDuplicateWarningDecls is an error that occurs whenever-      the constraint solver in the simplifier hits the iterations' limit.--      Examples(s):-        None.--     Test cases:-        None.-  -}-  TcRnSimplifierTooManyIterations :: Cts-                                  -> !IntWithInf-                                  -- ^ The limit.-                                  -> WantedConstraints-                                  -> TcRnMessage--  {-| TcRnIllegalPatSynDecl is an error that occurs whenever-      there is an illegal pattern synonym declaration.--      Examples(s):--      varWithLocalPatSyn x = case x of-          P -> ()-        where-          pattern P = ()   -- not valid, it can't be local, it must be defined at top-level.--     Test cases: patsyn/should_fail/local-  -}-  TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage--  {-| TcRnLinearPatSyn is an error that occurs whenever a pattern-      synonym signature uses a field that is not unrestricted.--      Example(s): None--     Test cases: linear/should_fail/LinearPatSyn2-  -}-  TcRnLinearPatSyn :: !Type -> TcRnMessage--  {-| TcRnEmptyRecordUpdate is an error that occurs whenever-      a record is updated without specifying any field.--      Examples(s):--      $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions--     Test cases: th/T12788-  -}-  TcRnEmptyRecordUpdate :: TcRnMessage--  {-| TcRnIllegalFieldPunning is an error that occurs whenever-      field punning is used without the 'NamedFieldPuns' extension enabled.--      Examples(s):--      data Foo = Foo { a :: Int }--      foo :: Foo -> Int-      foo Foo{a} = a  -- Not ok, punning used without extension.--     Test cases: parser/should_fail/RecordDotSyntaxFail12-  -}-  TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage--  {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever-      wildcards (..) are used in a record without the relevant-      extension being enabled.--      Examples(s):--      data Foo = Foo { a :: Int }--      foo :: Foo -> Int-      foo Foo{..} = a  -- Not ok, wildcards used without extension.--     Test cases: parser/should_fail/RecordWildCardsFail-  -}-  TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage--  {-| TcRnIllegalWildcardInType is an error that occurs-      when a wildcard appears in a type in a location in which-      wildcards aren't allowed.--      Examples:--        Type synonyms:--          type T = _--        Class declarations and instances:--          class C _-          instance C _--        Standalone kind signatures:--          type D :: _-          data D--      Test cases:-        ExtraConstraintsWildcardInTypeSplice2-        ExtraConstraintsWildcardInTypeSpliceUsed-        ExtraConstraintsWildcardNotLast-        ExtraConstraintsWildcardTwice-        NestedExtraConstraintsWildcard-        NestedNamedExtraConstraintsWildcard-        PartialClassMethodSignature-        PartialClassMethodSignature2-        T12039-        T13324_fail1-        UnnamedConstraintWildcard1-        UnnamedConstraintWildcard2-        WildcardInADT1-        WildcardInADT2-        WildcardInADT3-        WildcardInADTContext1-        WildcardInDefault-        WildcardInDefaultSignature-        WildcardInDeriving-        WildcardInForeignExport-        WildcardInForeignImport-        WildcardInGADT1-        WildcardInGADT2-        WildcardInInstanceHead-        WildcardInInstanceSig-        WildcardInNewtype-        WildcardInPatSynSig-        WildcardInStandaloneDeriving-        WildcardInTypeFamilyInstanceRHS-        WildcardInTypeSynonymRHS-        saks_fail003-        T15433a-  -}--  TcRnIllegalWildcardInType-    :: Maybe Name-        -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard-    -> !BadAnonWildcardContext-    -> TcRnMessage---  {-| TcRnDuplicateFieldName is an error that occurs whenever-      there are duplicate field names in a record.--      Examples(s): None.--     Test cases: None.-  -}-  TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage--  {-| TcRnIllegalViewPattern is an error that occurs whenever-      the ViewPatterns syntax is used but the ViewPatterns language extension-      is not enabled.--      Examples(s):-      data Foo = Foo { a :: Int }--      foo :: Foo -> Int-      foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled.--     Test cases: parser/should_fail/ViewPatternsFail-  -}-  TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage--  {-| TcRnCharLiteralOutOfRange is an error that occurs whenever-      a character is out of range.--      Examples(s): None--     Test cases: None-  -}-  TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage--  {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever-      the record wildcards '..' are used inside a constructor without labeled fields.--      Examples(s): None--     Test cases: None-  -}-  TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage--  {-| TcRnIgnoringAnnotations is a warning that occurs when the source code-      contains annotation pragmas but the platform in use does not support an-      external interpreter such as GHCi and therefore the annotations are ignored.--      Example(s): None--     Test cases: None-  -}-  TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage--  {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas-      are used in conjunction with Safe Haskell.--      Example(s): None--     Test cases: annotations/should_fail/T10826-  -}-  TcRnAnnotationInSafeHaskell :: TcRnMessage--  {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application-      is used with an expression that does not accept "specified" type arguments.--      Example(s):-      foo :: forall {a}. a -> a-      foo x = x-      bar :: ()-      bar = let x = foo @Int 42-            in ()--     Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03-                 typecheck/should_fail/ExplicitSpecificity1-                 typecheck/should_fail/ExplicitSpecificity10-                 typecheck/should_fail/ExplicitSpecificity2-                 typecheck/should_fail/T17173-                 typecheck/should_fail/VtaFail-  -}-  TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage--  {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#'-      function is not applied to a single value argument.--      Example(s):-      tagToEnum# 1 2--     Test cases: None-  -}-  TcRnTagToEnumMissingValArg :: TcRnMessage--  {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#'-      function is not given a concrete result type.--      Example(s):-      foo :: forall a. a-      foo = tagToEnum# 0#--     Test cases: typecheck/should_fail/tcfail164-  -}-  TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage--  {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#'-      function is given a result type that is not an enumeration type.--      Example(s):-      foo :: Int -- not an enumeration TyCon-      foo = tagToEnum# 0#--     Test cases: typecheck/should_fail/tcfail164-  -}-  TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage--  {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#'-      function is given a result type that is headed by a @type data@ type, as-      the data constructors of a @type data@ do not exist at the term level.--      Example(s):-      type data Letter = A | B | C--      foo :: Letter-      foo = tagToEnum# 0#--     Test cases: type-data/should_fail/TDTagToEnum.hs-  -}-  TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage--  {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the-      predicate type of an ifThenElse expression in arrow notation depends on-      the type of the result.--      Example(s): None--     Test cases: None-  -}-  TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage--  {-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file-      contains declarations that are not allowed, such as bindings.--      Example(s): None--     Test cases: None-  -}-  TcRnIllegalHsBootFileDecl :: TcRnMessage--  {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym-      is defined in terms of itself, either directly or indirectly.--      Example(s):-      pattern A = B-      pattern B = A--     Test cases: patsyn/should_fail/T16900-  -}-  TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage--  {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature-      attempts to unify two different types.--      Example(s):-      f :: a -> b -> _-      f x y = [x, y]--     Test cases: partial-sigs/should_fail/T14449-  -}-  TcRnPartialTypeSigTyVarMismatch-    :: Name -- ^ first type variable-    -> Name -- ^ second type variable-    -> Name -- ^ function name-    -> LHsSigWcType GhcRn -> TcRnMessage--  {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable-      being quantified over in the partial type signature of a function gets unified-      with a type that is free in that function's context.--      Example(s):-      foo :: Num a => a -> a-      foo xxx = g xxx-        where-          g :: forall b. Num b => _ -> b-          g y = xxx + y--     Test cases: partial-sig/should_fail/T14479-  -}-  TcRnPartialTypeSigBadQuantifier-    :: Name   -- ^ user-written name of type variable being quantified-    -> Name   -- ^ function name-    -> Maybe Type   -- ^ type the variable unified with, if known-    -> LHsSigWcType GhcRn  -- ^ partial type signature-    -> TcRnMessage--  {-| TcRnMissingSignature is a warning that occurs when a top-level binding-      or a pattern synonym does not have a type signature.--      Controlled by the flags:-        -Wmissing-signatures-        -Wmissing-exported-signatures-        -Wmissing-pattern-synonym-signatures-        -Wmissing-exported-pattern-synonym-signatures-        -Wmissing-kind-signatures--      Test cases:-        T11077 (top-level bindings)-        T12484 (pattern synonyms)-        T19564 (kind signatures)-  -}-  TcRnMissingSignature :: MissingSignature-                       -> Exported-                       -> Bool -- ^ True: -Wmissing-signatures overrides -Wmissing-exported-signatures,-                               --     or -Wmissing-pattern-synonym-signatures overrides -Wmissing-exported-pattern-synonym-signatures-                       -> TcRnMessage--  {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures-      that occurs when a local polymorphic binding lacks a type signature.--      Example(s):-      id a = a--     Test cases: warnings/should_compile/T12574-  -}-  TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage--  {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts-      with the monomorphism restriction.--      Example(s):-      data T a = T a-      mono = ... where-        x :: Applicative f => f a-        T x = ...--     Test cases: typecheck/should_compile/T11339-  -}-  TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage--  {-| TcRnTupleConstraintInst is an error that occurs whenever an instance-      for a tuple constraint is specified.--      Examples(s):-        class C m a-        class D m a-        f :: (forall a. Eq a => (C m a, D m a)) => m a-        f = undefined--      Test cases: quantified-constraints/T15334-  -}-  TcRnTupleConstraintInst :: !Class -> TcRnMessage--  {-| TcRnAbstractClassInst is an error that occurs whenever an instance-      of an abstract class is specified.--      Examples(s):-        -- A.hs-boot-        module A where-        class C a--        -- B.hs-        module B where-        import {-# SOURCE #-} A-        instance C Int where--        -- A.hs-        module A where-        import B-        class C a where-          f :: a--        -- Main.hs-        import A-        main = print (f :: Int)--      Test cases: typecheck/should_fail/T13068-  -}-  TcRnAbstractClassInst :: !Class -> TcRnMessage--  {-| TcRnNoClassInstHead is an error that occurs whenever an instance-      head is not headed by a class.--      Examples(s):-        instance c--      Test cases: typecheck/rename/T5513-                  typecheck/rename/T16385-  -}-  TcRnNoClassInstHead :: !Type -> TcRnMessage--  {-| TcRnUserTypeError is an error that occurs due to a user's custom type error,-      which can be triggered by adding a `TypeError` constraint in a type signature-      or typeclass instance.--      Examples(s):-        f :: TypeError (Text "This is a type error")-        f = undefined--      Test cases: typecheck/should_fail/CustomTypeErrors02-                  typecheck/should_fail/CustomTypeErrors03-  -}-  TcRnUserTypeError :: !Type -> TcRnMessage--  {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified-      in a kind.--      Examples(s):-        data Q :: Eq a => Type where {}--      Test cases: dependent/should_fail/T13895-                  polykinds/T16263-                  saks/should_fail/saks_fail004-                  typecheck/should_fail/T16059a-                  typecheck/should_fail/T18714-  -}-  TcRnConstraintInKind :: !Type -> TcRnMessage--  {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple-      or unboxed sum type is specified as a function argument, when the appropriate-      extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled.--      Examples(s):-        -- T15073.hs-        import T15073a-        newtype Foo a = MkFoo a-          deriving P--        -- T15073a.hs-        class P a where-          p :: a -> (# a #)--      Test cases: deriving/should_fail/T15073.hs-                  deriving/should_fail/T15073a.hs-                  typecheck/should_fail/T16059d-  -}-  TcRnUnboxedTupleOrSumTypeFuncArg-    :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum-    -> !Type-    -> TcRnMessage--  {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is-      specified in a kind.--      Examples(s):-        data A :: * %1 -> *--      Test cases: linear/should_fail/LinearKind-                  linear/should_fail/LinearKind2-                  linear/should_fail/LinearKind3-  -}-  TcRnLinearFuncInKind :: !Type -> TcRnMessage--  {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind-      mentions quantified type variable.--      Examples(s):-        type T :: TYPE (BoxedRep l)-        data T = MkT--      Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly-  -}-  TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage--  {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification-      is specified in the type of a term.--      Examples(s):-        a = (undefined :: forall k -> k -> Type) @Int--      Test cases: dependent/should_fail/T15859-                  dependent/should_fail/T16326_Fail1-                  dependent/should_fail/T16326_Fail2-                  dependent/should_fail/T16326_Fail3-                  dependent/should_fail/T16326_Fail4-                  dependent/should_fail/T16326_Fail5-                  dependent/should_fail/T16326_Fail6-                  dependent/should_fail/T16326_Fail7-                  dependent/should_fail/T16326_Fail8-                  dependent/should_fail/T16326_Fail9-                  dependent/should_fail/T16326_Fail10-                  dependent/should_fail/T16326_Fail11-                  dependent/should_fail/T16326_Fail12-                  dependent/should_fail/T17687-                  dependent/should_fail/T18271-  -}-  TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage--  {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate-      lacks a class or type variable head.--      Examples(s):-        class (forall a. A t a => A t [a]) => B t where-          type A t a :: Constraint--      Test cases: quantified-constraints/T16474-  -}-  TcRnBadQuantPredHead :: !Type -> TcRnMessage--  {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple-      constraint is specified.--      Examples(s):-        g :: ((Show a, Num a), Eq a) => a -> a-        g = undefined--      Test cases: typecheck/should_fail/tcfail209a-  -}-  TcRnIllegalTupleConstraint :: !Type -> TcRnMessage--  {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable-      argument is specified in a constraint.--      Examples(s):-        data T-        instance Eq Int => Eq T--      Test cases: ghci/scripts/T13202-                  ghci/scripts/T13202a-                  polykinds/T12055a-                  typecheck/should_fail/T10351-                  typecheck/should_fail/T19187-                  typecheck/should_fail/T6022-                  typecheck/should_fail/T8883-  -}-  TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage--  {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit-      parameter is specified.--      Examples(s):-        type Bla = ?x::Int-        data T = T-        instance Bla => Eq T--      Test cases: polykinds/T11466-                  typecheck/should_fail/T8912-                  typecheck/should_fail/tcfail041-                  typecheck/should_fail/tcfail211-                  typecheck/should_fail/tcrun045-  -}-  TcRnIllegalImplicitParam :: !Type -> TcRnMessage--  {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint-      synonym of kind is specified.--      Examples(s):-        type Showish = Show-        f :: (Showish a) => a -> a-        f = undefined--      Test cases: typecheck/should_fail/tcfail209-  -}-  TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage--  {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified-      for a non-class.--      Examples(s):-        type C1 a = (Show (a -> Bool))-        instance C1 Int where--      Test cases: polykinds/T13267-  -}-  TcRnIllegalClassInst :: !TyConFlavour -> TcRnMessage--  {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated-      visible kind argument is specified.--      Examples(s):-        type family-          F2 :: forall (a :: Type). Type where-          F2 @a = Maybe a--      Test cases: typecheck/should_fail/T15793-                  typecheck/should_fail/T16255-  -}-  TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage--  {-| TcRnBadAssociatedType is an error that occurs whenever a class doesn't have an-      associated type.--      Examples(s):-        $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo)-                    [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)]-             return [d])-        ======>-        instance Eq Foo where-          type Rep Foo = Maybe--      Test cases: th/T12387a-  -}-  TcRnBadAssociatedType :: {-Class-} !Name -> {-TyCon-} !Name -> TcRnMessage--  {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type-      is specified.--      Examples(s):-        foo :: (a,b) -> (a~b => t) -> (a,b)-        foo p x = p--      Test cases:-        - ghci/should_run/T15806-        - indexed-types/should_fail/SimpleFail15-        - typecheck/should_fail/T11355-        - typecheck/should_fail/T12083a-        - typecheck/should_fail/T12083b-        - typecheck/should_fail/T16059c-        - typecheck/should_fail/T16059e-        - typecheck/should_fail/T17213-        - typecheck/should_fail/T18939_Fail-        - typecheck/should_fail/T2538-        - typecheck/should_fail/T5957-        - typecheck/should_fail/T7019-        - typecheck/should_fail/T7019a-        - typecheck/should_fail/T7809-        - typecheck/should_fail/T9196-        - typecheck/should_fail/tcfail127-        - typecheck/should_fail/tcfail184-        - typecheck/should_fail/tcfail196-        - typecheck/should_fail/tcfail197-  -}-  TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage--  {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction)-      that arise when the monomorphism restriction applies to the given bindings.--      Examples(s):-        {-# OPTIONS_GHC -Wmonomorphism-restriction #-}--        bar = 10--        foo :: Int-        foo = bar--        main :: IO ()-        main = print foo--      The example above emits the warning (for 'bar'), because without monomorphism-      restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us-      that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar'-      less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that.--      Test cases: typecheck/should_compile/T13785-  -}-  TcRnMonomorphicBindings :: [Name] -> TcRnMessage--  {-| TcRnOrphanInstance is a warning (controlled by -Wwarn-orphans)-      that arises when a typeclass instance is an \"orphan\", i.e. if it appears-      in a module in which neither the class nor the type being instanced are-      declared in the same module.--      Examples(s): None--      Test cases: warnings/should_compile/T9178-                  typecheck/should_compile/T4912-  -}-  TcRnOrphanInstance :: ClsInst -> TcRnMessage--  {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies-      conflicts between instance declarations.--      Examples(s): None--      Test cases: typecheck/should_fail/T2307-                  typecheck/should_fail/tcfail096-                  typecheck/should_fail/tcfail202-  -}-  TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage--  {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance-      declarations.--      Examples(s):-        class Foo a where-          foo :: a -> Int--        instance Foo Int where-          foo = id--        instance Foo Int where-          foo = const 42--      Test cases: cabal/T12733/T12733-                  typecheck/should_fail/tcfail035-                  typecheck/should_fail/tcfail023-                  backpack/should_fail/bkpfail18-                  typecheck/should_fail/TcNullaryTCFail-                  typecheck/should_fail/tcfail036-                  typecheck/should_fail/tcfail073-                  module/mod51-                  module/mod52-                  module/mod44-  -}-  TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage--  {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting-      family instance declarations.--      Examples(s): None.--      Test cases: indexed-types/should_fail/ExplicitForAllFams4b-                  indexed-types/should_fail/NoGood-                  indexed-types/should_fail/Over-                  indexed-types/should_fail/OverDirectThisMod-                  indexed-types/should_fail/OverIndirectThisMod-                  indexed-types/should_fail/SimpleFail11a-                  indexed-types/should_fail/SimpleFail11b-                  indexed-types/should_fail/SimpleFail11c-                  indexed-types/should_fail/SimpleFail11d-                  indexed-types/should_fail/SimpleFail2a-                  indexed-types/should_fail/SimpleFail2b-                  indexed-types/should_fail/T13092/T13092-                  indexed-types/should_fail/T13092c/T13092c-                  indexed-types/should_fail/T14179-                  indexed-types/should_fail/T2334A-                  indexed-types/should_fail/T2677-                  indexed-types/should_fail/T3330b-                  indexed-types/should_fail/T4246-                  indexed-types/should_fail/T7102a-                  indexed-types/should_fail/T9371-                  polykinds/T7524-                  typecheck/should_fail/UnliftedNewtypesOverlap-  -}-  TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage--  TcRnFamInstNotInjective :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> TcRnMessage--  {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that-      occurs when a strictness annotation is applied to an unlifted type.--      Example(s):-      data T = MkT !Int# -- Strictness flag has no effect on unlifted types--     Test cases: typecheck/should_compile/T20187a-                 typecheck/should_compile/T20187b-  -}-  TcRnBangOnUnliftedType :: !Type -> TcRnMessage--  {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that-      occurs when a lazy annotation is applied to an unlifted type.--      Example(s):-      data T = MkT ~Int# -- Lazy flag has no effect on unlifted types--     Test cases: typecheck/should_compile/T21951a-                 typecheck/should_compile/T21951b-  -}-  TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage--  {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has-      more than one default declaration.--      Example:-      default (Integer, Int)-      default (Double, Float) -- 2nd default declaration not allowed--     Text cases: module/mod58-  -}-  TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage--  {-| TcRnBadDefaultType is an error that occurs when a type used in a default-      declaration does not have an instance for any of the applicable classes.--      Example(s):-      data Foo-      default (Foo)--     Test cases: typecheck/should_fail/T11974b-  -}-  TcRnBadDefaultType :: Type -> [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-      `data` or `newtype` construction.--      Example(s):-      module Foo (MyClass(.., P)) where-      pattern P = Nothing-      class MyClass a where-        foo :: a -> Int--     Test cases: patsyn/should_fail/export-class-  -}-  TcRnPatSynBundledWithNonDataCon :: TcRnMessage--  {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list-      of a module has a pattern synonym bundled with a type that does not match-      the type of the pattern synonym.--      Example(s):-      module Foo (R(P,x)) where-      data Q = Q Int-      data R = R-      pattern P{x} = Q x--     Text cases: patsyn/should_fail/export-ps-rec-sel-                 patsyn/should_fail/export-type-synonym-                 patsyn/should_fail/export-type-  -}-  TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage--  {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that-      occurs when a module appears more than once in an export list.--      Example(s):-      module Foo (module Bar, module Bar)-      import Bar--     Text cases: None-  -}-  TcRnDupeModuleExport :: ModuleName -> TcRnMessage--  {-| TcRnExportedModNotImported is an error that occurs when an export list-      contains a module that is not imported.--      Example(s): None--     Text cases: module/mod135-                 module/mod8-                 rename/should_fail/rnfail028-                 backpack/should_fail/bkpfail48-  -}-  TcRnExportedModNotImported :: ModuleName -> TcRnMessage--  {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs-      when an export list contains a module that has no exports.--      Example(s):-      module Foo (module Bar) where-      import Bar ()--     Test cases: None-  -}-  TcRnNullExportedModule :: ModuleName -> TcRnMessage--  {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that-      occurs when a module does not have an explicit export list.--      Example(s): None--     Test cases: typecheck/should_fail/MissingExportList03-  -}-  TcRnMissingExportList :: ModuleName -> TcRnMessage--  {-| TcRnExportHiddenComponents is an error that occurs when an export contains-      constructor or class methods that are not visible.--      Example(s): None--     Test cases: None-  -}-  TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage--  {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs-      when an identifier appears in an export list more than once.--      Example(s): None--     Test cases: module/MultiExport-                 module/mod128-                 module/mod14-                 module/mod5-                 overloadedrecflds/should_fail/DuplicateExports-                 patsyn/should_compile/T11959-  -}-  TcRnDuplicateExport :: GreName -> 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--      Example(s):-      module Foo (T(a)) where-      data T-      a = True--     Test cases: module/T11970-                 module/T11970B-                 module/mod17-                 module/mod3-                 overloadedrecflds/should_fail/NoParent-  -}-  TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage--  {-| TcRnConflictingExports is an error that occurs when different identifiers that-      have the same name are being exported by a module.--      Example(s):-      module Foo (Bar.f, module Baz) where-      import qualified Bar (f)-      import Baz (f)--     Test cases: module/mod131-                 module/mod142-                 module/mod143-                 module/mod144-                 module/mod145-                 module/mod146-                 module/mod150-                 module/mod155-                 overloadedrecflds/should_fail/T14953-                 overloadedrecflds/should_fail/overloadedrecfldsfail10-                 rename/should_fail/rnfail029-                 rename/should_fail/rnfail040-                 typecheck/should_fail/T16453E2-                 typecheck/should_fail/tcfail025-                 typecheck/should_fail/tcfail026-  -}-  TcRnConflictingExports-    :: OccName -- ^ Occurrence name shared by both exports-    -> GreName -- ^ Name of first export-    -> GlobalRdrElt -- ^ Provenance for definition site of first export-    -> IE GhcPs -- ^ Export decl of first export-    -> GreName -- ^ Name of second export-    -> GlobalRdrElt -- ^ Provenance for definition site of second export-    -> IE GhcPs -- ^ Export decl of second export-    -> TcRnMessage--  {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring-      when a record update's type cannot be precisely determined. This will not-      be supported by -XDuplicateRecordFields in future releases.--      Example(s):-      data Person  = MkPerson  { personId :: Int, name :: String }-      data Address = MkAddress { personId :: Int, address :: String }-      bad1 x = x { personId = 4 } :: Person -- ambiguous-      bad2 (x :: Person) = x { personId = 4 } -- ambiguous-      good x = (x :: Person) { personId = 4 } -- not ambiguous--     Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06-  -}-  TcRnAmbiguousField-    :: HsExpr GhcRn -- ^ Field update-    -> TyCon -- ^ Record type-    -> TcRnMessage--  {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring-      when the intialisation of a record is missing one or more (lazy) fields.--      Example(s):-      data Rec = Rec { a :: Int, b :: String, c :: Bool }-      x = Rec { a = 1, b = "two" } -- missing field 'c'--     Test cases: deSugar/should_compile/T13870-                 deSugar/should_compile/ds041-                 patsyn/should_compile/T11283-                 rename/should_compile/T5334-                 rename/should_compile/T12229-                 rename/should_compile/T5892a-                 warnings/should_fail/WerrorFail2-  -}-  TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage--  {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's-      type mentions something that is outside the universally quantified variables-      of the data constructor, such as an existentially quantified type.--      Example(s):-      data X = forall a. MkX { f :: a }-      x = (MkX ()) { f = False }--      Test cases: patsyn/should_fail/records-exquant-                  typecheck/should_fail/T3323-  -}-  TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage--  {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update-      has fields that no single constructor encompasses.--      Example(s):-      data Foo = A { x :: Bool }-               | B { y :: Int }-      foo = (A False) { x = True, y = 5 }--     Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08-                 patsyn/should_fail/mixed-pat-syn-record-sels-                 typecheck/should_fail/T7989-  -}-  TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage--  {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and-      record selectors are used in the same record update block.--      Example(s):-      data Rec = Rec { foo :: Int, bar :: String }-      pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 }-      illegal :: Rec -> Rec-      illegal r = r { f1 = 1, bar = "two" }--     Test cases: patsyn/should_fail/records-mixing-fields-  -}-  TcRnMixedSelectors-    :: Name -- ^ Record-    -> [Id] -- ^ Record selectors-    -> Name -- ^ Pattern synonym-    -> [Id] -- ^ Pattern selectors-    -> TcRnMessage--  {- TcRnMissingStrictFields is an error occurring when a record field marked-     as strict is omitted when constructing said record.--     Example(s):-     data R = R { strictField :: !Bool, nonStrict :: Int }-     x = R { nonStrict = 1 }--    Test cases: typecheck/should_fail/T18869-                typecheck/should_fail/tcfail085-                typecheck/should_fail/tcfail112-  -}-  TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage--  {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a-     record update block do not all belong to any one type.--     Example(s):-     data R1 = R1 { x :: Int, y :: Int }-     data R2 = R2 { y :: Int, z :: Int }-     update r = r { x = 1, y = 2, z = 3 }--    Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01-                overloadedrecflds/should_fail/overloadedrecfldsfail14-  -}-  TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage--  {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot-     be pinned down to any one constructor and thus must be given a type signature.--     Example(s):-     data R1 = R1 { x :: Int }-     data R2 = R2 { x :: Int }-     update r = r { x = 1 } -- needs a type signature--    Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01-  -}-  TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage--  {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static-     using the -XStaticPointers extension but which are not closed terms.--     Example(s):-     f x = static x--    Test cases: rename/should_fail/RnStaticPointersFail01-                rename/should_fail/RnStaticPointersFail03-  -}-  TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage-  {-| TcRnSpecialClassInst is an error that occurs when a user-      attempts to define an instance for a built-in typeclass such as-      'Coercible', 'Typeable', or 'KnownNat', outside of a signature file.--     Test cases: deriving/should_fail/T9687-                 deriving/should_fail/T14916-                 polykinds/T8132-                 typecheck/should_fail/TcCoercibleFail2-                 typecheck/should_fail/T12837-                 typecheck/should_fail/T14390--  -}-  TcRnSpecialClassInst :: !Class-                       -> !Bool -- ^ Whether the error is due to Safe Haskell being enabled-                       -> TcRnMessage--  {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that-      occurs when trying to derive an instance of the 'Typeable' class. Deriving-      'Typeable' is no longer necessary (hence the \"useless\") as all types-      automatically derive 'Typeable' in modern GHC versions.--      Example(s): None.--     Test cases: warnings/should_compile/DerivingTypeable-  -}-  TcRnUselessTypeable :: TcRnMessage--  {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that-      occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are-      enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not-      be what the user wants.--      Example(s): None.--     Test cases: typecheck/should_compile/T15839a-                 deriving/should_compile/T16179-  -}-  TcRnDerivingDefaults :: !Class -> TcRnMessage--  {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC-      encounters a non-unary constraint when trying to derive a typeclass.--      Example(s):-        class A-        deriving instance A-        data B deriving A  -- We cannot derive A, is not unary (i.e. 'class A a').--     Test cases: deriving/should_fail/T7959-                 deriving/should_fail/drvfail005-                 deriving/should_fail/drvfail009-                 deriving/should_fail/drvfail006-  -}-  TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> 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-      type class derivation--      Example(s):-        foo :: _ -> Int-        foo = ...--        deriving instance _ => Eq (Foo a)--     Test cases: dependent/should_compile/T11241-                 dependent/should_compile/T15076-                 dependent/should_compile/T14880-2-                 typecheck/should_compile/T17024-                 typecheck/should_compile/T10072-                 partial-sigs/should_fail/TidyClash2-                 partial-sigs/should_fail/Defaulting1MROff-                 partial-sigs/should_fail/WildcardsInPatternAndExprSig-                 partial-sigs/should_fail/T10615-                 partial-sigs/should_fail/T14584a-                 partial-sigs/should_fail/TidyClash-                 partial-sigs/should_fail/T11122-                 partial-sigs/should_fail/T14584-                 partial-sigs/should_fail/T10045-                 partial-sigs/should_fail/PartialTypeSignaturesDisabled-                 partial-sigs/should_fail/T10999-                 partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature-                 partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice-                 partial-sigs/should_fail/WildcardInstantiations-                 partial-sigs/should_run/T15415-                 partial-sigs/should_compile/T10463-                 partial-sigs/should_compile/T15039a-                 partial-sigs/should_compile/T16728b-                 partial-sigs/should_compile/T15039c-                 partial-sigs/should_compile/T10438-                 partial-sigs/should_compile/SplicesUsed-                 partial-sigs/should_compile/T18008-                 partial-sigs/should_compile/ExprSigLocal-                 partial-sigs/should_compile/T11339a-                 partial-sigs/should_compile/T11670-                 partial-sigs/should_compile/WarningWildcardInstantiations-                 partial-sigs/should_compile/T16728-                 partial-sigs/should_compile/T12033-                 partial-sigs/should_compile/T15039b-                 partial-sigs/should_compile/T10403-                 partial-sigs/should_compile/T11192-                 partial-sigs/should_compile/T16728a-                 partial-sigs/should_compile/TypedSplice-                 partial-sigs/should_compile/T15039d-                 partial-sigs/should_compile/T11016-                 partial-sigs/should_compile/T13324_compile2-                 linear/should_fail/LinearPartialSig-                 polykinds/T14265-                 polykinds/T14172-  -}-  TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage--  {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance-      can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason-      this error arose.--      Example(s): None.--      Test cases: generics/T10604/T10604_no_PolyKinds-                  deriving/should_fail/drvfail009-                  deriving/should_fail/drvfail-functor2-                  deriving/should_fail/T10598_fail3-                  deriving/should_fail/deriving-via-fail2-                  deriving/should_fail/deriving-via-fail-                  deriving/should_fail/T16181-  -}-  TcRnCannotDeriveInstance :: !Class-                           -- ^ The typeclass we are trying to derive-                           -- an instance for-                           -> [Type]-                           -- ^ The typeclass arguments, if any.-                           -> !(Maybe (DerivStrategy GhcTc))-                           -- ^ The derivation strategy, if any.-                           -> !UsingGeneralizedNewtypeDeriving-                           -- ^ Is '-XGeneralizedNewtypeDeriving' enabled?-                           -> !DeriveInstanceErrReason-                           -- ^ The specific reason why we couldn't derive-                           -- an instance for the class.-                           -> TcRnMessage--  {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested-      GADT pattern match inside a lazy (~) pattern.--      Test case: gadt/lazypat-  -}-  TcRnLazyGADTPattern :: TcRnMessage--  {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a-      GADT pattern inside arrow proc notation.--      Test case: arrows/should_fail/arrowfail004.-  -}-  TcRnArrowProcGADTPattern :: TcRnMessage--  {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs-     when a definition uses 'forall' as an identifier.--     Example:-       forall x = ()-       g forall = ()--     Test cases: T20609 T20609a T20609b T20609c T20609d-  -}-  TcRnForallIdentifier :: RdrName -> TcRnMessage--  {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope)-      that occurs when the type equality (a ~ b) is not in scope.--      Test case: T18862b-  -}-  TcRnTypeEqualityOutOfScope :: TcRnMessage--  {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators)-      that occurs when the type equality (a ~ b) is used without the TypeOperators extension.--      Example:-        {-# LANGUAGE NoTypeOperators #-}-        f :: (a ~ b) => a -> b--      Test case: T18862a-  -}-  TcRnTypeEqualityRequiresOperators :: TcRnMessage--  {-| TcRnIllegalTypeOperator is an error that occurs when a type operator-      is used without the TypeOperators extension.--      Example:-        {-# LANGUAGE NoTypeOperators #-}-        f :: Vec a n -> Vec a m -> Vec a (n + m)--      Test case: T12811-  -}-  TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage--  {-| TcRnIllegalTypeOperatorDecl is an error that occurs when a type or class-      operator is declared without the TypeOperators extension.--      See Note [Type and class operator definitions]--      Example:-        {-# LANGUAGE Haskell2010 #-}-        {-# LANGUAGE MultiParamTypeClasses #-}--        module T3265 where--        data a :+: b = Left a | Right b--        class a :*: b where {}---      Test cases: T3265, tcfail173-  -}-  TcRnIllegalTypeOperatorDecl :: !RdrName -> TcRnMessage---  {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds-      that occurs when pattern matching on a GADT when -XMonoLocalBinds is off.--      Example(s): None--      Test cases: T20485, T20485a-  -}-  TcRnGADTMonoLocalBinds :: TcRnMessage-  {-| The TcRnNotInScope constructor is used for various not-in-scope errors.-      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--  {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors)-      that is triggered by an unticked occurrence of a promoted data constructor.--      Examples:--        data A = MkA-        type family F (a :: A) where { F MkA = Bool }--        type B = [ Int, Bool ]--      Test cases: T9778, T19984.-  -}-  TcRnUntickedPromotedThing :: UntickedPromotedThing-                            -> TcRnMessage--  {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears-      in an unexpected location, e.g. as a data constructor or in a fixity declaration.--      Examples:--        infixl 5 :--        data P = (,)--      Test cases: rnfail042, T14907b, T15124, T15233.-  -}-  TcRnIllegalBuiltinSyntax :: SDoc -- ^ 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-      is solving through the defaulting of a type variable.--      Example:--        one = show 1-        -- We get Wanteds Show a0, Num a0, and default a0 to Integer.--      Test cases:-        none (which are really specific to defaulting),-        but see e.g. tcfail204.-   -}-  TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred-                     -> Maybe TyVar -- ^ The type variable being defaulted-                     -> Type -- ^ The default type-                     -> TcRnMessage--  {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name'-      is used in the incorrect 'NameSpace', e.g. a type constructor-      or class used in a term, or a term variable used in a type.--      Example:--        f x = Int--      Test cases: T18740a, T20884.-  -}-  TcRnIncorrectNameSpace :: Name-                         -> Bool -- ^ whether the error is happening-                                 -- in a Template Haskell tick-                                 -- (so we should give a Template Haskell hint)-                         -> TcRnMessage--  {- TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import-     is declared using the @prim@ calling convention without having turned on-     the -XGHCForeignImportPrim extension.--     Example(s):-     foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #)--    Test cases: ffi/should_fail/T20116-  -}-  TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage--  {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe-     annotation should not be used with @prim@ foreign imports.--     Example(s):-     foreign import prim unsafe "my_primop_cmm" :: ...--    Test cases: None-  -}-  TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage--  {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@-     imports cannot have function types.--     Example(s):-     foreign import capi "math.h value sqrt" f :: CInt -> CInt--    Test cases: ffi/should_fail/capi_value_function-  -}-  TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage--  {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@-     that informs the user of a possible missing @&@ in the declaration of a-     foreign import with a 'FunPtr' return type.--     Example(s):-     foreign import ccall "f" f :: FunPtr (Int -> IO ())--    Test cases: ffi/should_compile/T1357-  -}-  TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage--  {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration-     is not compatible with the code generation backend being used.--     Example(s): None--    Test cases: None-  -}-  TcRnIllegalForeignDeclBackend-    :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)-    -> Backend-    -> ExpectedBackends-    -> TcRnMessage--  {- TcRnUnsupportedCallConv informs the user that the calling convention specified-     for a foreign export declaration is not compatible with the target platform.-     It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of-     @stdcall@ but is otherwise considered an error.--     Example(s): None--    Test cases: None-  -}-  TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)-                          -> UnsupportedCallConvention-                          -> TcRnMessage--  {- TcRnIllegalForeignType is an error for when a type appears in a foreign-     function signature that is not compatible with the FFI.--     Example(s): None--    Test cases: ffi/should_fail/T3066-                ffi/should_fail/ccfail004-                ffi/should_fail/T10461-                ffi/should_fail/T7506-                ffi/should_fail/T5664-                safeHaskell/ghci/p6-                safeHaskell/safeLanguage/SafeLang08-                ffi/should_fail/T16702-                linear/should_fail/LinearFFI-                ffi/should_fail/T7243-  -}-  TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage--  {- TcRnInvalidCIdentifier indicates a C identifier that is not valid.--     Example(s):-     foreign import prim safe "not valid" cmm_test2 :: Int# -> Int#--    Test cases: th/T10638-  -}-  TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage--  {- TcRnExpectedValueId is an error occurring when something that is not a-      value identifier is used where one is expected.--     Example(s): none--    Test cases: none-  -}-  TcRnExpectedValueId :: !TcTyThing -> TcRnMessage--  {- TcRnNotARecordSelector is an error for when something that is not a record-     selector is used in a record pattern.--     Example(s):-     data Rec = MkRec { field :: Int }-     r = Mkrec 1-     r' = r { notAField = 2 }--    Test cases: rename/should_fail/rnfail054-                typecheck/should_fail/tcfail114-  -}-  TcRnNotARecordSelector :: !Name -> TcRnMessage--  {- TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector-     containing an existential type variable is used as a function rather than in-     a pattern match.--     Example(s):-     data Rec = forall a. Rec { field :: a }-     field (Rec True)--    Test cases: patsyn/should_fail/records-exquant-                typecheck/should_fail/T3176-  -}-  TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage--  {- TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern-     synonym is used as a constructor.--     Example(s):-     pattern Five :: Int-     pattern Five <- 5-     five = Five--    Test cases: patsyn/should_fail/records-no-uni-update-                patsyn/should_fail/records-no-uni-update2-  -}-  TcRnPatSynNotBidirectional :: !Name -> TcRnMessage--  {- TcRnSplicePolymorphicLocalVar is the error that occurs when the expression-     inside typed template haskell brackets is a polymorphic local variable.--     Example(s):-     x = \(y :: forall a. a -> a) -> [|| y ||]--    Test cases: quotes/T10384-  -}-  TcRnSplicePolymorphicLocalVar :: !Id -> TcRnMessage--  {- TcRnIllegalDerivingItem is an error for when something other than a type class-     appears in a deriving statement.--     Example(s):-     data X = X deriving Int--    Test cases: deriving/should_fail/T5922-  -}-  TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage--  {- TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such-     as strictness, laziness, or unpacking.--     Example(s):-     data T = T { t :: Maybe {-# UNPACK #-} Int }-     data C = C { f :: !IntMap Int }--    Test cases: parser/should_fail/unpack_inside_type-                typecheck/should_fail/T7210-  -}-  TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsSrcBang -> TcRnMessage--  {- TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax.--     Example(s):-     data T = T Int { field :: Int }--    Test cases: rename/should_fail/T7943-                rename/should_fail/T9077-  -}-  TcRnIllegalRecordSyntax :: !(HsType GhcRn) -> TcRnMessage--  {- TcRnUnexpectedTypeSplice is an error for a typed template haskell splice-     appearing unexpectedly.--     Example(s): none--    Test cases: none-  -}-  TcRnUnexpectedTypeSplice :: !(HsType GhcRn) -> TcRnMessage--  {- TcRnInvalidVisibleKindArgument is an error for a kind application on a-     target type that cannot accept it.--     Example(s):-     bad :: Int @Type-     bad = 1-     type Foo :: forall a {b}. a -> b -> b-     type Foo x y = y-     type Bar = Foo @Bool @Int True 42--    Test cases: indexed-types/should_fail/T16356_Fail3-                typecheck/should_fail/ExplicitSpecificity7-                typecheck/should_fail/T12045b-                typecheck/should_fail/T12045c-                typecheck/should_fail/T15592a-                typecheck/should_fail/T15816-  -}-  TcRnInvalidVisibleKindArgument-    :: !(LHsType GhcRn) -- ^ The visible kind argument-    -> !Type -- ^ Target of the kind application-    -> TcRnMessage--  {- TcRnTooManyBinders is an error for a type constructor that is declared with-     more arguments then its kind specifies.--     Example(s):-     type T :: Type -> (Type -> Type) -> Type-     data T a (b :: Type -> Type) x1 (x2 :: Type -> Type)--    Test cases: saks/should_fail/saks_fail008-  -}-  TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr () GhcRn] -> TcRnMessage--  {- TcRnDifferentNamesForTyVar is an error that indicates different names being-     used for the same type variable.--     Example(s):-     data SameKind :: k -> k -> *-     data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)--    Test cases: polykinds/T11203-                polykinds/T11821a-                saks/should_fail/T20916-                typecheck/should_fail/T17566b-                typecheck/should_fail/T17566c-  -}-  TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage--  {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature,-      where the implicitly-bound type type variables can't be matched up unambiguously-      with the ones from the signature. See Note [Disconnected type variables] in-      GHC.Tc.Gen.HsType.-  -}-  TcRnDisconnectedTyVar :: !Name -> TcRnMessage--  {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature-     with an invalid result kind.--     Example(s):-     data family Foo :: Constraint--    Test cases: typecheck/should_fail/T14048b-                typecheck/should_fail/UnliftedNewtypesConstraintFamily-                typecheck/should_fail/T12729-                typecheck/should_fail/T15883-                typecheck/should_fail/T16829a-                typecheck/should_fail/T16829b-                typecheck/should_fail/UnliftedNewtypesNotEnabled-                typecheck/should_fail/tcfail079-  -}-  TcRnInvalidReturnKind-    :: !DataSort -- ^ classification of thing being returned-    -> !AllowedDataResKind -- ^ allowed kind-    -> !Kind -- ^ the return kind-    -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension-    -> TcRnMessage--  {- TcRnClassKindNotConstraint is an error for a type class that has a kind that-     is not equivalent to Constraint.--     Example(s):-     type C :: Type -> Type-     class C a--    Test cases: saks/should_fail/T16826-  -}-  TcRnClassKindNotConstraint :: !Kind -> TcRnMessage--  {- TcRnUnpromotableThing is an error that occurs when the user attempts to-     use the promoted version of something which is not promotable.--     Example(s):-     data T :: T -> *-     data X a where-       MkX :: Show a => a -> X a-     foo :: Proxy ('MkX 'True)-     foo = Proxy--    Test cases: dependent/should_fail/PromotedClass-                dependent/should_fail/T14845_fail1-                dependent/should_fail/T14845_fail2-                dependent/should_fail/T15215-                dependent/should_fail/T13780c-                dependent/should_fail/T15245-                polykinds/T5716-                polykinds/T5716a-                polykinds/T6129-                polykinds/T7433-                patsyn/should_fail/T11265-                patsyn/should_fail/T9161-1-                patsyn/should_fail/T9161-2-                dependent/should_fail/SelfDep-                polykinds/PolyKinds06-                polykinds/PolyKinds07-                polykinds/T13625-                polykinds/T15116-                polykinds/T15116a-                saks/should_fail/T16727a-                saks/should_fail/T16727b-                rename/should_fail/T12686-  -}-  TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage--  {- TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches-     that have different numbers of arguments--     Example(s):-     foo x = True-     foo x y = False--    Test cases: rename/should_fail/rnfail045-                typecheck/should_fail/T20768_fail-  -}-  TcRnMatchesHaveDiffNumArgs-    :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics-    -> !MatchArgBadMatches-    -> TcRnMessage--  {- TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type-     variables cannot be used in pattern bindings.--     Example(s):-     let (x :: a) = 5--     Test cases: typecheck/should_compile/tc141-  -}-  TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage--  {- TcRnCannotBindTyVarsInPatBind is an error for when type-     variables are introduced in a pattern binding--     Example(s):-     Just @a x = Just True--    Test cases: typecheck/should_fail/TyAppPat_PatternBinding-                typecheck/should_fail/TyAppPat_PatternBindingExistential-  -}-  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.--     Example(s):-     {-# INLINE foo #-}-     {-# INLINE foo #-}-     foo :: Bool -> Bool-     foo = id--    Test cases: none-  -}-  TcRnMultipleInlinePragmas-    :: !Id -- ^ Target of the pragmas-    -> !(LocatedA InlinePragma) -- ^ The first pragma-    -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas-    -> TcRnMessage--  {- TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear-     in the source.--     Example(s):--    Test cases: none-  -}-  TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage--  {- TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being-     placed on a definition that is not overloaded.--     Example(s):-     {-# SPECIALISE foo :: Bool -> Bool #-}-     foo :: Bool -> Bool-     foo = id--    Test cases: simplCore/should_compile/T8537-                typecheck/should_compile/T10504-  -}-  TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage--  {- TcRnSpecialiseNotVisible is a warning that occurs when the subject of a-     SPECIALISE pragma has a definition that is not visible from the current module.--     Example(s): none--    Test cases: none-  -}-  TcRnSpecialiseNotVisible :: !Name -> TcRnMessage--  {- TcRnNameByTemplateHaskellQuote is an error that occurs when one tries-     to use a Template Haskell splice to define a top-level identifier with-     an already existing name.--     (See issue #13968 (closed) on GHC's issue tracker for more details)--     Example(s):--       $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])--     Test cases:-      T13968-  -}-  TcRnNameByTemplateHaskellQuote :: !RdrName -> TcRnMessage--  {- TcRnIllegalBindingOfBuiltIn is an error that occurs when one uses built-in-     syntax for data constructors or class names.--     Use an OccName here because we don't want to print Prelude.(,)--     Test cases:-      rename/should_fail/T14907b-      rename/should_fail/rnfail042-  -}-  TcRnIllegalBindingOfBuiltIn :: !OccName -> TcRnMessage--  {- TcRnPragmaWarning is a warning that can happen when usage of something-     is warned or deprecated by pragma.--    Test cases:-      DeprU-      T5281-      T5867-      rn050-      rn066 (here is a warning, not deprecation)-      T3303-  -}-  TcRnPragmaWarning :: {-    pragma_warning_occ :: OccName,-    pragma_warning_msg :: WarningTxt GhcRn,-    pragma_warning_import_mod :: ModuleName,-    pragma_warning_defined_mod :: ModuleName-  } -> TcRnMessage---  {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for-     a class default method is provided in a Backpack signature file.--    Test case:-      bkpfail40-  -}--  TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class-                                -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods-                                -> TcRnMessage-  {-| TcRnBadGenericMethod-     This test ensures that if you provide a "more specific" type signatures-     for the default method, you must also provide a binding.--     Example:-     {-# LANGUAGE DefaultSignatures #-}--     class C a where-       meth :: a-       default meth :: Num a => a-       meth = 0--    Test case:-      testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs-  -}-  TcRnBadGenericMethod :: !Name   -- ^ 'Name' of the class-                       -> !Name   -- ^ Problematic method-                       -> TcRnMessage--  {-| TcRnWarningMinimalDefIncomplete is a warning that one must-      specify which methods must be implemented by all instances.--     Example:-       class Cheater a where  -- WARNING LINE-       cheater :: a-       {-# MINIMAL #-} -- warning!--     Test case:-       testsuite/tests/warnings/minimal/WarnMinimal.hs:-  -}-  TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage--  {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when-      a default method pragma is missing an accompanying binding.--    Test cases:-      testsuite/tests/typecheck/should_fail/T5084.hs-      testsuite/tests/typecheck/should_fail/T2354.hs-  -}-  TcRnDefaultMethodForPragmaLacksBinding-            :: Id             -- ^ method-            -> Sig GhcRn      -- ^ the pragma-            -> TcRnMessage-  {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when-      a specialise pragma is put on a default method.--    Test cases: none-  -}-  TcRnIgnoreSpecialisePragmaOnDefMethod-            :: !Name-            -> TcRnMessage-  {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method-     in a class instance, when the class doesn't have a method by that name.--     Test case:-       testsuite/tests/th/T12387-  -}-  TcRnBadMethodErr-    :: { badMethodErrClassName  :: !Name-       , badMethodErrMethodName :: !Name-       } -> TcRnMessage-  {-| TcRnNoExplicitAssocTypeOrDefaultDeclaration is an error that occurs-      when a class instance does not provide an expected associated type-      or default declaration.--    Test cases:-      testsuite/tests/deriving/should_compile/T14094-      testsuite/tests/indexed-types/should_compile/Simple2-      testsuite/tests/typecheck/should_compile/tc254-  -}-  TcRnNoExplicitAssocTypeOrDefaultDeclaration-            :: Name-            -> TcRnMessage-  {-| TcRnIllegalNewtype is an error that occurs when a newtype:--      * Does not have exactly one field, or-      * is non-linear, or-      * is a GADT, or-      * has a context in its constructor's type, or-      * has existential type variables in its constructor's type, or-      * has strictness annotations.--    Test cases:-      testsuite/tests/gadt/T14719-      testsuite/tests/indexed-types/should_fail/T14033-      testsuite/tests/indexed-types/should_fail/T2334A-      testsuite/tests/linear/should_fail/LinearGADTNewtype-      testsuite/tests/parser/should_fail/readFail008-      testsuite/tests/polykinds/T11459-      testsuite/tests/typecheck/should_fail/T15523-      testsuite/tests/typecheck/should_fail/T15796-      testsuite/tests/typecheck/should_fail/T17955-      testsuite/tests/typecheck/should_fail/T18891a-      testsuite/tests/typecheck/should_fail/T21447-      testsuite/tests/typecheck/should_fail/tcfail156-  -}-  TcRnIllegalNewtype-            :: DataCon-            -> Bool -- ^ True if linear types enabled-            -> IllegalNewtypeReason-            -> TcRnMessage--  {-| TcRnIllegalTypeData is an error that occurs when a @type data@-      declaration occurs without the TypeOperators extension.--      See Note [Type data declarations]--     Test case:-       testsuite/tests/type-data/should_fail/TDNoPragma-  -}-  TcRnIllegalTypeData :: TcRnMessage--  {-| TcRnTypeDataForbids is an error that occurs when a @type data@-      declaration contains @data@ declaration features that are-      forbidden in a @type data@ declaration.--      See Note [Type data declarations]--     Test cases:-       testsuite/tests/type-data/should_fail/TDDeriving-       testsuite/tests/type-data/should_fail/TDRecordsGADT-       testsuite/tests/type-data/should_fail/TDRecordsH98-       testsuite/tests/type-data/should_fail/TDStrictnessGADT-       testsuite/tests/type-data/should_fail/TDStrictnessH98-  -}-  TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage--  {-| TcRnTypedTHWithPolyType is an error that signifies the illegal use-      of a polytype in a typed template haskell expression.--      Example(s):-      bad :: (forall a. a -> a) -> ()-      bad = $$( [|| \_ -> () ||] )--     Test cases: th/T11452-  -}-  TcRnTypedTHWithPolyType :: !TcType -> TcRnMessage--  {-| TcRnSpliceThrewException is an error that occurrs when running a template-      haskell splice throws an exception.--      Example(s):--     Test cases: annotations/should_fail/annfail12-                 perf/compiler/MultiLayerModulesTH_Make-                 perf/compiler/MultiLayerModulesTH_OneShot-                 th/T10796b-                 th/T19470-                 th/T19709d-                 th/T5358-                 th/T5976-                 th/T7276a-                 th/T8987-                 th/TH_exn1-                 th/TH_exn2-                 th/TH_runIO-  -}-  TcRnSpliceThrewException-    :: !SplicePhase-    -> !SomeException-    -> !String -- ^ Result of showing the exception (cannot be done safely outside IO)-    -> !(LHsExpr GhcTc)-    -> !Bool -- True <=> Print the expression-    -> TcRnMessage--  {-| TcRnInvalidTopDecl is a template haskell error occurring when one of the 'Dec's passed to-      'addTopDecls' is not a function, value, annotation, or foreign import declaration.--      Example(s):--     Test cases:-  -}-  TcRnInvalidTopDecl :: !(HsDecl GhcPs) -> TcRnMessage--  {-| TcRnNonExactName is a template haskell error for when a declaration being-      added is bound to a name that is not fully known.--      Example(s):--     Test cases:-  -}-  TcRnNonExactName :: !RdrName -> TcRnMessage--  {-| TcRnAddInvalidCorePlugin is a template haskell error indicating that a-      core plugin being added has an invalid module due to being in the current package.--      Example(s):--     Test cases:-  -}-  TcRnAddInvalidCorePlugin-    :: !String -- ^ Module name-    -> TcRnMessage--  {-| TcRnAddDocToNonLocalDefn is a template haskell error for documentation being added to a-      definition which is not in the current module.--      Example(s):--     Test cases: showIface/should_fail/THPutDocExternal-  -}-  TcRnAddDocToNonLocalDefn :: !TH.DocLoc -> TcRnMessage--  {-| TcRnFailedToLookupThInstName is a template haskell error that occurrs when looking up an-      instance fails.--      Example(s):--     Test cases: showIface/should_fail/THPutDocNonExistent-  -}-  TcRnFailedToLookupThInstName :: !TH.Type -> !LookupTHInstNameErrReason -> TcRnMessage--  {-| TcRnCannotReifyInstance is a template haskell error for when an instance being reified-      via `reifyInstances` is not a class constraint or type family application.--      Example(s):--     Test cases:-  -}-  TcRnCannotReifyInstance :: !Type -> TcRnMessage--  {-| TcRnCannotReifyOutOfScopeThing is a template haskell error indicating-      that the given name is not in scope and therefore cannot be reified.--      Example(s):--     Test cases: th/T16976f-  -}-  TcRnCannotReifyOutOfScopeThing :: !TH.Name -> TcRnMessage--  {-| TcRnCannotReifyThingNotInTypeEnv is a template haskell error occurring-      when the given name is not in the type environment and therefore cannot be reified.--      Example(s):--     Test cases:-  -}-  TcRnCannotReifyThingNotInTypeEnv :: !Name -> TcRnMessage--  {-| TcRnNoRolesAssociatedWithName is a template haskell error for when the user-      tries to reify the roles of a given name but it is not something that has-      roles associated with it.--      Example(s):--     Test cases:-  -}-  TcRnNoRolesAssociatedWithThing :: !TcTyThing -> TcRnMessage--  {-| TcRnCannotRepresentThing is a template haskell error indicating that a-      type cannot be reified because it does not have a representation in template haskell.--      Example(s):--     Test cases:-  -}-  TcRnCannotRepresentType :: !UnrepresentableTypeDescr -> !Type -> TcRnMessage--  {-| TcRnRunSpliceFailure is an error indicating that a template haskell splice-      failed to be converted into a valid expression.--      Example(s):--     Test cases: th/T10828a-                 th/T10828b-                 th/T12478_4-                 th/T15270A-                 th/T15270B-                 th/T16895a-                 th/T16895b-                 th/T16895c-                 th/T16895d-                 th/T16895e-                 th/T17379a-                 th/T17379b-                 th/T18740d-                 th/T2597b-                 th/T2674-                 th/T3395-                 th/T7484-                 th/T7667a-                 th/TH_implicitParamsErr1-                 th/TH_implicitParamsErr2-                 th/TH_implicitParamsErr3-                 th/TH_invalid_add_top_decl-  -}-  TcRnRunSpliceFailure-    :: !(Maybe String) -- ^ Name of the function used to run the splice-    -> !RunSpliceFailReason-    -> TcRnMessage--  {-| TcRnUserErrReported is an error or warning thrown using 'qReport' from-      the 'Quasi' instance of 'TcM'.--      Example(s):--     Test cases:-  -}-  TcRnReportCustomQuasiError-    :: !Bool -- True => Error, False => Warning-    -> !String -- Error body-    -> TcRnMessage--  {-| TcRnInterfaceLookupError is an error resulting from looking up a name in an interface file.--      Example(s):--     Test cases:-  -}-  TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage--  {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance-       is missing methods that are required by the minimal definition.--       Example:-          class C a where-            foo :: a -> a-          instance C ()        -- | foo needs to be defined here--       Test cases:-         testsuite/tests/typecheck/prog001/typecheck.prog001-         testsuite/tests/typecheck/should_compile/tc126-         testsuite/tests/typecheck/should_compile/T7903-         testsuite/tests/typecheck/should_compile/tc116-         testsuite/tests/typecheck/should_compile/tc175-         testsuite/tests/typecheck/should_compile/HasKey-         testsuite/tests/typecheck/should_compile/tc125-         testsuite/tests/typecheck/should_compile/tc078-         testsuite/tests/typecheck/should_compile/tc161-         testsuite/tests/typecheck/should_fail/T5051-         testsuite/tests/typecheck/should_compile/T21583-         testsuite/tests/backpack/should_compile/bkp47-         testsuite/tests/backpack/should_fail/bkpfail25-         testsuite/tests/parser/should_compile/T2245-         testsuite/tests/parser/should_compile/read014-         testsuite/tests/indexed-types/should_compile/Class3-         testsuite/tests/indexed-types/should_compile/Simple2-         testsuite/tests/indexed-types/should_fail/T7862-         testsuite/tests/deriving/should_compile/deriving-1935-         testsuite/tests/deriving/should_compile/T9968a-         testsuite/tests/deriving/should_compile/drv003-         testsuite/tests/deriving/should_compile/T4966-         testsuite/tests/deriving/should_compile/T14094-         testsuite/tests/perf/compiler/T15304-         testsuite/tests/warnings/minimal/WarnMinimal-         testsuite/tests/simplCore/should_compile/simpl020-         testsuite/tests/deSugar/should_compile/T14546d-         testsuite/tests/ghci/scripts/T5820-         testsuite/tests/ghci/scripts/ghci019-  -}-  TcRnUnsatisfiedMinimalDef :: ClassMinimalDef -> TcRnMessage--  {- | 'TcRnMisplacedInstSig' is an error that happens when a method in-       a class instance is given a type signature, but the user has not-       enabled the @InstanceSigs@ extension.--       Test case:-       testsuite/tests/module/mod45-  -}-  TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage-  {- | 'TcRnBadBootFamInstDecl' is an error that is triggered by a-       type family instance being declared in an hs-boot file.--       Test case:-       testsuite/tests/indexed-types/should_fail/HsBootFam-  -}-  TcRnBadBootFamInstDecl :: {} -> TcRnMessage-  {- | 'TcRnIllegalFamilyInstance' is an error that occurs when an associated-       type or data family is given a top-level instance.--       Test case:-       testsuite/tests/indexed-types/should_fail/T3092-  -}-  TcRnIllegalFamilyInstance :: TyCon -> TcRnMessage-  {- | 'TcRnMissingClassAssoc' is an error that occurs when a class instance-       for a class with an associated type or data family is missing a corresponding-       family instance declaration.--       Test case:-       testsuite/tests/indexed-types/should_fail/SimpleFail7-  -}-  TcRnMissingClassAssoc :: TyCon -> TcRnMessage-  {- | 'TcRnBadFamInstDecl' is an error that is triggered by a type or data family-       instance without the @TypeFamilies@ extension.--       Test case:-       testsuite/tests/indexed-types/should_fail/BadFamInstDecl-  -}-  TcRnBadFamInstDecl :: TyCon -> TcRnMessage-  {- | 'TcRnNotOpenFamily' is an error that is triggered by attempting to give-       a top-level (open) type family instance for a closed type family.--       Test cases:-         testsuite/tests/indexed-types/should_fail/Overlap7-         testsuite/tests/indexed-types/should_fail/Overlap3-  -}-  TcRnNotOpenFamily :: TyCon -> TcRnMessage-  {-| TcRnNoRebindableSyntaxRecordDot is an error triggered by an overloaded record update-      without RebindableSyntax enabled.--      Example(s):--     Test cases: parser/should_fail/RecordDotSyntaxFail5-  -}-  TcRnNoRebindableSyntaxRecordDot :: TcRnMessage--  {-| TcRnNoFieldPunsRecordDot is an error triggered by the use of record field puns-      in an overloaded record update without enabling NamedFieldPuns.--      Example(s):-      print $ a{ foo.bar.baz.quux }--     Test cases: parser/should_fail/RecordDotSyntaxFail12-  -}-  TcRnNoFieldPunsRecordDot :: TcRnMessage--  {-| TcRnIllegalStaticExpression is an error thrown when user creates a static-      pointer via TemplateHaskell without enabling the StaticPointers extension.--      Example(s):--     Test cases: th/T14204-  -}-  TcRnIllegalStaticExpression :: HsExpr GhcPs -> TcRnMessage--  {-| TcRnIllegalStaticFormInSplice is an error when a user attempts to define-      a static pointer in a Template Haskell splice.--      Example(s):--     Test cases: th/TH_StaticPointers02-  -}-  TcRnIllegalStaticFormInSplice :: HsExpr GhcPs -> TcRnMessage--  {-| TcRnListComprehensionDuplicateBinding is an error triggered by duplicate-      let-bindings in a list comprehension.--      Example(s):-      [ () | let a = 13 | let a = 17 ]--     Test cases: typecheck/should_fail/tcfail092-  -}-  TcRnListComprehensionDuplicateBinding :: Name -> TcRnMessage--  {-| TcRnEmptyStmtsGroup is an error triggered by an empty list of statements-      in a statement block. For more information, see 'EmptyStatementGroupErrReason'--      Example(s):--        [() | then ()]--        do--        proc () -> do--     Test cases: rename/should_fail/RnEmptyStatementGroup1-  -}-  TcRnEmptyStmtsGroup:: EmptyStatementGroupErrReason -> TcRnMessage--  {-| TcRnLastStmtNotExpr is an error caused by the last statement-      in a statement block not being an expression.--      Example(s):--        do x <- pure ()--        do let x = 5--     Test cases: rename/should_fail/T6060-                 parser/should_fail/T3811g-                 parser/should_fail/readFail028-  -}-  TcRnLastStmtNotExpr-    :: HsStmtContext GhcRn-    -> UnexpectedStatement-    -> TcRnMessage--  {-| TcRnUnexpectedStatementInContext is an error when a statement appears-      in an unexpected context (e.g. an arrow statement appears in a list comprehension).--      Example(s):--     Test cases: parser/should_fail/readFail042-                 parser/should_fail/readFail038-                 parser/should_fail/readFail043-  -}-  TcRnUnexpectedStatementInContext-    :: HsStmtContext GhcRn-    -> UnexpectedStatement-    -> Maybe LangExt.Extension-    -> TcRnMessage--  {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section-      without enabling the TupleSections extension.--      Example(s):-        (5,)--     Test cases: rename/should_fail/rnfail056-  -}-  TcRnIllegalTupleSection :: TcRnMessage--  {-| TcRnIllegalImplicitParameterBindings is an error triggered by binding-      an implicit parameter in an mdo block.--      Example(s):-      mdo { let { ?x = 5 }; () }--     Test cases: rename/should_fail/RnImplicitBindInMdoNotation-  -}-  TcRnIllegalImplicitParameterBindings-    :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs)-    -> TcRnMessage--  {-| TcRnSectionWithoutParentheses is an error triggered by attempting to-      use an operator section without parentheses.--      Example(s):-      (`head` x, ())--     Test cases: rename/should_fail/T2490-                 rename/should_fail/T5657-  -}-  TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage--  {-| TcRnLoopySuperclassSolve is a warning, controlled by @-Wloopy-superclass-solve@,-      that is triggered when GHC solves a constraint in a possibly-loopy way,-      violating the class instance termination rules described in the section-      "Undecidable instances and loopy superclasses" of the user's guide.--      Example:--        class Foo f-        class Foo f => Bar f g-        instance Bar f f => Bar f (h k)--      Test cases: T20666, T20666{a,b}, T22891, T22912.-  -}-  TcRnLoopySuperclassSolve :: CtLoc    -- ^ Wanted 'CtLoc'-                           -> PredType -- ^ Wanted 'PredType'-                           -> TcRnMessage--  {- TcRnCannotDefaultConcrete is an error occurring when a concrete-    type variable cannot be defaulted.--    Test cases:-      T23153-  -}-  TcRnCannotDefaultConcrete-    :: !FixedRuntimeRepOrigin-    -> TcRnMessage---  deriving Generic---- | Things forbidden in @type data@ declarations.--- See Note [Type data declarations]-data TypeDataForbids-  = TypeDataForbidsDatatypeContexts-  | TypeDataForbidsLabelledFields-  | TypeDataForbidsStrictnessAnnotations-  | TypeDataForbidsDerivingClauses-  deriving Generic--instance Outputable TypeDataForbids where-  ppr TypeDataForbidsDatatypeContexts      = text "Data type contexts"-  ppr TypeDataForbidsLabelledFields        = text "Labelled fields"-  ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags"-  ppr TypeDataForbidsDerivingClauses       = text "Deriving clauses"--data RunSpliceFailReason-  = ConversionFail !ThingBeingConverted !ConversionFailReason-  deriving Generic---- | Identifies the TH splice attempting to be converted-data ThingBeingConverted-  = ConvDec !TH.Dec-  | ConvExp !TH.Exp-  | ConvPat !TH.Pat-  | ConvType !TH.Type---- | The reason a TH splice could not be converted to a Haskell expression-data ConversionFailReason-  = IllegalOccName !OccName.NameSpace !String-  | SumAltArityExceeded !TH.SumAlt !TH.SumArity-  | IllegalSumAlt !TH.SumAlt-  | IllegalSumArity !TH.SumArity-  | MalformedType !TypeOrKind !TH.Type-  | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs))-  | KindSigsOnlyAllowedOnGADTs-  | IllegalDeclaration !THDeclDescriptor !IllegalDecls-  | CannotMixGADTConsWith98Cons-  | EmptyStmtListInDoBlock-  | NonVarInInfixExpr-  | MultiWayIfWithoutAlts-  | CasesExprWithoutAlts-  | ImplicitParamsWithOtherBinds-  | InvalidCCallImpent !String -- ^ Source-  | RecGadtNoCons-  | GadtNoCons-  | InvalidTypeInstanceHeader !TH.Type-  | InvalidTyFamInstLHS !TH.Type-  | InvalidImplicitParamBinding-  | DefaultDataInstDecl ![LDataFamInstDecl GhcPs]-  | FunBindLacksEquations !TH.Name-  deriving Generic--data IllegalDecls-  = IllegalDecls    !(NE.NonEmpty (LHsDecl GhcPs))-  | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs))---- | Label for a TH declaration-data THDeclDescriptor-  = InstanceDecl-  | WhereClause-  | LetBinding-  | LetExpression-  | ClssDecl---- | Specifies which back ends can handle a requested foreign import or export-type ExpectedBackends = [Backend]---- | Specifies which calling convention is unsupported on the current platform-data UnsupportedCallConvention-  = StdCallConvUnsupported-  | PrimCallConvUnsupported-  | JavaScriptCallConvUnsupported-  deriving Eq---- | Whether the error pertains to a function argument or a result.-data ArgOrResult-  = Arg | Result---- | Which parts of a record field are affected by a particular error or warning.-data RecordFieldPart-  = RecordFieldConstructor !Name-  | RecordFieldPattern !Name-  | RecordFieldUpdate---- | Where a shadowed name comes from-data ShadowedNameProvenance-  = ShadowedNameProvenanceLocal !SrcLoc-    -- ^ The shadowed name is local to the module-  | ShadowedNameProvenanceGlobal [GlobalRdrElt]-    -- ^ The shadowed name is global, typically imported from elsewhere.---- | In what context did we require a type to have a fixed runtime representation?------ Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing--- representation polymorphism errors when validity checking.------ See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete-data FixedRuntimeRepProvenance-  -- | Data constructor fields must have a fixed runtime representation.-  ---  -- Tests: T11734, T18534.-  = FixedRuntimeRepDataConField--  -- | Pattern synonym signature arguments must have a fixed runtime representation.-  ---  -- Test: RepPolyPatSynArg.-  | FixedRuntimeRepPatSynSigArg--  -- | Pattern synonym signature scrutinee must have a fixed runtime representation.-  ---  -- Test: RepPolyPatSynRes.-  | FixedRuntimeRepPatSynSigRes--pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc-pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field"-pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument"-pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee"---- | Why the particular illegal newtype error arose together with more--- information, if any.-data IllegalNewtypeReason-  = DoesNotHaveSingleField !Int-  | IsNonLinear-  | IsGADT-  | HasConstructorContext-  | HasExistentialTyVar-  | HasStrictnessAnnotation-  deriving Generic---- | Why the particular injectivity error arose together with more information,--- if any.-data InjectivityErrReason-  = InjErrRhsBareTyVar [Type]-  | InjErrRhsCannotBeATypeFam-  | InjErrRhsOverlap-  | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances--data HasKinds-  = YesHasKinds-  | NoHasKinds-  deriving (Show, Eq)--hasKinds :: Bool -> HasKinds-hasKinds True  = YesHasKinds-hasKinds False = NoHasKinds--data SuggestUndecidableInstances-  = YesSuggestUndecidableInstaces-  | NoSuggestUndecidableInstaces-  deriving (Show, Eq)--suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances-suggestUndecidableInstances True  = YesSuggestUndecidableInstaces-suggestUndecidableInstances False = NoSuggestUndecidableInstaces--data SuggestUnliftedTypes-  = SuggestUnliftedNewtypes-  | SuggestUnliftedDatatypes---- | A description of whether something is a------ * @data@ or @newtype@ ('DataDeclSort')------ * @data instance@ or @newtype instance@ ('DataInstanceSort')------ * @data family@ ('DataFamilySort')------ At present, this data type is only consumed by 'checkDataKindSig'.-data DataSort-  = DataDeclSort     NewOrData-  | DataInstanceSort NewOrData-  | DataFamilySort--ppDataSort :: DataSort -> SDoc-ppDataSort data_sort = text $-  case data_sort of-    DataDeclSort     DataType -> "Data type"-    DataDeclSort     NewType  -> "Newtype"-    DataInstanceSort DataType -> "Data instance"-    DataInstanceSort NewType  -> "Newtype instance"-    DataFamilySort            -> "Data family"---- | Helper type used in 'checkDataKindSig'.------ Superficially similar to 'ContextKind', but it lacks 'AnyKind'--- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@--- provides 'LiftedKind', which is much simpler to match on and--- handle in 'isAllowedDataResKind'.-data AllowedDataResKind-  = AnyTYPEKind-  | AnyBoxedKind-  | LiftedKind---- | A data type to describe why a variable is not closed.--- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr-data NotClosedReason = NotLetBoundReason-                     | NotTypeClosed VarSet-                     | NotClosed Name NotClosedReason--data SuggestPartialTypeSignatures-  = YesSuggestPartialTypeSignatures-  | NoSuggestPartialTypeSignatures-  deriving (Show, Eq)--suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures-suggestPartialTypeSignatures True  = YesSuggestPartialTypeSignatures-suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures--data UsingGeneralizedNewtypeDeriving-  = YesGeneralizedNewtypeDeriving-  | NoGeneralizedNewtypeDeriving-  deriving Eq--usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving-usingGeneralizedNewtypeDeriving True  = YesGeneralizedNewtypeDeriving-usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving--data DeriveAnyClassEnabled-  = YesDeriveAnyClassEnabled-  | NoDeriveAnyClassEnabled-  deriving Eq--deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled-deriveAnyClassEnabled True  = YesDeriveAnyClassEnabled-deriveAnyClassEnabled False = NoDeriveAnyClassEnabled---- | Why a particular typeclass instance couldn't be derived.-data DeriveInstanceErrReason-  =-    -- | The typeclass instance is not well-kinded.-    DerivErrNotWellKinded !TyCon-                          -- ^ The type constructor that occurs in-                          -- the typeclass instance declaration.-                          !Kind-                          -- ^ The typeclass kind.-                          !Int-                          -- ^ The number of typeclass arguments that GHC-                          -- kept. See Note [tc_args and tycon arity] in-                          -- GHC.Tc.Deriv.-  -- | Generic instances can only be derived using the stock strategy-  -- in Safe Haskell.-  | DerivErrSafeHaskellGenericInst-  | DerivErrDerivingViaWrongKind !Kind !Type !Kind-  | DerivErrNoEtaReduce !Type-                        -- ^ The instance type-  -- | We cannot derive instances in boot files-  | DerivErrBootFileFound-  | DerivErrDataConsNotAllInScope !TyCon-  -- | We cannot use GND on non-newtype types-  | DerivErrGNDUsedOnData-  -- | We cannot derive instances of nullary classes-  | DerivErrNullaryClasses-  -- | Last arg must be newtype or data application-  | DerivErrLastArgMustBeApp-  | DerivErrNoFamilyInstance !TyCon [Type]-  | DerivErrNotStockDeriveable !DeriveAnyClassEnabled-  | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts-                                   !AssociatedTyLastVarInKind-                                   !AssociatedTyNotParamOverLastTyVar-  | DerivErrNewtypeNonDeriveableClass-  | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK?-  | DerivErrOnlyAnyClassDeriveable !TyCon-                                   -- ^ Type constructor for which the instance-                                   -- is requested-                                   !DeriveAnyClassEnabled-                                   -- ^ Whether or not -XDeriveAnyClass is enabled-                                   -- already.-  -- | Stock deriving won't work, but perhaps DeriveAnyClass will.-  | DerivErrNotDeriveable !DeriveAnyClassEnabled-  -- | The given 'PredType' is not a class.-  | DerivErrNotAClass !PredType-  -- | The given (representation of the) 'TyCon' has no-  -- data constructors.-  | DerivErrNoConstructors !TyCon-  | DerivErrLangExtRequired !LangExt.Extension-  -- | GHC simply doesn't how to how derive the input 'Class' for the given-  -- 'Type'.-  | DerivErrDunnoHowToDeriveForType !Type-  -- | The given 'TyCon' must be an enumeration.-  -- See Note [Enumeration types] in GHC.Core.TyCon-  | DerivErrMustBeEnumType !TyCon-  -- | The given 'TyCon' must have /precisely/ one constructor.-  | DerivErrMustHaveExactlyOneConstructor !TyCon-  -- | The given data type must have some parameters.-  | DerivErrMustHaveSomeParameters !TyCon-  -- | The given data type must not have a class context.-  | DerivErrMustNotHaveClassContext !TyCon !ThetaType-  -- | We couldn't derive an instance for a particular data constructor-  -- for a variety of reasons.-  | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor]-  -- | We couldn't derive a 'Generic' instance for the given type for a-  -- variety of reasons-  | DerivErrGenerics [DeriveGenericsErrReason]-  -- | We couldn't derive an instance either because the type was not an-  -- enum type or because it did have more than one constructor.-  | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason-  deriving Generic--data DeriveInstanceBadConstructor-  =-  -- | The given 'DataCon' must be truly polymorphic in the-  -- last argument of the data type.-    DerivErrBadConExistential !DataCon-  -- | The given 'DataCon' must not use the type variable in a function argument"-  | DerivErrBadConCovariant !DataCon-  -- | The given 'DataCon' must not contain function types-  | DerivErrBadConFunTypes !DataCon-  -- | The given 'DataCon' must use the type variable only-  -- as the last argument of a data type-  | DerivErrBadConWrongArg !DataCon-  -- | The given 'DataCon' is a GADT so we cannot directly-  -- derive an istance for it.-  | DerivErrBadConIsGADT !DataCon-  -- | The given 'DataCon' has existentials type vars in its type.-  | DerivErrBadConHasExistentials !DataCon-  -- | The given 'DataCon' has constraints in its type.-  | DerivErrBadConHasConstraints !DataCon-  -- | The given 'DataCon' has a higher-rank type.-  | DerivErrBadConHasHigherRankType !DataCon--data DeriveGenericsErrReason-  = -- | The type must not have some datatype context.-    DerivErrGenericsMustNotHaveDatatypeContext !TyCon-    -- | The data constructor must not have exotic unlifted-    -- or polymorphic arguments.-  | DerivErrGenericsMustNotHaveExoticArgs !DataCon-    -- | The data constructor must be a vanilla constructor.-  | DerivErrGenericsMustBeVanillaDataCon  !DataCon-    -- | The type must have some type parameters.-    -- check (d) from Note [Requirements for deriving Generic and Rep]-    -- in GHC.Tc.Deriv.Generics.-  | DerivErrGenericsMustHaveSomeTypeParams !TyCon-    -- | The data constructor must not have existential arguments.-  | DerivErrGenericsMustNotHaveExistentials !DataCon-    -- | The derivation applies a type to an argument involving-    -- the last parameter but the applied type is not of kind * -> *.-  | DerivErrGenericsWrongArgKind !DataCon--data HasWildcard-  = YesHasWildcard-  | NoHasWildcard-  deriving Eq--hasWildcard :: Bool -> HasWildcard-hasWildcard True  = YesHasWildcard-hasWildcard False = NoHasWildcard---- | A context in which we don't allow anonymous wildcards.-data BadAnonWildcardContext-  = WildcardNotLastInConstraint-  | ExtraConstraintWildcardNotAllowed-      SoleExtraConstraintWildcardAllowed-  | WildcardsNotAllowedAtAll---- | Whether a sole extra-constraint wildcard is allowed,--- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@.-data SoleExtraConstraintWildcardAllowed-  = SoleExtraConstraintWildcardNotAllowed-  | SoleExtraConstraintWildcardAllowed---- | A type representing whether or not the input type has associated data family instances.-data HasAssociatedDataFamInsts-  = YesHasAdfs-  | NoHasAdfs-  deriving Eq--hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts-hasAssociatedDataFamInsts True = YesHasAdfs-hasAssociatedDataFamInsts False = NoHasAdfs---- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass--- contains the last type variable of the class in a kind, which is not (yet) allowed--- by GHC.-data AssociatedTyLastVarInKind-  = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class-  | NoAssocTyLastVarInKind-  deriving Eq--associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind-associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc-associatedTyLastVarInKind Nothing   = NoAssocTyLastVarInKind---- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a--- typeclass is not parameterized over the last type variable of the class-data AssociatedTyNotParamOverLastTyVar-  = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class-  | NoAssociatedTyNotParamOverLastTyVar-  deriving Eq--associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar-associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc-associatedTyNotParamOverLastTyVar Nothing   = NoAssociatedTyNotParamOverLastTyVar---- | What kind of thing is missing a type signature?------ Used for reporting @"missing signature"@ warnings, see--- 'tcRnMissingSignature'.-data MissingSignature-  = MissingTopLevelBindingSig Name Type-  | MissingPatSynSig PatSyn-  | MissingTyConKindSig-      TyCon-      Bool -- ^ whether -XCUSKs is enabled---- | Is the object we are dealing with exported or not?------ Used for reporting @"missing signature"@ warnings, see--- 'TcRnMissingSignature'.-data Exported-  = IsNotExported-  | IsExported--instance Outputable Exported where-  ppr IsNotExported = text "IsNotExported"-  ppr IsExported    = text "IsExported"----------------------------------------------------------------------------------------     Errors used in GHC.Tc.Errors--------------------------------------------------------------------------------------{- Note [Error report]-~~~~~~~~~~~~~~~~~~~~~~-The idea is that error msgs are divided into three parts: the main msg, the-context block ("In the second argument of ..."), and the relevant bindings-block, which are displayed in that order, with a mark to divide them. The-the main msg ('report_important') varies depending on the error-in question, but context and relevant bindings are always the same, which-should simplify visual parsing.--See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'.--}---- | A collection of main error messages and supplementary information.------ In practice, we will:---  - display the important messages first,---  - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'),---  - then the supplementary information (e.g. relevant bindings, valid hole fits),---  - then the hints ("Possible fix: ...").------ So this is mostly just a way of making sure that the error context appears--- early on rather than at the end of the message.------ See Note [Error report] for details.-data SolverReport-  = SolverReport-  { sr_important_msg :: SolverReportWithCtxt-  , sr_supplementary :: [SolverReportSupplementary]-  , sr_hints         :: [GhcHint]-  }---- | Additional information to print in a 'SolverReport', after the--- important messages and after the error context.------ See Note [Error report].-data SolverReportSupplementary-  = SupplementaryBindings RelevantBindings-  | SupplementaryHoleFits ValidHoleFits-  | SupplementaryCts      [(PredType, RealSrcSpan)]---- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints)--- that are needed in order to report it.-data SolverReportWithCtxt =-  SolverReportWithCtxt-    { reportContext :: SolverReportErrCtxt-       -- ^ Context for what we wish to report.-       -- This can change as we enter implications, so is-       -- stored alongside the content.-    , reportContent :: TcSolverReportMsg-      -- ^ The content of the message to report.-    }-  deriving Generic---- | Context needed when reporting a 'TcSolverReportMsg', such as--- the enclosing implication constraints or whether we are deferring type errors.-data SolverReportErrCtxt-    = CEC { cec_encl :: [Implication]  -- ^ Enclosing implications-                                       --   (innermost first)-                                       -- ic_skols and givens are tidied, rest are not-          , cec_tidy  :: TidyEnv--          , cec_binds :: EvBindsVar    -- ^ We make some errors (depending on cec_defer)-                                       -- into warnings, and emit evidence bindings-                                       -- into 'cec_binds' for unsolved constraints--          , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime--          -- We might throw a warning on an error when encountering a hole,-          -- depending on the type of hole (expression hole, type hole, out of scope hole).-          -- We store the reasons for reporting a diagnostic for each type of hole.-          , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions.-          , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types.-          , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes.--          , cec_warn_redundant :: Bool    -- ^ True <=> -Wredundant-constraints-          , cec_expand_syns    :: Bool    -- ^ True <=> -fprint-expanded-synonyms--          , cec_suppress :: Bool    -- ^ True <=> More important errors have occurred,-                                    --            so create bindings if need be, but-                                    --            don't issue any more errors/warnings-                                    -- See Note [Suppressing error messages]-      }--getUserGivens :: SolverReportErrCtxt -> [UserGiven]--- One item for each enclosing implication-getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics------------------------------------------------------------------------------------   ErrorItem------------------------------------------------------------------------------------ | A predicate with its arising location; used to encapsulate a constraint--- that will give rise to a diagnostic.-data ErrorItem--- We could perhaps use Ct here (and indeed used to do exactly that), but--- having a separate type gives to denote errors-in-formation gives us--- a nice place to do pre-processing, such as calculating ei_suppress.--- Perhaps some day, an ErrorItem could eventually evolve to contain--- the error text (or some representation of it), so we can then have all--- the errors together when deciding which to report.-  = EI { ei_pred     :: PredType         -- report about this-         -- The ei_pred field will never be an unboxed equality with-         -- a (casted) tyvar on the right; this is guaranteed by the solver-       , ei_evdest   :: Maybe TcEvDest-         -- ^ for Wanteds, where to put the evidence-         --   for Givens, Nothing-       , ei_flavour  :: CtFlavour-       , ei_loc      :: CtLoc-       , ei_m_reason :: Maybe CtIrredReason  -- if this ErrorItem was made from a-                                             -- CtIrred, this stores the reason-       , ei_suppress :: Bool    -- Suppress because of Note [Wanteds rewrite Wanteds]-                                -- in GHC.Tc.Constraint-       }--instance Outputable ErrorItem where-  ppr (EI { ei_pred     = pred-          , ei_evdest   = m_evdest-          , ei_flavour  = flav-          , ei_suppress = supp })-    = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred-    where-      pp_dest Nothing   = empty-      pp_dest (Just ev) = ppr ev <+> dcolon--      pp_supp = if supp then text "suppress:" else empty--errorItemOrigin :: ErrorItem -> CtOrigin-errorItemOrigin = ctLocOrigin . ei_loc--errorItemEqRel :: ErrorItem -> EqRel-errorItemEqRel = predTypeEqRel . ei_pred--errorItemCtLoc :: ErrorItem -> CtLoc-errorItemCtLoc = ei_loc--errorItemPred :: ErrorItem -> PredType-errorItemPred = ei_pred--{- Note [discardProvCtxtGivens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In most situations we call all enclosing implications "useful". There is one-exception, and that is when the constraint that causes the error is from the-"provided" context of a pattern synonym declaration:--  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a-             --  required      => provided => type-  pattern Pat x <- (Just x, 4)--When checking the pattern RHS we must check that it does actually bind all-the claimed "provided" constraints; in this case, does the pattern (Just x, 4)-bind the (Show a) constraint.  Answer: no!--But the implication we generate for this will look like-   forall a. (Num a, Eq a) => [W] Show a-because when checking the pattern we must make the required-constraints available, since they are needed to match the pattern (in-this case the literal '4' needs (Num a, Eq a)).--BUT we don't want to suggest adding (Show a) to the "required" constraints-of the pattern synonym, thus:-  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a-It would then typecheck but it's silly.  We want the /pattern/ to bind-the alleged "provided" constraints, Show a.--So we suppress that Implication in discardProvCtxtGivens.  It's-painfully ad-hoc but the truth is that adding it to the "required"-constraints would work.  Suppressing it solves two problems.  First,-we never tell the user that we could not deduce a "provided"-constraint from the "required" context. Second, we never give a-possible fix that suggests to add a "provided" constraint to the-"required" context.--For example, without this distinction the above code gives a bad error-message (showing both problems):--  error: Could not deduce (Show a) ... from the context: (Eq a)-         ... Possible fix: add (Show a) to the context of-         the signature for pattern synonym `Pat' ...--}---discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]-discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]-  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig-  = filterOut (discard name) givens-  | otherwise-  = givens-  where-    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'-    discard _ _                                                  = False----- | An error reported after constraint solving.--- This is usually, some sort of unsolved constraint error,--- but we try to be specific about the precise problem we encountered.-data TcSolverReportMsg-  -- | Quantified variables appear out of dependency order.-  ---  -- Example:-  ---  --   forall (a :: k) k. ...-  ---  -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451.-  = BadTelescope TyVarBndrs [TyCoVar]--  -- | We came across a custom type error and we have decided to report it.-  ---  -- Example:-  ---  --   type family F a where-  --     F a = TypeError (Text "error")-  ---  --   err :: F ()-  --   err = ()-  ---  -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104.-  | UserTypeError Type--  -- | We want to report an out of scope variable or a typed hole.-  -- See 'HoleError'.-  | ReportHoleError Hole HoleError--  -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope.-  ---  -- Test case: Simple14-  | UntouchableVariable-    { untouchableTyVar :: TyVar-    , untouchableTyVarImplication :: Implication-    }--  -- | Cannot unify a variable, because of a type mismatch.-  | CannotUnifyVariable-    { mismatchMsg         :: MismatchMsg-    , cannotUnifyReason   :: CannotUnifyVariableReason }--  -- | A mismatch between two types.-  | Mismatch-     { mismatchMsg           :: MismatchMsg-     , mismatchTyVarInfo     :: Maybe TyVarInfo-     , mismatchAmbiguityInfo :: [AmbiguityInfo]-     , mismatchCoercibleInfo :: Maybe CoercibleMsg }--   -- | A violation of the representation-polymorphism invariants.-   ---   -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information.-  | FixedRuntimeRepError [FixedRuntimeRepErrorInfo]--  -- | 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.Canonical,-    -- wrinkle (2). 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:-  ---  --    instance Eq Maybe where {..}-  ---  -- Test case: T11563.-  | ExpectingMoreArguments Int TypedThing--  -- | Trying to use an unbound implicit parameter.-  ---  -- Example:-  ---  --    foo :: Int-  --    foo = ?param-  ---  -- Test case: tcfail130.-  | UnboundImplicitParams-      (NE.NonEmpty ErrorItem)--  -- | A constraint couldn't be solved because it contains-  -- ambiguous type variables.-  ---  -- Example:-  ---  --   class C a b where-  --     f :: (a,b)-  ---  --   x = fst f-  ---  ---  -- Test case: T4921.-  | AmbiguityPreventsSolvingCt-      ErrorItem -- ^ always a class constraint-      ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively--  -- | Could not solve a constraint; there were several unifying candidate instances-  -- but no matching instances. This is used to report as much useful information-  -- as possible about why we couldn't choose any instance, e.g. because of-  -- ambiguous type variables.-  | CannotResolveInstance-    { 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.--  -- | Could not solve a constraint using available instances-  -- because the instances overlap.-  ---  -- Test cases: tcfail118, tcfail121, tcfail218.-  | OverlappingInstances-    { overlappingInstances_item     :: ErrorItem-    , overlappingInstances_matches  :: NE.NonEmpty ClsInst-    , overlappingInstances_unifiers :: [ClsInst] }--  -- | Could not solve a constraint from instances because-  -- instances declared in a Safe module cannot overlap instances-  -- from other modules (with -XSafeHaskell).-  ---  -- Test cases: SH_Overlap{1,2,5,6,7,11}.-  | UnsafeOverlap-    { unsafeOverlap_item    :: ErrorItem-    , unsafeOverlap_match   :: ClsInst-    , unsafeOverlapped      :: NE.NonEmpty ClsInst }--  deriving Generic--data MismatchMsg-  =  -- | Couldn't unify two types or kinds.-  ---  --  Example:-  ---  --    3 + 3# -- can't match a lifted type with an unlifted type-  ---  --  Test cases: T1396, T8263, ...-    BasicMismatch-      { mismatch_ea           :: MismatchEA  -- ^ Should this be phrased in terms of expected vs actual?-      , mismatch_item         :: ErrorItem   -- ^ The constraint in which the mismatch originated.-      , mismatch_ty1          :: Type        -- ^ First type (the expected type if if mismatch_ea is True)-      , mismatch_ty2          :: Type        -- ^ Second type (the actual type if mismatch_ea is True)-      , mismatch_whenMatching :: Maybe WhenMatching-      , mismatch_mb_same_occ  :: Maybe SameOccInfo-      }--  -- | A type has an unexpected kind.-  ---  -- Test cases: T2994, T7609, ...-  | KindMismatch-      { kmismatch_what     :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of?-      , kmismatch_expected :: Type-      , kmismatch_actual   :: Type-      }-    -- TODO: combine with 'BasicMismatch'.--  -- | A mismatch between two types, which arose from a type equality.-  ---  -- Test cases: T1470, tcfail212.-  | TypeEqMismatch-      { teq_mismatch_ppr_explicit_kinds :: Bool-      , teq_mismatch_item     :: ErrorItem-      , teq_mismatch_ty1      :: Type-      , teq_mismatch_ty2      :: Type-      , teq_mismatch_expected :: Type -- ^ The overall expected type-      , teq_mismatch_actual   :: Type -- ^ The overall actual type-      , teq_mismatch_what     :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of?-      , teq_mb_same_occ       :: Maybe SameOccInfo-      }-    -- TODO: combine with 'BasicMismatch'.--  -- | Couldn't solve some Wanted constraints using the Givens.-  -- Used for messages such as @"No instance for ..."@ and-  -- @"Could not deduce ... from"@.-  | CouldNotDeduce-     { cnd_user_givens :: [Implication]-        -- | The Wanted constraints we couldn't solve.-        ---        -- N.B.: the 'ErrorItem' at the head of the list has been tidied,-        -- perhaps not the others.-     , cnd_wanted      :: NE.NonEmpty ErrorItem--       -- | Some additional info consumed by 'mk_supplementary_ea_msg'.-     , cnd_extra       :: Maybe CND_Extra-     }-  deriving Generic---- | Construct a basic mismatch message between two types.------ See 'pprMismatchMsg' for how such a message is displayed to users.-mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg-mkBasicMismatchMsg ea item ty1 ty2-  = BasicMismatch-      { mismatch_ea           = ea-      , mismatch_item         = item-      , mismatch_ty1          = ty1-      , mismatch_ty2          = ty2-      , mismatch_whenMatching = Nothing-      , mismatch_mb_same_occ  = Nothing-      }---- | Whether to use expected/actual in a type mismatch message.-data MismatchEA-  -- | Don't use expected/actual.-  = NoEA-  -- | Use expected/actual.-  | EA-  { mismatch_mbEA :: Maybe ExpectedActualInfo-    -- ^ Whether to also mention type synonym expansion.-  }--data CannotUnifyVariableReason-  =  -- | A type equality between a type variable and a polytype.-    ---    -- Test cases: T12427a, T2846b, T10194, ...-    CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo)--  -- | An occurs check.-  | OccursCheck-    { occursCheckInterestingTyVars :: [TyVar]-    , occursCheckAmbiguityInfos    :: [AmbiguityInfo] }--  -- | A skolem type variable escapes its scope.-  ---  -- Example:-  ---  --   data Ex where { MkEx :: a -> MkEx }-  --   foo (MkEx x) = x-  ---  -- Test cases: TypeSkolEscape, T11142.-  | SkolemEscape ErrorItem Implication [TyVar]--  -- | Can't unify the type variable with the other type-  -- due to the kind of type variable it is.-  ---  -- For example, trying to unify a 'SkolemTv' with the-  -- type Int, or with a 'TyVarTv'.-  | DifferentTyVars TyVarInfo-  | RepresentationalEq TyVarInfo (Maybe CoercibleMsg)-  deriving Generic---- | Report a mismatch error without any extra--- information.-mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg-mkPlainMismatchMsg msg-  = Mismatch-     { mismatchMsg           = msg-     , mismatchTyVarInfo     = Nothing-     , mismatchAmbiguityInfo = []-     , mismatchCoercibleInfo = Nothing }---- | Additional information to be given in a 'CouldNotDeduce' message,--- which is then passed on to 'mk_supplementary_ea_msg'.-data CND_Extra = CND_Extra TypeOrKind Type Type---- | A cue to print out information about type variables,--- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@.-data TyVarInfo =-  TyVarInfo { thisTyVar :: TyVar-            , thisTyVarIsUntouchable :: Maybe Implication-            , otherTy   :: Maybe TyVar }---- | Add some information to disambiguate errors in which--- two 'Names' would otherwise appear to be identical.------ See Note [Disambiguating (X ~ X) errors].-data SameOccInfo-  = SameOcc-    { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package.-    , sameOcc_lhs :: Name-    , sameOcc_rhs :: Name }---- | Add some information about ambiguity-data AmbiguityInfo--  -- | Some type variables remained ambiguous: print them to the user.-  = Ambiguity-    { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..."-                                  --  False <=> create a message of the form "The type variable is ambiguous."-    , ambig_tyvars        :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively.-                                                -- Guaranteed to not both be empty.-    }--  -- | Remind the user that a particular type family is not injective.-  | NonInjectiveTyFam TyCon---- | Expected/actual information.-data ExpectedActualInfo-  -- | Display the expected and actual types.-  = ExpectedActual-     { ea_expected, ea_actual :: Type }--  -- | Display the expected and actual types, after expanding type synonyms.-  | ExpectedActualAfterTySynExpansion-     { ea_expanded_expected, ea_expanded_actual :: Type }---- | Explain how a kind equality originated.-data WhenMatching--  = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind)-  deriving Generic---- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole'--- constructor of 'HoleError'.-data NotInScopeError--  -- | A run-of-the-mill @"not in scope"@ error.-  = NotInScope--  -- | An exact 'Name' was not in scope.-  ---  -- This usually indicates a problem with a Template Haskell splice.-  ---  -- Test cases: T5971, T18263.-  | NoExactName Name--  -- The same exact 'Name' occurs in multiple name-spaces.-  ---  -- This usually indicates a problem with a Template Haskell splice.-  ---  -- Test case: T7241.-  | SameName [GlobalRdrElt] -- ^ always at least 2 elements--  -- A type signature, fixity declaration, pragma, standalone kind signature...-  -- is missing an associated binding.-  | MissingBinding SDoc [GhcHint]-    -- TODO: remove the SDoc argument.--  -- | Couldn't find a top-level binding.-  ---  -- Happens when specifying an annotation for something that-  -- is not in scope.-  ---  -- Test cases: annfail01, annfail02, annfail11.-  | NoTopLevelBinding--  -- | A class doesn't have a method with this name,-  -- or, a class doesn't have an associated type with this name,-  -- or, a record doesn't have a record field with this name.-  | UnknownSubordinate SDoc-  deriving Generic---- | Create a @"not in scope"@ error message for the given 'RdrName'.-mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage-mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints---- | Configuration for pretty-printing valid hole fits.-data HoleFitDispConfig =-  HFDC { showWrap, showWrapVars, showType, showProv, showMatches-          :: Bool }---- | Report an error involving a 'Hole'.------ This could be an out of scope data constructor or variable,--- a typed hole, or a wildcard in a type.-data HoleError-  -- | Report an out-of-scope data constructor or variable-  -- masquerading as an expression hole.-  ---  -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint.-  -- See 'NotInScopeError' for other not-in-scope errors.-  ---  -- Test cases: T9177a.-  = OutOfScopeHole [ImportError]-  -- | Report a typed hole, or wildcard, with additional information.-  | HoleError HoleSort-              [TcTyVar]                     -- Other type variables which get computed on the way.-              [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole.---- | A message that aims to explain why two types couldn't be seen--- to be representationally equal.-data CoercibleMsg-  -- | Not knowing the role of a type constructor prevents us from-  -- concluding that two types are representationally equal.-  ---  -- Example:-  ---  --   foo :: Applicative m => m (Sum Int)-  --   foo = coerce (pure $ 1 :: Int)-  ---  -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`.-  ---  -- Test cases: T8984, TcCoercibleFail.-  = UnknownRoles Type--  -- | The fact that a 'TyCon' is abstract prevents us from decomposing-  -- a 'TyConApp' and deducing that two types are representationally equal.-  ---  -- Test cases: none.-  | TyConIsAbstract TyCon--  -- | We can't unwrap a newtype whose constructor is not in scope.-  ---  -- Example:-  ---  --   import Data.Ord (Down) -- NB: not importing the constructor-  --   foo :: Int -> Down Int-  --   foo = coerce-  ---  -- Test cases: TcCoercibleFail.-  | OutOfScopeNewtypeConstructor TyCon DataCon---- | Explain a problem with an import.-data ImportError-  -- | 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---- | This datatype collates instances that match or unifier,--- in order to report an error message for an unsolved typeclass constraint.-data PotentialInstances-  = PotentialInstances-  { matches  :: [ClsInst]-  , unifiers :: [ClsInst]-  }---- | A collection of valid hole fits or refinement fits,--- in which some fits might have been suppressed.-data FitsMbSuppressed-  = Fits-    { fits           :: [HoleFit]-    , fitsSuppressed :: Bool  -- ^ Whether we have suppressed any fits because there were too many.-    }---- | A collection of hole fits and refinement fits.-data ValidHoleFits-  = ValidHoleFits-    { holeFits       :: FitsMbSuppressed-    , refinementFits :: FitsMbSuppressed-    }--noValidHoleFits :: ValidHoleFits-noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False)--data RelevantBindings-  = RelevantBindings-    { relevantBindingNamesAndTys :: [(Name, Type)]-    , ranOutOfFuel               :: Bool -- ^ Whether we ran out of fuel generating the bindings.-    }---- | Display some relevant bindings.-pprRelevantBindings :: RelevantBindings -> SDoc--- This function should be in "GHC.Tc.Errors.Ppr",--- but it's here for the moment as it's needed in "GHC.Tc.Errors".-pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) =-  ppUnless (null rel_bds) $-    hang (text "Relevant bindings include")-       2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg)-  where-    ppr_binding (nm, tidy_ty) =-      sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty-          , nest 2 (parens (text "bound at"-               <+> ppr (getSrcLoc nm)))]-    rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds--discardMsg :: SDoc-discardMsg = text "(Some bindings suppressed;" <+>-             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"--data PromotionErr-  = TyConPE          -- TyCon used in a kind before we are ready-                     --     data T :: T -> * where ...-  | ClassPE          -- Ditto Class--  | FamDataConPE     -- Data constructor for a data family-                     -- See Note [AFamDataCon: not promoting data family constructors]-                     -- in GHC.Tc.Utils.Env.-  | ConstrainedDataConPE PredType-                     -- Data constructor with a non-equality context-                     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-  | PatSynPE         -- Pattern synonyms-                     -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env--  | RecDataConPE     -- Data constructor in a recursive loop-                     -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl-  | TermVariablePE   -- See Note [Promoted variables in types]-  | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)--instance Outputable PromotionErr where-  ppr ClassPE                     = text "ClassPE"-  ppr TyConPE                     = text "TyConPE"-  ppr PatSynPE                    = text "PatSynPE"-  ppr FamDataConPE                = text "FamDataConPE"-  ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE"-                                      <+> parens (ppr pred)-  ppr RecDataConPE                = text "RecDataConPE"-  ppr NoDataKindsDC               = text "NoDataKindsDC"-  ppr TermVariablePE              = text "TermVariablePE"--pprPECategory :: PromotionErr -> SDoc-pprPECategory = text . capitalise . peCategory--peCategory :: PromotionErr -> String-peCategory ClassPE                = "class"-peCategory TyConPE                = "type constructor"-peCategory PatSynPE               = "pattern synonym"-peCategory FamDataConPE           = "data constructor"-peCategory ConstrainedDataConPE{} = "data constructor"-peCategory RecDataConPE           = "data constructor"-peCategory NoDataKindsDC          = "data constructor"-peCategory TermVariablePE         = "term variable"---- | Stores the information to be reported in a representation-polymorphism--- error message.-data FixedRuntimeRepErrorInfo-  = FRR_Info-  { frr_info_origin       :: FixedRuntimeRepOrigin-      -- ^ What is the original type we checked for-      -- representation-polymorphism, and what specific-      -- check did we perform?-  , frr_info_not_concrete :: Maybe (TcTyVar, TcType)-      -- ^ Which non-concrete type did we try to-      -- unify this concrete type variable with?-  }--{--************************************************************************-*                                                                      *-\subsection{Contexts for renaming errors}-*                                                                      *-************************************************************************--}---- AZ:TODO: Change these all to be Name instead of RdrName.---          Merge TcType.UserTypeContext in to it.-data HsDocContext-  = TypeSigCtx SDoc-  | StandaloneKindSigCtx SDoc-  | PatCtx-  | SpecInstSigCtx-  | DefaultDeclCtx-  | ForeignDeclCtx (LocatedN RdrName)-  | DerivDeclCtx-  | RuleCtx FastString-  | TyDataCtx (LocatedN RdrName)-  | TySynCtx (LocatedN RdrName)-  | TyFamilyCtx (LocatedN RdrName)-  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance-  | ConDeclCtx [LocatedN Name]-  | ClassDeclCtx (LocatedN RdrName)-  | ExprWithTySigCtx-  | TypBrCtx-  | HsTypeCtx-  | HsTypePatCtx-  | GHCiCtx-  | SpliceTypeCtx (LHsType GhcPs)-  | ClassInstanceCtx-  | GenericCtx SDoc---- | Context for a mismatch in the number of arguments-data MatchArgsContext-  = EquationArgs-      !Name -- ^ Name of the function-  | PatternArgs-      !(HsMatchContext GhcTc) -- ^ Pattern match specifics---- | The information necessary to report mismatched--- numbers of arguments in a match group.-data MatchArgBadMatches where-  MatchArgMatches-    ::  { matchArgFirstMatch :: LocatedA (Match GhcRn body)-        , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) }-    -> MatchArgBadMatches---- | The phase in which an exception was encountered when dealing with a TH splice-data SplicePhase-  = SplicePhase_Run-  | SplicePhase_CompileAndLink--data LookupTHInstNameErrReason-  = NoMatchesFound-  | CouldNotDetermineInstance--data UnrepresentableTypeDescr-  = LinearInvisibleArgument-  | CoercionsInTypes---- | The context for an "empty statement group" error.-data EmptyStatementGroupErrReason-  = EmptyStmtsGroupInParallelComp-  -- ^ Empty statement group in a parallel list comprehension-  | EmptyStmtsGroupInTransformListComp-  -- ^ Empty statement group in a transform list comprehension-  ---  --   Example:-  --   [() | then ()]-  | EmptyStmtsGroupInDoNotation HsDoFlavour-  -- ^ Empty statement group in do notation-  ---  --   Example:-  --   do-  | EmptyStmtsGroupInArrowNotation-  -- ^ Empty statement group in arrow notation-  ---  --   Example:-  --   proc () -> do--  deriving (Generic)---- | An existential wrapper around @'StmtLR' GhcPs GhcPs body@.-data UnexpectedStatement where-  UnexpectedStatement-    :: Outputable (StmtLR GhcPs GhcPs body)-    => StmtLR GhcPs GhcPs body-    -> UnexpectedStatement+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Tc.Errors.Types (+  -- * Main types+    TcRnMessage(..)+  , TcRnMessageOpts(..)+  , mkTcRnUnknownMessage+  , TcRnMessageDetailed(..), ErrInfo(..)+  , TypeDataForbids(..)+  , FixedRuntimeRepProvenance(..)+  , pprFixedRuntimeRepProvenance+  , ShadowedNameProvenance(..)+  , ResolvedNameInfo(..)+  , pprResolvedNameProvenance+  , RecordFieldPart(..)+  , IllegalNewtypeReason(..)+  , BadRecordUpdateReason(..)+  , InjectivityErrReason(..)+  , HasKinds(..)+  , hasKinds+  , SuggestUndecidableInstances(..)+  , suggestUndecidableInstances+  , SuggestUnliftedTypes(..)+  , DataSort(..), ppDataSort+  , AllowedDataResKind(..)+  , NotClosedReason(..)+  , SuggestPartialTypeSignatures(..)+  , suggestPartialTypeSignatures+  , DeriveInstanceErrReason(..)+  , UsingGeneralizedNewtypeDeriving(..)+  , usingGeneralizedNewtypeDeriving+  , DeriveAnyClassEnabled(..)+  , deriveAnyClassEnabled+  , DeriveInstanceBadConstructor(..)+  , HasWildcard(..)+  , hasWildcard+  , BadAnonWildcardContext(..)+  , SoleExtraConstraintWildcardAllowed(..)+  , DeriveGenericsErrReason(..)+  , HasAssociatedDataFamInsts(..)+  , hasAssociatedDataFamInsts+  , AssociatedTyLastVarInKind(..)+  , associatedTyLastVarInKind+  , AssociatedTyNotParamOverLastTyVar(..)+  , associatedTyNotParamOverLastTyVar+  , MissingSignature(..)+  , Exported(..)+  , HsDocContext(..)+  , FixedRuntimeRepErrorInfo(..)+  , TcRnNoDerivStratSpecifiedInfo(..)++  , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc++  , SolverReport(..), SupplementaryInfo(..)+  , SolverReportWithCtxt(..)+  , SolverReportErrCtxt(..)+  , getUserGivens, discardProvCtxtGivens+  , TcSolverReportMsg(..)+  , CannotUnifyVariableReason(..)+  , MismatchMsg(..)+  , MismatchEA(..)+  , mkPlainMismatchMsg, mkBasicMismatchMsg+  , WhenMatching(..)+  , ExpectedActualInfo(..)+  , TyVarInfo(..), SameOccInfo(..)+  , AmbiguityInfo(..)+  , CND_Extra(..)+  , FitsMbSuppressed(..)+  , ValidHoleFits(..), noValidHoleFits+  , HoleFitDispConfig(..)+  , RelevantBindings(..), pprRelevantBindings+  , PromotionErr(..), pprPECategory, peCategory+  , TermLevelUseErr(..), teCategory+  , NotInScopeError(..)+  , Subordinate(..), pprSubordinate+  , ImportError(..)+  , WhatLooking(..)+  , lookingForSubordinate+  , HoleError(..)+  , CoercibleMsg(..)+  , PotentialInstances(..)+  , UnsupportedCallConvention(..)+  , ExpectedBackends+  , ArgOrResult(..)+  , MatchArgsContext(..), MatchArgBadMatches(..)+  , PragmaWarningInfo(..)+  , EmptyStatementGroupErrReason(..)+  , UnexpectedStatement(..)+  , DeclSort(..)+  , NonStandardGuards(..)+  , RuleLhsErrReason(..)+  , HsigShapeMismatchReason(..)+  , WrongThingSort(..)+  , LevelCheckReason(..)+  , UninferrableTyVarCtx(..)+  , PatSynInvalidRhsReason(..)+  , BadFieldAnnotationReason(..)+  , SuperclassCycle(..)+  , SuperclassCycleDetail(..)+  , RoleValidationFailedReason(..)+  , DisabledClassExtension(..)+  , TyFamsDisabledReason(..)+  , BadInvisPatReason(..)+  , BadEmptyCaseReason(..)+  , HsTypeOrSigType(..)+  , HsTyVarBndrExistentialFlag(..)+  , TySynCycleTyCons+  , BadImportKind(..)+  , DodgyImportsReason (..)+  , ImportLookupExtensions (..)+  , ImportLookupReason (..)+  , UnusedImportReason (..)+  , UnusedImportName (..)+  , NestedForallsContextsIn(..)+  , UnusedNameProv(..)+  , NonCanonicalDefinition(..)+  , NonCanonical_Monoid(..)+  , NonCanonical_Monad(..)+  , TypeSyntax(..)+  , typeSyntaxExtension++    -- * Errors for hs-boot and signature files+  , BadBootDecls(..)+  , MissingBootThing(..), missingBootThing+  , BootMismatch(..)+  , BootMismatchWhat(..)+  , BootTyConMismatch(..)+  , BootAxiomBranchMismatch(..)+  , BootClassMismatch(..)+  , BootMethodMismatch(..)+  , BootATMismatch(..)+  , BootDataMismatch(..)+  , BootDataConMismatch(..)+  , SynAbstractDataError(..)+  , BootListMismatch(..), BootListMismatches++    -- * Class and family instance errors+  , IllegalInstanceReason(..)+  , IllegalClassInstanceReason(..)+  , IllegalInstanceHeadReason(..)+  , IllegalHasFieldInstance(..)+  , CoverageProblem(..), FailedCoverageCondition(..)+  , IllegalFamilyInstanceReason(..)+  , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..)+  , InvalidAssoc(..), InvalidAssocInstance(..)+  , InvalidAssocDefault(..), AssocDefaultBadArgs(..)+  , InstHeadNonClassHead(..)++    -- * Template Haskell errors+  , THError(..), THSyntaxError(..), THNameError(..)+  , THReifyError(..), TypedTHError(..)+  , SpliceFailReason(..), RunSpliceFailReason(..)+  , AddTopDeclsError(..)+  , ConversionFailReason(..)+  , UnrepresentableTypeDescr(..)+  , LookupTHInstNameErrReason(..)+  , SplicePhase(..)+  , THDeclDescriptor(..)+  , ThingBeingConverted(..)+  , IllegalDecls(..)++  -- * Zonker errors+  , ZonkerMessage(..)++  -- * FFI Errors+  , IllegalForeignTypeReason(..)+  , TypeCannotBeMarshaledReason(..)++  -- * Error contexts+  , ErrCtxtMsg(..)+  ) where++import GHC.Prelude++import GHC.Hs++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.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(..), 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.SourceFile (HsBootOrSig(..))+import GHC.Types.SrcLoc+import GHC.Types.TyThing (TyThing)+import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar, Specificity)+import GHC.Types.Var.Env (TidyEnv)+import GHC.Types.Var.Set (TyVarSet, VarSet)+import GHC.Types.DefaultEnv (ClassDefaults)++import GHC.Unit.Types (Module)+import GHC.Unit.State (UnitState)+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)+import GHC.Core.ConLike (ConLike)+import GHC.Core.DataCon (DataCon, FieldLabel)+import GHC.Core.FamInstEnv (FamInst)+import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst, DFunId)+import GHC.Core.PatSyn (PatSyn)+import GHC.Core.Predicate (EqRel, predTypeEqRel)+import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs)+import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder)++import GHC.Driver.Backend (Backend)++import GHC.Iface.Errors.Types++import GHC.Utils.Misc (filterOut)++import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.FastString (FastString)+import GHC.Data.Pair+import GHC.Exception.Type (SomeException)++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 qualified Data.Set as Set++data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not+                                       , tcOptsIfaceOpts   :: !IfaceMessageOpts+                                       }++{- Note [Migrating TcM Messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As part of #18516, we are slowly migrating the diagnostic messages emitted+and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted+some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions+that accepted 3 SDocs an input: one for the important part of the message,+one for the context and one for any supplementary information. Consider the following:++    • Couldn't match expected type ‘Int’ with actual type ‘Char’+    • In the expression: x4+      In a stmt of a 'do' block: return (x2, x4)+      In the expression:++Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match"+as the important part, "In the expression" as the context and "In a stmt..In the expression"+as the supplementary, with the context and supplementary usually smashed together so that+the final message would be composed only by two SDoc (which would then be bulleted like in+the example).++In order for us to smooth out the migration to the new diagnostic infrastructure, we+introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose+of bridging the two worlds together without breaking the external API or the existing+format of messages reported by GHC.++Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden+diagnostic API inside Tc.Utils.Monad, enabling further refactorings.++In the future, once the conversion will be complete and we will successfully eradicate+any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and+existence of these two types, which for now remain a "necessary evil".+-}+++-- | 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 :: ![ErrCtxtMsg]+    -- ^ Extra context associated to the error.+  , 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+        -- ^ main error payload+  deriving Generic++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;+  -- it mainly exists for users of the GHC API, such as plugins.+  --+  -- If you need to emit a new error message in the typechecker,+  -- you should add a new constructor to 'TcRnMessage' instead.++-- | An error which might arise during typechecking/renaming.+data TcRnMessage where+  {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins+      to provide custom diagnostic messages originated during typechecking/renaming.+  -}+  TcRnUnknownMessage :: UnknownDiagnosticFor TcRnMessage -> TcRnMessage++  {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface+      files during typechecking but encounter an error. -}++  TcRnInterfaceError :: !IfaceMessage -> TcRnMessage++  {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed+      to be provided in order to qualify a diagnostic and where it was originated (and why).+      It carries an extra 'UnitState' which can be used to pretty-print some names+      and it wraps a 'TcRnMessageDetailed', which includes any extra context associated+      with this diagnostic.+  -}+  TcRnMessageWithInfo :: !UnitState+                      -- ^ The 'UnitState' will allow us to pretty-print+                      -- some diagnostics with more detail.+                      -> !TcRnMessageDetailed+                      -> TcRnMessage++  {-| TcRnWithHsDocContext annotates an error message with the context in which+      it originated.+  -}+  TcRnWithHsDocContext :: !HsDocContext+                       -> !TcRnMessage+                       -> TcRnMessage++  {-| TcRnSolverReport is the constructor used to report unsolved constraints+      after constraint solving, as well as other errors such as hole fit errors.++      See the documentation of t'TcSolverReportMsg' datatype for an overview+      of the different errors.+  -}+  TcRnSolverReport :: SolverReportWithCtxt+                   -> DiagnosticReason+                   -> TcRnMessage++  {-| TcRnSolverDepthError is an error that occurs when the constraint solver+      exceeds the maximum recursion depth.++      Example:++        class C a where { meth :: a }+        instance Cls [a] => Cls a where { meth = head . meth }++        t :: ()+        t = meth++      Test cases:+        T7788+        T8550+        T9554+        T15316A+        T17267{∅,a,b,c,e}+        T17458+        ContextStack1+        T22924b+        TcCoercibleFail+  -}+  TcRnSolverDepthError :: !Type -> !SubGoalDepth -> TcRnMessage++  {-| TcRnRedundantConstraints is a warning that is emitted when a binding+      has a user-written type signature which contains superfluous constraints.++      Example:++        f :: (Eq a, Ord a) => a -> a -> a+        f x y = (x < y) || x == y+          -- `Eq a` is superfluous: the `Ord a` constraint suffices.++      Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296.+  -}+  TcRnRedundantConstraints :: [Id]+                           -> (SkolemInfoAnon, Bool)+                              -- ^ The contextual skolem info.+                              -- The boolean controls whether we+                              -- want to show it in the user message.+                              -- (Nice to keep track of the info in either case,+                              -- for other users of the GHC API.)+                           -> TcRnMessage++  {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern+      match is inaccessible, because the constraint solver has detected a contradiction.++      Example:++        data B a where { MkTrue :: B True; MkFalse :: B False }++        foo :: B False -> Bool+        foo MkFalse = False+        foo MkTrue  = True -- Inaccessible: requires True ~ False++    Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167.+  -}+  TcRnInaccessibleCode :: Implication          -- ^ The implication containing a contradiction.+                       -> SolverReportWithCtxt -- ^ The contradiction.+                       -> TcRnMessage+  {-| TcRnInaccessibleCoAxBranch is a warning that is emitted when a closed type family has a+      branch which is inaccessible due to a more general, prior branch.++      Example:+        type family F a where+          F a = Int+          F Bool = Bool+      Test cases: T9085, T14066a, T9085, T6018, tc265,++  -}+  TcRnInaccessibleCoAxBranch :: TyCon      -- ^ The type family's constructor+                             -> CoAxBranch -- ^ The inaccessible branch+                             -> TcRnMessage+  {-| A type which was expected to have a fixed runtime representation+      does not have a fixed runtime representation.++      Example:++        data D (a :: TYPE r) = MkD a++      Test cases: T11724, T18534,+                  RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype,+                  RepPolyPatSynRes, T20423+  -}+  TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type+                                     -> !FixedRuntimeRepProvenance+                                     -> ![ErrCtxtMsg] -- Extra info accumulated in the TcM monad+                                     -> TcRnMessage++  {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when+      a Template Haskell quote implicitly uses 'lift'.++     Example:+       warning1 :: Lift t => t -> Q Exp+       warning1 x = [| x |]++     Test cases: th/T17804+  -}+  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+      lone wild-card pattern, or a banged pattern.++     Example:+        Just _ = rhs3    -- Warning: unused pattern binding+        (_, _) = rhs4    -- Warning: unused pattern binding+        _  = rhs3        -- No warning: lone wild-card pattern+        !() = rhs4       -- No warning: banged pattern; behaves like seq++     Test cases: rename/{T13646,T17c,T17e,T7085}+  -}+  TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage++  {-| TcRnUnusedQuantifiedTypeVar is a warning that occurs if there are unused+      quantified type variables.++      Examples:+        f :: forall a. Int -> Char++      Test cases: rename/should_compile/ExplicitForAllRules1+                  rename/should_compile/T5331+  -}+  TcRnUnusedQuantifiedTypeVar+    :: HsDocContext+    -> HsTyVarBndrExistentialFlag -- ^ tyVar binder.+    -> TcRnMessage++  {-| TcRnDodgyImports is a group of warnings (controlled with -Wdodgy-imports).++      See 'DodgyImportsReason' for the different warnings.+  -}+  TcRnDodgyImports :: !DodgyImportsReason -> TcRnMessage+  {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when+      an export of the form 'T(..)' for a type constructor 'T' does not actually export anything+      beside 'T' itself.++     Example:+       module Foo (+           T(..)  -- Warning: T is a type synonym+         , A(..)  -- Warning: A is a type family+         , C(..)  -- Warning: C is a data family+         ) where++       type T = Int+       type family A :: * -> *+       data family C :: * -> *++     Test cases: warnings/should_compile/DodgyExports01+  -}+  TcRnDodgyExports :: GlobalRdrElt -> TcRnMessage+  {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when+      an import declaration does not explicitly list all the names brought into scope.++     Test cases: rename/should_compile/T4489+  -}+  TcRnMissingImportList :: IE GhcPs -> TcRnMessage+  {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled+      with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the+      reason the module was inferred to be unsafe. This warning is not raised if the+      -fplugin-trustworthy flag is passed.++     Test cases: plugins/T19926+  -}+  TcRnUnsafeDueToPlugin :: TcRnMessage+  {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks+      an associated 'RealSrcSpan'.++     Test cases: None+  -}+  TcRnModMissingRealSrcSpan :: Module -> TcRnMessage+  {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs+      when an identifier required by a signature is not exported by the module+      or signature that is being used as a substitution for that signature.++      Example(s): None++     Test cases: backpack/should_fail/bkpfail36+  -}+  TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage+  {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that+      occurs when an identifier which is necessary for implementing a module+      signature is not exported from that signature.++      Example(s): None++     Test cases: backpack/should_fail/bkpfail30+                 backpack/should_fail/bkpfail31+                 backpack/should_fail/bkpfail34+  -}+  TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage++  {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever+      an inner-scope value has the same name as an outer-scope value, i.e. the inner+      value shadows the outer one. This can catch typographical errors that turn into+      hard-to-find bugs. The warning is suppressed for names beginning with an underscore.++      Examples(s):+        f = ... let f = id in ... f ...  -- NOT OK, 'f' is shadowed+        f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore++     Test cases: typecheck/should_compile/T10971a+                 rename/should_compile/rn039+                 rename/should_compile/rn064+                 rename/should_compile/T1972+                 rename/should_fail/T2723+                 rename/should_compile/T3262+                 driver/werror+                 rename/should_fail/T22478d+                 typecheck/should_fail/TyAppPat_ScopedTyVarConflict+  -}+  TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage++  {-| TcRnInvalidWarningCategory is an error that occurs when a warning is declared+      with a category name that is not the special category "deprecations", and+      either does not begin with the prefix "x-" indicating a user-defined+      category, or contains characters not valid in category names.  See Note+      [Warning categories] in GHC.Unit.Module.Warnings++      Examples(s):+        module M {-# WARNING in "invalid" "Oops" #-} where++        {-# WARNING in "x- spaces not allowed" foo "Oops" #-}++     Test cases: warnings/should_fail/WarningCategoryInvalid+  -}+  TcRnInvalidWarningCategory :: !WarningCategory -> TcRnMessage++  {-| TcRnDuplicateWarningDecls is an error that occurs whenever+      a warning is declared twice.++      Examples(s):+        {-# DEPRECATED foo "Don't use me" #-}+        {-# DEPRECATED foo "Don't use me" #-}+        foo :: Int+        foo = 2++     Test cases:+        rename/should_fail/rnfail058+  -}+  TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage++  {-| TcRnSimplifierTooManyIterations is an error that occurs whenever+      the constraint solver in the simplifier hits the iterations' limit.++      Examples(s):+        None.++     Test cases:+        None.+  -}+  TcRnSimplifierTooManyIterations :: Cts+                                  -> !IntWithInf+                                  -- ^ The limit.+                                  -> WantedConstraints+                                  -> TcRnMessage++  {-| TcRnIllegalPatSynDecl is an error that occurs whenever+      there is an illegal pattern synonym declaration.++      Examples(s):++      varWithLocalPatSyn x = case x of+          P -> ()+        where+          pattern P = ()   -- not valid, it can't be local, it must be defined at top-level.++     Test cases: patsyn/should_fail/local+  -}+  TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage++  {-| TcRnLinearPatSyn is an error that occurs whenever a pattern+      synonym signature uses a field that is not unrestricted.++      Example(s): None++     Test cases: linear/should_fail/LinearPatSyn2+  -}+  TcRnLinearPatSyn :: !Type -> TcRnMessage++  {-| TcRnEmptyRecordUpdate is an error that occurs whenever+      a record is updated without specifying any field.++      Examples(s):++      $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions++     Test cases: th/T12788+  -}+  TcRnEmptyRecordUpdate :: TcRnMessage++  {-| TcRnIllegalFieldPunning is an error that occurs whenever+      field punning is used without the 'NamedFieldPuns' extension enabled.++      Examples(s):++      data Foo = Foo { a :: Int }++      foo :: Foo -> Int+      foo Foo{a} = a  -- Not ok, punning used without extension.++     Test cases: parser/should_fail/RecordDotSyntaxFail12+  -}+  TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage++  {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever+      wildcards (..) are used in a record without the relevant+      extension being enabled.++      Examples(s):++      data Foo = Foo { a :: Int }++      foo :: Foo -> Int+      foo Foo{..} = a  -- Not ok, wildcards used without extension.++     Test cases: parser/should_fail/RecordWildCardsFail+  -}+  TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage++  {-| TcRnIllegalWildcardInType is an error that occurs+      when a wildcard appears in a type in a location in which+      wildcards aren't allowed.++      Examples:++        Type synonyms:++          type T = _++        Class declarations and instances:++          class C _+          instance C _++        Standalone kind signatures:++          type D :: _+          data D++      Test cases:+        ExtraConstraintsWildcardInTypeSplice2+        ExtraConstraintsWildcardInTypeSpliceUsed+        ExtraConstraintsWildcardNotLast+        ExtraConstraintsWildcardTwice+        NestedExtraConstraintsWildcard+        NestedNamedExtraConstraintsWildcard+        PartialClassMethodSignature+        PartialClassMethodSignature2+        T12039+        T13324_fail1+        UnnamedConstraintWildcard1+        UnnamedConstraintWildcard2+        WildcardInADT1+        WildcardInADT2+        WildcardInADT3+        WildcardInADTContext1+        WildcardInDefault+        WildcardInDefaultSignature+        WildcardInDeriving+        WildcardInForeignExport+        WildcardInForeignImport+        WildcardInGADT1+        WildcardInGADT2+        WildcardInInstanceHead+        WildcardInInstanceSig+        WildcardInNewtype+        WildcardInPatSynSig+        WildcardInStandaloneDeriving+        WildcardInTypeFamilyInstanceRHS+        WildcardInTypeSynonymRHS+        saks_fail003+        T15433a+  -}+  TcRnIllegalWildcardInType+    :: Maybe Name+        -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard+    -> !BadAnonWildcardContext+    -> TcRnMessage++  {-| TcRnIllegalNamedWildcardInTypeArgument is an error that occurs+      when a named wildcard is used in a required type argument.++      Example:++        vfun :: forall (a :: k) -> ()+        x = vfun _nwc+        --       ^^^^+        -- named wildcards not allowed in type arguments++      Test cases:+        T23738_fail_wild+  -}+  TcRnIllegalNamedWildcardInTypeArgument+    :: RdrName+    -> TcRnMessage++  {- TcRnIllegalImplicitTyVarInTypeArgument is an error raised+     when a type variable is implicitly quantified in a required type argument.++     Example:+       vfun :: forall (a :: k) -> ()+       x = vfun (Nothing :: Maybe a)+       --                        ^^^+       -- implicit quantification not allowed in type arguments++  -}+  TcRnIllegalImplicitTyVarInTypeArgument+    :: 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.++      Examples(s):++        data R = MkR { x :: Int, x :: Bool }+        f r = r { x = 3, x = 4 }++     Test cases: T21959.+  -}+  TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage++  {-| TcRnIllegalViewPattern is an error that occurs whenever+      the ViewPatterns syntax is used but the ViewPatterns language extension+      is not enabled.++      Examples(s):+      data Foo = Foo { a :: Int }++      foo :: Foo -> Int+      foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled.++     Test cases: parser/should_fail/ViewPatternsFail+  -}+  TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage++  {-| TcRnCharLiteralOutOfRange is an error that occurs whenever+      a character is out of range.++      Examples(s): None++     Test cases: None+  -}+  TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage++  {-| TcRnNegativeNumTypeLiteral is an error that occurs whenever+      a type-level number literal is negative.++      type Neg = -1++     Test cases: th/T8412+                 typecheck/should_fail/T8306+  -}+  TcRnNegativeNumTypeLiteral :: HsTyLit GhcPs -> TcRnMessage++  {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever+      the record wildcards '..' are used inside a constructor without labeled fields.++      Examples(s): None++     Test cases:+       rename/should_fail/T9815.hs+       rename/should_fail/T9815b.hs+       rename/should_fail/T9815ghci.hs+       rename/should_fail/T9815bghci.hs+  -}+  TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage++  {-| TcRnIgnoringAnnotations is a warning that occurs when the source code+      contains annotation pragmas but the platform in use does not support an+      external interpreter such as GHCi and therefore the annotations are ignored.++      Example(s): None++     Test cases: None+  -}+  TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage++  {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas+      are used in conjunction with Safe Haskell.++      Example(s): None++     Test cases: annotations/should_fail/T10826+  -}+  TcRnAnnotationInSafeHaskell :: TcRnMessage++  {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application+      is used with an expression that does not accept "specified" type arguments.++      Example(s):+      foo :: forall {a}. a -> a+      foo x = x+      bar :: ()+      bar = let x = foo @Int 42+            in ()++     Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03+                 typecheck/should_fail/ExplicitSpecificity1+                 typecheck/should_fail/ExplicitSpecificity10+                 typecheck/should_fail/ExplicitSpecificity2+                 typecheck/should_fail/T17173+                 typecheck/should_fail/VtaFail+  -}+  TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage++  {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#'+      function is not applied to a single value argument.++      Example(s):+      tagToEnum# 1 2++     Test cases: None+  -}+  TcRnTagToEnumMissingValArg :: TcRnMessage++  {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#'+      function is not given a concrete result type.++      Example(s):+      foo :: forall a. a+      foo = tagToEnum# 0#++     Test cases: typecheck/should_fail/tcfail164+  -}+  TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage++  {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#'+      function is given a result type that is not an enumeration type.++      Example(s):+      foo :: Int -- not an enumeration TyCon+      foo = tagToEnum# 0#++     Test cases: typecheck/should_fail/tcfail164+  -}+  TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage++  {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#'+      function is given a result type that is headed by a @type data@ type, as+      the data constructors of a @type data@ do not exist at the term level.++      Example(s):+      type data Letter = A | B | C++      foo :: Letter+      foo = tagToEnum# 0#++     Test cases: type-data/should_fail/TDTagToEnum.hs+  -}+  TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage++  {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the+      predicate type of an ifThenElse expression in arrow notation depends on+      the type of the result.++      Example(s): None++     Test cases: None+  -}+  TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage++  {-| TcRnIllegalHsBootOrSigDecl is an error that occurs when an hs-boot file+      contains declarations that are not allowed, such as bindings.++      Examples:++        -- A.hs-boot+        f :: Int -> Int+        f x = 2 * x -- binding not allowed++        -- B.hs-boot+        type family F a where { F Int = Bool }+          -- type family equations not allowed++        -- C.hsig+        bar :: Int -> Int+        {-# RULES forall x. bar x = x #-} -- RULES not allowed+++     Test cases:++       - bindings: T19781+       - class instance body: none+       - type family instance: HsBootFam+       - splice: none+       - foreign declaration: none+       - default declaration: none+       - RULEs: none+  -}+  TcRnIllegalHsBootOrSigDecl :: !HsBootOrSig -> !BadBootDecls -> TcRnMessage++  {-| TcRnBootMismatch is a family of errors that occur when there is a+      mismatch between the hs-boot and hs files.++     Examples:++       -- A.hs-boot+       foo :: Int -> Bool+       data D = MkD++       -- A.hs+       foo :: Int -> Char+       foo = chr++       data D = MkD Int++      Test cases:++        - missing export: bkpcabal06, bkpfail{01,05,09,16,35}, rnfail{047,055}+        - missing definition: none+        - missing instance: T14075+        - mismatch in exports: bkpfail{03,19}+        - conflicting definitions: bkpcabal02,+           bkpfail{04,06,07,10,12,133,14,15,17,22,23,25,26,27,41,42,45,47,50,52,53,54},+           T19244{a,b}, T23344, ClosedFam3, rnfail055+  -}+  TcRnBootMismatch :: !HsBootOrSig -> !BootMismatch -> TcRnMessage++  {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym+      is defined in terms of itself, either directly or indirectly.++      Example(s):+      pattern A = B+      pattern B = A++     Test cases: patsyn/should_fail/T16900+  -}+  TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage++  {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature+      attempts to unify two different types.++      Example(s):+      f :: a -> b -> _+      f x y = [x, y]++     Test cases: partial-sigs/should_fail/T14449+  -}+  TcRnPartialTypeSigTyVarMismatch+    :: Name -- ^ first type variable+    -> Name -- ^ second type variable+    -> Name -- ^ function name+    -> LHsSigWcType GhcRn -> TcRnMessage++  {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable+      being quantified over in the partial type signature of a function gets unified+      with a type that is free in that function's context.++      Example(s):+      foo :: Num a => a -> a+      foo xxx = g xxx+        where+          g :: forall b. Num b => _ -> b+          g y = xxx + y++     Test cases: partial-sig/should_fail/T14479+  -}+  TcRnPartialTypeSigBadQuantifier+    :: Name   -- ^ user-written name of type variable being quantified+    -> Name   -- ^ function name+    -> Maybe Type   -- ^ type the variable unified with, if known+    -> LHsSigWcType GhcRn  -- ^ partial type signature+    -> TcRnMessage++  {-| TcRnMissingSignature is a warning that occurs when a top-level binding+      or a pattern synonym does not have a type signature.++      Controlled by the flags:+        -Wmissing-signatures+        -Wmissing-exported-signatures+        -Wmissing-pattern-synonym-signatures+        -Wmissing-exported-pattern-synonym-signatures+        -Wmissing-kind-signatures+        -Wmissing-poly-kind-signatures++      Test cases:+        T11077 (top-level bindings)+        T12484 (pattern synonyms)+        T19564 (kind signatures)+  -}+  TcRnMissingSignature :: MissingSignature+                       -> Exported+                       -> TcRnMessage++  {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures+      that occurs when a local polymorphic binding lacks a type signature.++      Example(s):+      id a = a++     Test cases: warnings/should_compile/T12574+  -}+  TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage++  {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts+      with the monomorphism restriction.++      Example(s):+      data T a = T a+      mono = ... where+        x :: Applicative f => f a+        T x = ...++     Test cases: typecheck/should_compile/T11339+  -}+  TcRnOverloadedSig :: TcIdSig -> TcRnMessage++  {-| TcRnTupleConstraintInst is an error that occurs whenever an instance+      for a tuple constraint is specified.++      Examples(s):+        class C m a+        class D m a+        f :: (forall a. Eq a => (C m a, D m a)) => m a+        f = undefined++      Test cases: quantified-constraints/T15334+  -}+  TcRnTupleConstraintInst :: !Class -> TcRnMessage++  {-| TcRnUserTypeError is an error that occurs due to a user's custom type error,+      which can be triggered by adding a `TypeError` constraint in a type signature+      or typeclass instance.++      Examples(s):+        f :: TypeError (Text "This is a type error")+        f = undefined++      Test cases: typecheck/should_fail/CustomTypeErrors02+                  typecheck/should_fail/CustomTypeErrors03+  -}+  TcRnUserTypeError :: !Type -> TcRnMessage++  {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified+      in a kind.++      Examples(s):+        data Q :: Eq a => Type where {}++      Test cases: dependent/should_fail/T13895+                  polykinds/T16263+                  saks/should_fail/saks_fail004+                  typecheck/should_fail/T16059a+                  typecheck/should_fail/T18714+  -}+  TcRnConstraintInKind :: !Type -> TcRnMessage++  {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple+      or unboxed sum type is specified as a function argument, when the appropriate+      extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled.++      Examples(s):+        -- T15073.hs+        import T15073a+        newtype Foo a = MkFoo a+          deriving P++        -- T15073a.hs+        class P a where+          p :: a -> (# a #)++      Test cases: deriving/should_fail/T15073.hs+                  deriving/should_fail/T15073a.hs+                  typecheck/should_fail/T16059d+  -}+  TcRnUnboxedTupleOrSumTypeFuncArg+    :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum+    -> !Type+    -> TcRnMessage++  {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is+      specified in a kind.++      Examples(s):+        data A :: * %1 -> *++      Test cases: linear/should_fail/LinearKind+                  linear/should_fail/LinearKind2+                  linear/should_fail/LinearKind3+  -}+  TcRnLinearFuncInKind :: !Type -> TcRnMessage++  {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind+      mentions quantified type variable.++      Examples(s):+        type T :: TYPE (BoxedRep l)+        data T = MkT++      Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly+  -}+  TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage++  {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification+      is specified in the type of a term.++      Examples(s):+        a = (undefined :: forall k -> k -> Type) @Int++      Test cases: dependent/should_fail/T15859+                  dependent/should_fail/T16326_Fail1+                  dependent/should_fail/T16326_Fail2+                  dependent/should_fail/T16326_Fail3+                  dependent/should_fail/T16326_Fail4+                  dependent/should_fail/T16326_Fail5+                  dependent/should_fail/T16326_Fail6+                  dependent/should_fail/T16326_Fail7+                  dependent/should_fail/T16326_Fail8+                  dependent/should_fail/T16326_Fail9+                  dependent/should_fail/T16326_Fail10+                  dependent/should_fail/T16326_Fail11+                  dependent/should_fail/T16326_Fail12+                  dependent/should_fail/T17687+                  dependent/should_fail/T18271+  -}+  TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage++  {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate+      lacks a class or type variable head.++      Examples(s):+        class (forall a. A t a => A t [a]) => B t where+          type A t a :: Constraint++      Test cases: quantified-constraints/T16474+  -}+  TcRnBadQuantPredHead :: !Type -> TcRnMessage++  {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple+      constraint is specified.++      Examples(s):+        g :: ((Show a, Num a), Eq a) => a -> a+        g = undefined++      Test cases: typecheck/should_fail/tcfail209a+  -}+  TcRnIllegalTupleConstraint :: !Type -> TcRnMessage++  {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable+      argument is specified in a constraint.++      Examples(s):+        data T+        instance Eq Int => Eq T++      Test cases: ghci/scripts/T13202+                  ghci/scripts/T13202a+                  polykinds/T12055a+                  typecheck/should_fail/T10351+                  typecheck/should_fail/T19187+                  typecheck/should_fail/T6022+                  typecheck/should_fail/T8883+  -}+  TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage++  {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit+      parameter is specified.++      Examples(s):+        type Bla = ?x::Int+        data T = T+        instance Bla => Eq T++      Test cases: polykinds/T11466+                  typecheck/should_fail/T8912+                  typecheck/should_fail/tcfail041+                  typecheck/should_fail/tcfail211+                  typecheck/should_fail/tcrun045+  -}+  TcRnIllegalImplicitParam :: !Type -> TcRnMessage++  {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint+      synonym of kind is specified.++      Examples(s):+        type Showish = Show+        f :: (Showish a) => a -> a+        f = undefined++      Test cases: typecheck/should_fail/tcfail209+  -}+  TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage++  {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated+      visible kind argument is specified.++      Examples(s):+        type family+          F2 :: forall (a :: Type). Type where+          F2 @a = Maybe a++      Test cases: typecheck/should_fail/T15793+                  typecheck/should_fail/T16255+  -}+  TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage++  {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type+      is specified.++      Examples(s):+        foo :: (a,b) -> (a~b => t) -> (a,b)+        foo p x = p++      Test cases:+        - ghci/should_run/T15806+        - indexed-types/should_fail/SimpleFail15+        - typecheck/should_fail/T11355+        - typecheck/should_fail/T12083a+        - typecheck/should_fail/T12083b+        - typecheck/should_fail/T16059c+        - typecheck/should_fail/T16059e+        - typecheck/should_fail/T17213+        - typecheck/should_fail/T18939_Fail+        - typecheck/should_fail/T2538+        - typecheck/should_fail/T5957+        - typecheck/should_fail/T7019+        - typecheck/should_fail/T7019a+        - typecheck/should_fail/T7809+        - typecheck/should_fail/T9196+        - typecheck/should_fail/tcfail127+        - typecheck/should_fail/tcfail184+        - typecheck/should_fail/tcfail196+        - typecheck/should_fail/tcfail197+  -}+  TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage++  {-| TcRnSimplifiableConstraint is a warning triggered by the occurrence of+      a simplifiable constraint in a context, when MonoLocalBinds is not enabled.++      Examples(s):+        simplifiableEq :: Eq (a, a) => a -> a -> Bool+        simplifiableEq = undefined++      Test cases:+        - indexed-types/should_compile/T15322+        - partial-sigs/should_compile/SomethingShowable+        - typecheck/should_compile/T13526+  -}+  TcRnSimplifiableConstraint :: !PredType -> !InstanceWhat -> TcRnMessage++  {-| TcRnArityMismatch is an error that occurs when a type constructor is supplied with+      fewer arguments than required.++      Examples(s):+        f Left = undefined++      Test cases:+        - backpack/should_fail/bkpfail25.bkp+        - ghci/should_fail/T16013+        - ghci/should_fail/T16287+        - indexed-types/should_fail/BadSock+        - indexed-types/should_fail/T9433+        - module/mod60+        - ndexed-types/should_fail/T2157+        - parser/should_fail/ParserNoBinaryLiterals2+        - parser/should_fail/ParserNoBinaryLiterals3+        - patsyn/should_fail/T12819+        - polykinds/T10516+        - typecheck/should_fail/T12124+        - typecheck/should_fail/T15954+        - typecheck/should_fail/T16874+        - typecheck/should_fail/tcfail100+        - typecheck/should_fail/tcfail101+        - typecheck/should_fail/tcfail107+        - typecheck/should_fail/tcfail129+        - typecheck/should_fail/tcfail187+  -}+  TcRnArityMismatch :: !TyThing+                    -> !Arity -- ^ expected arity+                    -> !Arity -- ^ actual arity+                    -> TcRnMessage++  {-| TcRnIllegalClassInstance is a collection of diagnostics that arise+      from an invalid class or family instance declaration.++      See t'IllegalInstanceReason'.+  -}+  TcRnIllegalInstance :: IllegalInstanceReason -> TcRnMessage++  {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction)+      that arises when the monomorphism restriction applies to the given bindings.++      Examples(s):+        {-# OPTIONS_GHC -Wmonomorphism-restriction #-}++        bar = 10++        foo :: Int+        foo = bar++        main :: IO ()+        main = print foo++      The example above emits the warning (for 'bar'), because without monomorphism+      restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us+      that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar'+      less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that.++      Test cases: typecheck/should_compile/T13785+  -}+  TcRnMonomorphicBindings :: [Name] -> TcRnMessage++  {-| TcRnOrphanInstance is a warning (controlled by -Worphans) that arises when+      a typeclass instance or family instance is an \"orphan\", i.e. if it+      appears in a module in which neither the class/family nor the type being+      instanced are declared in the same module.++      Examples(s): None++      Test cases: warnings/should_compile/T9178+                  typecheck/should_compile/T4912+  -}+  TcRnOrphanInstance :: Either ClsInst FamInst -> TcRnMessage++  {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies+      conflicts between instance declarations.++      Examples(s): None++      Test cases: typecheck/should_fail/T2307+                  typecheck/should_fail/tcfail096+                  typecheck/should_fail/tcfail202+  -}+  TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage++  {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance+      declarations.++      Examples(s):+        class Foo a where+          foo :: a -> Int++        instance Foo Int where+          foo = id++        instance Foo Int where+          foo = const 42++      Test cases: cabal/T12733/T12733+                  typecheck/should_fail/tcfail035+                  typecheck/should_fail/tcfail023+                  backpack/should_fail/bkpfail18+                  typecheck/should_fail/TcNullaryTCFail+                  typecheck/should_fail/tcfail036+                  typecheck/should_fail/tcfail073+                  module/mod51+                  module/mod52+                  module/mod44+  -}+  TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage++  {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting+      family instance declarations.++      Examples(s): None.++      Test cases: indexed-types/should_fail/ExplicitForAllFams4b+                  indexed-types/should_fail/NoGood+                  indexed-types/should_fail/Over+                  indexed-types/should_fail/OverDirectThisMod+                  indexed-types/should_fail/OverIndirectThisMod+                  indexed-types/should_fail/SimpleFail11a+                  indexed-types/should_fail/SimpleFail11b+                  indexed-types/should_fail/SimpleFail11c+                  indexed-types/should_fail/SimpleFail11d+                  indexed-types/should_fail/SimpleFail2a+                  indexed-types/should_fail/SimpleFail2b+                  indexed-types/should_fail/T13092/T13092+                  indexed-types/should_fail/T13092c/T13092c+                  indexed-types/should_fail/T14179+                  indexed-types/should_fail/T2334A+                  indexed-types/should_fail/T2677+                  indexed-types/should_fail/T3330b+                  indexed-types/should_fail/T4246+                  indexed-types/should_fail/T7102a+                  indexed-types/should_fail/T9371+                  polykinds/T7524+                  typecheck/should_fail/UnliftedNewtypesOverlap+  -}+  TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage++  {-| TcRnFamInstNotInjective is a collection of errors that arise from+      a type family equation violating the injectivity annotation.++      See 'InjectivityErrReason'.+  -}+  TcRnFamInstNotInjective :: InjectivityErrReason -- ^ the violation+                          -> TyCon -- ^ the family 'TyCon'+                          -> NE.NonEmpty CoAxBranch -- ^ the family equations+                          -> TcRnMessage++  {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that+      occurs when a strictness annotation is applied to an unlifted type.++      Example(s):+      data T = MkT !Int# -- Strictness flag has no effect on unlifted types++     Test cases: typecheck/should_compile/T20187a+                 typecheck/should_compile/T20187b+  -}+  TcRnBangOnUnliftedType :: !Type -> TcRnMessage++  {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that+      occurs when a lazy annotation is applied to an unlifted type.++      Example(s):+      data T = MkT ~Int# -- Lazy flag has no effect on unlifted types++     Test cases: typecheck/should_compile/T21951a+                 typecheck/should_compile/T21951b+  -}+  TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage++  {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has+      more than one default declaration for the same class.++      Example:+      default (Integer, Int)  -- implicitly applies to Num+      default (Double, Float) -- 2nd default declaration not allowed++     Text cases: module/mod58+  -}+  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+      subsumed by one of them nor by a local `default` declaration.++      See Note [Named default declarations] in GHC.Tc.Gen.Default++     Test cases: default/Import07.hs+  -}+  TcRnWarnClashingDefaultImports :: Class+                                 -> Maybe [Type] -- ^ locally declared defaults+                                 -> NE.NonEmpty ClassDefaults -- ^ imported defaults+                                 -> TcRnMessage++  {-| TcRnBadDefaultType is an error that occurs when a type used in a default+      declaration does not have an instance for any of the applicable classes.++      Example(s):+      data Foo+      default (Foo)++     Test cases: typecheck/should_fail/T11974b+  -}+  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+      `data` or `newtype` construction.++      Example(s):+      module Foo (MyClass(.., P)) where+      pattern P = Nothing+      class MyClass a where+        foo :: a -> Int++     Test cases: patsyn/should_fail/export-class+  -}+  TcRnPatSynBundledWithNonDataCon :: TcRnMessage++  {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list+      of a module has a pattern synonym bundled with a type that does not match+      the type of the pattern synonym.++      Example(s):+      module Foo (R(P,x)) where+      data Q = Q Int+      data R = R+      pattern P{x} = Q x++     Text cases: patsyn/should_fail/export-ps-rec-sel+                 patsyn/should_fail/export-type-synonym+                 patsyn/should_fail/export-type+  -}+  TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage++  {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that+      occurs when a module appears more than once in an export list.++      Example(s):+      module Foo (module Bar, module Bar)+      import Bar++     Text cases: None+  -}+  TcRnDupeModuleExport :: ModuleName -> TcRnMessage++  {-| TcRnExportedModNotImported is an error that occurs when an export list+      contains a module that is not imported.++      Example(s): None++     Text cases: module/mod135+                 module/mod8+                 rename/should_fail/rnfail028+                 backpack/should_fail/bkpfail48+  -}+  TcRnExportedModNotImported :: ModuleName -> TcRnMessage++  {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs+      when an export list contains a module that has no exports.++      Example(s):+      module Foo (module Bar) where+      import Bar ()++     Test cases: None+  -}+  TcRnNullExportedModule :: ModuleName -> TcRnMessage++  {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that+      occurs when a module does not have an explicit export list.++      Example(s): None++     Test cases: typecheck/should_fail/MissingExportList03+  -}+  TcRnMissingExportList :: ModuleName -> TcRnMessage++  {-| TcRnExportHiddenComponents is an error that occurs when an export contains+      constructor or class methods that are not visible.++      Example(s): None++     Test cases: None+  -}+  TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage++  {-| TcRnExportHiddenDefault is an error that occurs when an export contains+      a class default (with language extension NamedDefaults) that is not visible.++      Example(s): None++     Test cases: default/fail06.hs+  -}+  TcRnExportHiddenDefault :: IE GhcPs -> TcRnMessage++  {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs+      when an identifier appears in an export list more than once.++      Example(s): None++     Test cases: module/MultiExport+                 module/mod128+                 module/mod14+                 module/mod5+                 overloadedrecflds/should_fail/DuplicateExports+                 patsyn/should_compile/T11959+  -}+  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++      Example(s):+      module Foo (T(a)) where+      data T+      a = True++     Test cases: module/T11970+                 module/T11970B+                 module/mod17+                 module/mod3+                 overloadedrecflds/should_fail/NoParent+  -}+  TcRnExportedParentChildMismatch :: Name -- ^ parent+                                  -> TyThing+                                  -> Name -- ^ child+                                  -> [Name] -> TcRnMessage++  {-| TcRnConflictingExports is an error that occurs when different identifiers that+      have the same name are being exported by a module.++      Example(s):+      module Foo (Bar.f, module Baz) where+      import qualified Bar (f)+      import Baz (f)++     Test cases: module/mod131+                 module/mod142+                 module/mod143+                 module/mod144+                 module/mod145+                 module/mod146+                 module/mod150+                 module/mod155+                 overloadedrecflds/should_fail/T14953+                 overloadedrecflds/should_fail/overloadedrecfldsfail10+                 rename/should_fail/rnfail029+                 rename/should_fail/rnfail040+                 typecheck/should_fail/T16453E2+                 typecheck/should_fail/tcfail025+                 typecheck/should_fail/tcfail026+  -}+  TcRnConflictingExports+    :: OccName      -- ^ Occurrence name shared by both exports+    -> GlobalRdrElt -- ^ First export+    -> IE GhcPs     -- ^ Export decl of first export+    -> GlobalRdrElt -- ^ Second export+    -> IE GhcPs     -- ^ Export decl of second export+    -> TcRnMessage++  {-| TcRnDuplicateFieldExport is an error that occurs when a module exports+      multiple record fields with the same name, without enabling+      DuplicateRecordFields.++      Example:++      module M1 where+        data D1 = MkD1 { foo :: Int }+      module M2 where+        data D2 = MkD2 { foo :: Int }+      module M ( D1(..), D2(..) ) where+        import module M1+        import module M2++     Test case: overloadedrecflds/should_fail/overloadedrecfldsfail10+  -}+  TcRnDuplicateFieldExport+    :: (GlobalRdrElt, IE GhcPs)+    -> NE.NonEmpty (GlobalRdrElt, IE GhcPs)+    -> TcRnMessage++  {-| TcRnAmbiguousRecordUpdate is a warning, controlled by -Wambiguous-fields,+      which occurs when a user relies on the type-directed disambiguation+      mechanism to disambiguate a record update. This will not be supported by+      -XDuplicateRecordFields in future releases.++      Example(s):++        data Person  = MkPerson  { personId :: Int, name :: String }+        data Address = MkAddress { personId :: Int, address :: String }+        bad1 x = x { personId = 4 } :: Person -- ambiguous+        bad2 (x :: Person) = x { personId = 4 } -- ambiguous+        good x = (x :: Person) { personId = 4 } -- not ambiguous++     Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06+  -}+  TcRnAmbiguousRecordUpdate+    :: HsExpr GhcRn -- ^ Field update+    -> TyCon -- ^ Record type+    -> TcRnMessage++  {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring+      when the intialisation of a record is missing one or more (lazy) fields.++      Example(s):+      data Rec = Rec { a :: Int, b :: String, c :: Bool }+      x = Rec { a = 1, b = "two" } -- missing field 'c'++     Test cases: deSugar/should_compile/T13870+                 deSugar/should_compile/ds041+                 patsyn/should_compile/T11283+                 rename/should_compile/T5334+                 rename/should_compile/T12229+                 rename/should_compile/T5892a+                 warnings/should_fail/WerrorFail2+  -}+  TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage++  {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's+      type mentions something that is outside the universally quantified variables+      of the data constructor, such as an existentially quantified type.++      Example(s):+      data X = forall a. MkX { f :: a }+      x = (MkX ()) { f = False }++      Test cases: patsyn/should_fail/records-exquant+                  typecheck/should_fail/T3323+  -}+  TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage++  {-| TcRnMissingStrictFields is an error occurring when a record field marked+     as strict is omitted when constructing said record.++     Example(s):+     data R = R { strictField :: !Bool, nonStrict :: Int }+     x = R { nonStrict = 1 }++    Test cases: typecheck/should_fail/T18869+                typecheck/should_fail/tcfail085+                typecheck/should_fail/tcfail112+  -}+  TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage++  {-| TcRnAmbiguousFieldInUpdate is an error that occurs when a field in a+      record update clashes with another field or top-level function of the+      same name, and the user hasn't enabled -XDisambiguateRecordFields.++      Example:++        {-# LANGUAGE NoFieldSelectors #-}+        {-# LANGUAGE NoDisambiguateRecordFields #-}+        module M where++          data A = MkA { fld :: Int }++          fld :: Bool+          fld = False++          f r = r { fld = 3 }++  -}+  TcRnAmbiguousFieldInUpdate :: (GlobalRdrElt, GlobalRdrElt, [GlobalRdrElt])+                                -> TcRnMessage++  {-| TcRnBadRecordUpdate is an error when a regular (non-overloaded)+     record update cannot be pinned down to any one parent.++     The problem with the record update is stored in the 'BadRecordUpdateReason'+     field.++     Example(s):++       data R1 = R1 { x :: Int }+       data R2 = R2 { x :: Int }+       update r = r { x = 1 }+         -- ambiguous++       data R1 = R1 { x :: Int, y :: Int }+       data R2 = R2 { y :: Int, z :: Int }+       update r = r { x = 1, y = 2, z = 3 }+         -- no parent has all the fields++    Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01+                overloadedrecflds/should_fail/overloadedrecfldsfail01+                overloadedrecflds/should_fail/overloadedrecfldsfail14+  -}+  TcRnBadRecordUpdate :: [RdrName]+                         -- ^ the fields of the record update+                      -> BadRecordUpdateReason+                         -- ^ the reason this record update was rejected+                      -> TcRnMessage++  {-| TcRnStaticFormNotClosed is an error pertaining to terms that are marked static+     using the -XStaticPointers extension but which are not closed terms.++     Example(s):+     f x = static x++    Test cases: rename/should_fail/RnStaticPointersFail01+                rename/should_fail/RnStaticPointersFail03+  -}+  TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage++  {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that+      occurs when trying to derive an instance of the 'Typeable' class. Deriving+      'Typeable' is no longer necessary (hence the \"useless\") as all types+      automatically derive 'Typeable' in modern GHC versions.++      Example(s): None.++     Test cases: warnings/should_compile/DerivingTypeable+  -}+  TcRnUselessTypeable :: TcRnMessage++  {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that+      occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are+      enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not+      be what the user wants.++      Example(s): None.++     Test cases: typecheck/should_compile/T15839a+                 deriving/should_compile/T16179+  -}+  TcRnDerivingDefaults :: !Class -> TcRnMessage++  {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC+      encounters a non-unary constraint when trying to derive a typeclass.++      Example(s):+        class A+        deriving instance A+        data B deriving A  -- We cannot derive A, is not unary (i.e. 'class A a').++     Test cases: deriving/should_fail/T7959+                 deriving/should_fail/drvfail005+                 deriving/should_fail/drvfail009+                 deriving/should_fail/drvfail006+  -}+  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+      type class derivation++      Example(s):+        foo :: _ -> Int+        foo = ...++        deriving instance _ => Eq (Foo a)++     Test cases: dependent/should_compile/T11241+                 dependent/should_compile/T15076+                 dependent/should_compile/T14880-2+                 typecheck/should_compile/T17024+                 typecheck/should_compile/T10072+                 partial-sigs/should_fail/TidyClash2+                 partial-sigs/should_fail/Defaulting1MROff+                 partial-sigs/should_fail/WildcardsInPatternAndExprSig+                 partial-sigs/should_fail/T10615+                 partial-sigs/should_fail/T14584a+                 partial-sigs/should_fail/TidyClash+                 partial-sigs/should_fail/T11122+                 partial-sigs/should_fail/T14584+                 partial-sigs/should_fail/T10045+                 partial-sigs/should_fail/PartialTypeSignaturesDisabled+                 partial-sigs/should_fail/T10999+                 partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature+                 partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice+                 partial-sigs/should_fail/WildcardInstantiations+                 partial-sigs/should_run/T15415+                 partial-sigs/should_compile/T10463+                 partial-sigs/should_compile/T15039a+                 partial-sigs/should_compile/T16728b+                 partial-sigs/should_compile/T15039c+                 partial-sigs/should_compile/T10438+                 partial-sigs/should_compile/SplicesUsed+                 partial-sigs/should_compile/T18008+                 partial-sigs/should_compile/ExprSigLocal+                 partial-sigs/should_compile/T11339a+                 partial-sigs/should_compile/T11670+                 partial-sigs/should_compile/WarningWildcardInstantiations+                 partial-sigs/should_compile/T16728+                 partial-sigs/should_compile/T12033+                 partial-sigs/should_compile/T15039b+                 partial-sigs/should_compile/T10403+                 partial-sigs/should_compile/T11192+                 partial-sigs/should_compile/T16728a+                 partial-sigs/should_compile/TypedSplice+                 partial-sigs/should_compile/T15039d+                 partial-sigs/should_compile/T11016+                 partial-sigs/should_compile/T13324_compile2+                 linear/should_fail/LinearPartialSig+                 polykinds/T14265+                 polykinds/T14172+  -}+  TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage++  {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance+      can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason+      this error arose.++      Example(s): None.++      Test cases: generics/T10604/T10604_no_PolyKinds+                  deriving/should_fail/drvfail009+                  deriving/should_fail/drvfail-functor2+                  deriving/should_fail/T10598_fail3+                  deriving/should_fail/deriving-via-fail2+                  deriving/should_fail/deriving-via-fail+                  deriving/should_fail/T16181+  -}+  TcRnCannotDeriveInstance :: !Class+                           -- ^ The typeclass we are trying to derive+                           -- an instance for+                           -> [Type]+                           -- ^ The typeclass arguments, if any.+                           -> !(Maybe (DerivStrategy GhcTc))+                           -- ^ The derivation strategy, if any.+                           -> !UsingGeneralizedNewtypeDeriving+                           -- ^ Is '-XGeneralizedNewtypeDeriving' enabled?+                           -> !DeriveInstanceErrReason+                           -- ^ The specific reason why we couldn't derive+                           -- an instance for the class.+                           -> TcRnMessage++  {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested+      GADT pattern match inside a lazy (~) pattern.++      Test case: gadt/lazypat+  -}+  TcRnLazyGADTPattern :: TcRnMessage++  {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a+      GADT pattern inside arrow proc notation.++      Test case: arrows/should_fail/arrowfail004.+  -}+  TcRnArrowProcGADTPattern :: TcRnMessage++  {-| TcRnCapturedTermName is a warning (controlled by -Wterm-variable-capture) that occurs+    when an implicitly quantified type variable's name is already used for a term.+    Example:+      a = 10+      f :: a -> a++    Test cases: T22513a T22513b T22513c T22513d T22513e T22513f T22513g T22513h T22513i+ -}+  TcRnCapturedTermName :: RdrName -> Either [GlobalRdrElt] Name -> TcRnMessage++  {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope)+      that occurs when the type equality (a ~ b) is not in scope.++      Test case: warnings/should_compile/T18862b+  -}+  TcRnTypeEqualityOutOfScope :: TcRnMessage++  {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators)+      that occurs when the type equality (a ~ b) is used without the TypeOperators extension.++      Example:+        {-# LANGUAGE NoTypeOperators #-}+        f :: (a ~ b) => a -> b++      Test case: T18862a+  -}+  TcRnTypeEqualityRequiresOperators :: TcRnMessage++  {-| TcRnIllegalTypeOperator is an error that occurs when a type operator+      is used without the TypeOperators extension.++      Example:+        {-# LANGUAGE NoTypeOperators #-}+        f :: Vec a n -> Vec a m -> Vec a (n + m)++      Test case: T12811+  -}+  TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage++  {-| TcRnIllegalTypeOperatorDecl is an error that occurs when a type or class+      operator is declared without the TypeOperators extension.++      See Note [Type and class operator definitions]++      Example:+        {-# LANGUAGE Haskell2010 #-}+        {-# LANGUAGE MultiParamTypeClasses #-}++        module T3265 where++        data a :+: b = Left a | Right b++        class a :*: b where {}+++      Test cases: T3265, tcfail173+  -}+  TcRnIllegalTypeOperatorDecl :: !RdrName -> TcRnMessage++  {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds+      that occurs when pattern matching on a GADT when -XMonoLocalBinds is off.++      Example(s): None++      Test cases: T20485, T20485a+  -}+  TcRnGADTMonoLocalBinds :: TcRnMessage++  {-| The TcRnNotInScope constructor is used for various not-in-scope errors.+      See 'NotInScopeError' for more details. -}+  TcRnNotInScope :: NotInScopeError  -- ^ what the problem is+                 -> RdrName          -- ^ the name that is not in scope+                 -> TcRnMessage++  {-| TcRnTermNameInType is an error that occurs when a term-level identifier+      is used in a type.++      Example:++        import qualified Prelude++        bad :: Prelude.fst (Bool, Float)+        bad = False++      Test cases: T21605{c,d}+  -}+  TcRnTermNameInType :: !RdrName -> TcRnMessage++  {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors)+      that is triggered by an unticked occurrence of a promoted data constructor.++      Examples:++        data A = MkA+        type family F (a :: A) where { F MkA = Bool }++        type B = [ Int, Bool ]++      Test cases: T9778, T19984.+  -}+  TcRnUntickedPromotedThing :: UntickedPromotedThing+                            -> TcRnMessage++  {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears+      in an unexpected location, e.g. as a data constructor or in a fixity declaration.++      Examples:++        infixl 5 :++        data P = (,)++      Test cases: rnfail042, T14907b, T15124, T15233.+  -}+  TcRnIllegalBuiltinSyntax :: SigLike -- ^ what kind of thing this is (a binding, fixity declaration, ...)+                           -> RdrName+                           -> TcRnMessage++  {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults)+      that is triggered whenever a Wanted typeclass constraint+      is solving through the defaulting of a type variable.++      Example:++        one = show 1+        -- We get Wanteds Show a0, Num a0, and default a0 to Integer.++      Test cases:+        none (which are really specific to defaulting),+        but see e.g. tcfail204.+   -}+  TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred+                     -> Maybe TyVar -- ^ The type variable being defaulted+                     -> Type -- ^ The default type+                     -> TcRnMessage++  {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name'+      is used in the incorrect 'NameSpace', e.g. a type constructor+      or class used in a term, or a term variable used in a type.++      Example:++        list2 = $( conE ''(:) `appE` litE (IntegerL 5) `appE` conE '[] )+        --              ^^^^^+        --              should use a single quotation tick, i.e. '(:)++      Test cases: T20884.+  -}+  TcRnIncorrectNameSpace :: Name+                         -> Bool -- ^ whether the error is happening+                                 -- in a Template Haskell tick+                                 -- (so we should give a Template Haskell hint)+                         -> TcRnMessage++  {-| TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import+     is declared using the @prim@ calling convention without having turned on+     the -XGHCForeignImportPrim extension.++     Example(s):+     foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #)++    Test cases: ffi/should_fail/T20116+  -}+  TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage++  {-| TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe+     annotation should not be used with @prim@ foreign imports.++     Example(s):+     foreign import prim unsafe "my_primop_cmm" :: ...++    Test cases: None+  -}+  TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage++  {-| TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@+     imports cannot have function types.++     Example(s):+     foreign import capi "math.h value sqrt" f :: CInt -> CInt++    Test cases: ffi/should_fail/capi_value_function+  -}+  TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage++  {-| TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@+     that informs the user of a possible missing @&@ in the declaration of a+     foreign import with a 'FunPtr' return type.++     Example(s):+     foreign import ccall "f" f :: FunPtr (Int -> IO ())++    Test cases: ffi/should_compile/T1357+  -}+  TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage++  {-| TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration+     is not compatible with the code generation backend being used.++     Example(s): None++    Test cases: None+  -}+  TcRnIllegalForeignDeclBackend+    :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)+    -> Backend+    -> ExpectedBackends+    -> TcRnMessage++  {-| TcRnUnsupportedCallConv informs the user that the calling convention specified+     for a foreign export declaration is not compatible with the target platform.+     It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of+     @stdcall@ but is otherwise considered an error.++     Example(s): None++    Test cases: None+  -}+  TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)+                          -> UnsupportedCallConvention+                          -> TcRnMessage++  {-| TcRnIllegalForeignType is an error for when a type appears in a foreign+     function signature that is not compatible with the FFI.++     Example(s): None++    Test cases: ffi/should_fail/T3066+                ffi/should_fail/ccfail004+                ffi/should_fail/T10461+                ffi/should_fail/T7506+                ffi/should_fail/T5664+                safeHaskell/ghci/p6+                safeHaskell/safeLanguage/SafeLang08+                ffi/should_fail/T16702+                linear/should_fail/LinearFFI+                ffi/should_fail/T7243+  -}+  TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage++  {-| TcRnInvalidCIdentifier indicates a C identifier that is not valid.++     Example(s):+     foreign import prim safe "not valid" cmm_test2 :: Int# -> Int#++    Test cases: th/T10638+  -}+  TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage++  {-| TcRnExpectedValueId is an error occurring when something that is not a+      value identifier is used where one is expected.++     Example(s): none++    Test cases: none+  -}+  TcRnExpectedValueId :: !TcTyThing -> TcRnMessage++  {-| TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector+     containing an existential type variable is used as a function rather than in+     a pattern match.++     Example(s):+     data Rec = forall a. Rec { field :: a }+     field (Rec True)++    Test cases: patsyn/should_fail/records-exquant+                typecheck/should_fail/T3176+  -}+  TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage++  {-| TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern+     synonym is used as a constructor.++     Example(s):+     pattern Five :: Int+     pattern Five <- 5+     five = Five++    Test cases: patsyn/should_fail/records-no-uni-update+                patsyn/should_fail/records-no-uni-update2+  -}+  TcRnPatSynNotBidirectional :: !Name -> TcRnMessage++  {-| TcRnIllegalDerivingItem is an error for when something other than a type class+     appears in a deriving statement.++     Example(s):+     data X = X deriving Int++    Test cases: deriving/should_fail/T5922+  -}+  TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage++  {-| TcRnIllegalDefaultClass is an error for when something other than a type class+     appears in a default declaration after the keyword.++     Example(s):+     default Integer (Int)++    Test cases: default/fail01+  -}+  TcRnIllegalDefaultClass :: !Name -> TcRnMessage++  {-| TcRnIllegalNamedDefault is an error for specifying an explicit default class name+     without @-XNamedDefaults@.++     Example(s):+     default Num (Integer)++    Test cases: default/fail02+  -}+  TcRnIllegalNamedDefault :: !(LDefaultDecl GhcRn) -> TcRnMessage++  {-| TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such+     as strictness, laziness, or unpacking.++     Example(s):+     data T = T { t :: Maybe {-# UNPACK #-} Int }+     data C = C { f :: !IntMap Int }++    Test cases: parser/should_fail/unpack_inside_type+                typecheck/should_fail/T7210+                rename/should_fail/T22478b+  -}+  TcRnUnexpectedAnnotation :: !(HsType GhcPs) -> !HsSrcBang -> TcRnMessage++  {-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax.++     Example(s):+     data T = T Int { field :: Int }++    Test cases: rename/should_fail/T7943+                rename/should_fail/T9077+                rename/should_fail/T22478b+  -}+  TcRnIllegalRecordSyntax :: HsType GhcPs -> TcRnMessage++  {-| TcRnInvalidVisibleKindArgument is an error for a kind application on a+     target type that cannot accept it.++     Example(s):+     bad :: Int @Type+     bad = 1+     type Foo :: forall a {b}. a -> b -> b+     type Foo x y = y+     type Bar = Foo @Bool @Int True 42++    Test cases: indexed-types/should_fail/T16356_Fail3+                typecheck/should_fail/ExplicitSpecificity7+                typecheck/should_fail/T12045b+                typecheck/should_fail/T12045c+                typecheck/should_fail/T15592a+                typecheck/should_fail/T15816+  -}+  TcRnInvalidVisibleKindArgument+    :: !(LHsType GhcRn) -- ^ The visible kind argument+    -> !Type -- ^ Target of the kind application+    -> TcRnMessage++  {-| TcRnTooManyBinders is an error for a type constructor that is declared with+     more arguments then its kind specifies.++     Example(s):+     type T :: Type -> (Type -> Type) -> Type+     data T a (b :: Type -> Type) x1 (x2 :: Type -> Type)++    Test cases: saks/should_fail/saks_fail008+  -}+  TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcRnMessage++  {-| TcRnDifferentNamesForTyVar is an error that indicates different names being+     used for the same type variable.++     Example(s):+     data SameKind :: k -> k -> *+     data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)++    Test cases: polykinds/T11203+                polykinds/T11821a+                saks/should_fail/T20916+                typecheck/should_fail/T17566b+                typecheck/should_fail/T17566c+  -}+  TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage++  {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature,+      where the implicitly-bound type type variables can't be matched up unambiguously+      with the ones from the signature. See Note [Disconnected type variables] in+      GHC.Tc.Gen.HsType.++      Test cases: T24083+  -}+  TcRnDisconnectedTyVar :: !Name -> TcRnMessage++  {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature+     with an invalid result kind.++     Example(s):+     data family Foo :: Constraint++    Test cases: typecheck/should_fail/T14048b+                typecheck/should_fail/UnliftedNewtypesConstraintFamily+                typecheck/should_fail/T12729+                typecheck/should_fail/T15883+                typecheck/should_fail/T16829a+                typecheck/should_fail/T16829b+                typecheck/should_fail/UnliftedNewtypesNotEnabled+                typecheck/should_fail/tcfail079+  -}+  TcRnInvalidReturnKind+    :: !DataSort -- ^ classification of thing being returned+    -> !AllowedDataResKind -- ^ allowed kind+    -> !Kind -- ^ the return kind+    -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension+    -> TcRnMessage++  {-| TcRnUnexpectedKindVar is an error that occurs when the user+      tries to use kind variables without -XPolyKinds.++      Example:+        f :: forall k a. Proxy (a :: k)++      Test cases: polykinds/BadKindVar+                  polykinds/T14710+                  saks/should_fail/T16722+  -}+  TcRnUnexpectedKindVar :: RdrName -> TcRnMessage++  {-| TcRnIllegalKind is used for a various illegal kinds errors including++      Example:+        type T :: forall k. Type -- without emabled -XPolyKinds++      Test cases: polykinds/T16762b+  -}+  TcRnIllegalKind+    :: HsTypeOrSigType GhcPs+            -- ^ The illegal kind+    -> Bool -- ^ Whether enabling -XPolyKinds should be suggested+    -> TcRnMessage++  {-| TcRnClassKindNotConstraint is an error for a type class that has a kind that+     is not equivalent to Constraint.++     Example(s):+     type C :: Type -> Type+     class C a++    Test cases: saks/should_fail/T16826+  -}+  TcRnClassKindNotConstraint :: !Kind -> TcRnMessage++  {-| TcRnUnpromotableThing is an error that occurs when the user attempts to+     use the promoted version of something which is not promotable.++     Example(s):+     data T :: T -> *+     data X a where+       MkX :: Show a => a -> X a+     foo :: Proxy ('MkX 'True)+     foo = Proxy++    Test cases: dependent/should_fail/PromotedClass+                dependent/should_fail/T14845_fail1+                dependent/should_fail/T14845_fail2+                dependent/should_fail/T15215+                dependent/should_fail/T13780c+                dependent/should_fail/T15245+                polykinds/T5716+                polykinds/T5716a+                polykinds/T6129+                polykinds/T7433+                patsyn/should_fail/T11265+                patsyn/should_fail/T9161-1+                patsyn/should_fail/T9161-2+                dependent/should_fail/SelfDep+                polykinds/PolyKinds06+                polykinds/PolyKinds07+                polykinds/T13625+                polykinds/T15116+                polykinds/T15116a+                saks/should_fail/T16727a+                saks/should_fail/T16727b+                rename/should_fail/T12686+                rename/should_fail/T16635a+                rename/should_fail/T16635b+                rename/should_fail/T16635c+  -}+  TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage++  {- | TcRnIllegalTermLevelUse is an error that occurs when the user attempts to+       use a type-level entity at the term-level.++       Examples:+          f x = Int                 -- illegal use of a type constructor+          g (Proxy :: Proxy a) = a  -- illegal use of a type variable++       Note that the namespace cannot be used to determine if a name refers to a+       type-level entity:++          {-# LANGUAGE RequiredTypeArguments #-}+          bad :: forall (a :: k) -> k+          bad t = t++      The name `t` is assigned the `varName` namespace but stands for a type+      variable that cannot be used at the term level.++      Test cases: T18740a, T18740b, T23739_fail_ret, T23739_fail_case+  -}+  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++     Example(s):+     foo x = True+     foo x y = False++    Test cases: rename/should_fail/rnfail045+                typecheck/should_fail/T20768_fail+  -}+  TcRnMatchesHaveDiffNumArgs+    :: !HsMatchContextRn   -- ^ Pattern match specifics+    -> !MatchArgBadMatches+    -> TcRnMessage++  {-| TcRnUnexpectedPatSigType is an error occurring when there is+      a type signature in a pattern without -XScopedTypeVariables extension++      Examples:+        f (a :: Bool) = ...++      Test case: rename/should_fail/T11663+  -}+  TcRnUnexpectedPatSigType :: HsPatSigType GhcPs -> TcRnMessage++  {-| TcRnIllegalKindSignature is an error occurring when there is+      a kind signature without -XKindSignatures extension++      Examples:+        data Foo (a :: Nat) = ....++      Test case: parser/should_fail/readFail036+  -}+  TcRnIllegalKindSignature :: HsType GhcPs -> TcRnMessage++  {-| TcRnDataKindsError is an error occurring when there is+      an illegal type or kind, probably required -XDataKinds+      and is used without the enabled extension.++      This error can occur in both the renamer and the typechecker. The field+      of type @'Either' ('HsType' 'GhcPs') 'Type'@ reflects this: this field+      will contain a 'Left' value if the error occurred in the renamer, and this+      field will contain a 'Right' value if the error occurred in the+      typechecker.++      Examples:++        type Foo = [Nat, Char]++        type Bar = [Int, String]++      Test cases: linear/should_fail/T18888+                  parser/should_fail/readFail001+                  polykinds/T7151+                  polykinds/T7433+                  rename/should_fail/T13568+                  rename/should_fail/T22478e+                  th/TH_Promoted1Tuple+                  typecheck/should_compile/tcfail094+                  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+                  typecheck/should_fail/T20873d+  -}+  TcRnDataKindsError :: TypeOrKind -> Either (HsType GhcPs) Type -> TcRnMessage++  {-| TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type+     variables cannot be used in pattern bindings.++     Example(s):+     let (x :: a) = 5++     Test cases: typecheck/should_compile/tc141+  -}+  TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage++  {-| TcRnCannotBindTyVarsInPatBind is an error for when type+     variables are introduced in a pattern binding++     Example(s):+     Just @a x = Just True++    Test cases: typecheck/should_fail/TyAppPat_PatternBinding+                typecheck/should_fail/TyAppPat_PatternBindingExistential+  -}+  TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage++  {-| TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas+     reference the same definition.++     Example(s):+     {-# INLINE foo #-}+     {-# INLINE foo #-}+     foo :: Bool -> Bool+     foo = id++    Test cases: none+  -}+  TcRnMultipleInlinePragmas+    :: !Id -- ^ Target of the pragmas+    -> !(LocatedA InlinePragma) -- ^ The first pragma+    -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas+    -> TcRnMessage++  {-| TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear+     in the source.++     Example(s):++    Test cases: none+  -}+  TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage++  {-| TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being+     placed on a definition that is not overloaded.++     Example(s):+     {-# SPECIALISE foo :: Bool -> Bool #-}+     foo :: Bool -> Bool+     foo = id++    Test cases: simplCore/should_compile/T8537+                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.++     Example(s): none++    Test cases: none+  -}+  TcRnSpecialiseNotVisible :: !Name -> TcRnMessage++  {-| TcRnPragmaWarning is a warning that can happen when usage of something+     is warned or deprecated by pragma.++    Test cases:+      DeprU+      T5281+      T5867+      rn050+      rn066 (here is a warning, not deprecation)+      T3303+      ExportWarnings1+      ExportWarnings2+      ExportWarnings3+      ExportWarnings4+      ExportWarnings5+      ExportWarnings6+      InstanceWarnings+  -}+  TcRnPragmaWarning :: {+    pragma_warning_info :: PragmaWarningInfo,+    pragma_warning_msg :: WarningTxt GhcRn+  } -> TcRnMessage++  {-| TcRnDifferentExportWarnings is an error that occurs when the+     warning messages for exports of a name differ between several export items.++     Test case:+      DifferentExportWarnings+  -}+  TcRnDifferentExportWarnings :: !Name -- ^ The name with different export warnings+                              -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that differ+                                            --   from the one at which the error is reported+                              -> TcRnMessage++  {-| TcRnIncompleteExportWarnings is a warning (controlled by -Wincomplete-export-warnings) that+     occurs when some of the exports of a name do not have an export warning and some do++     Test case:+      ExportWarnings6+  -}+  TcRnIncompleteExportWarnings :: !Name -- ^ The name that is exported+                               -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that are+                                             --   missing the export warning+                               -> TcRnMessage++  {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for+     a class default method is provided in a Backpack signature file.++    Test case:+      bkpfail40+  -}+  TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class+                                -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods+                                -> TcRnMessage++  {-| TcRnHsigFixityMismatch is an error indicating that the fixity decl in a+    Backpack signature file differs from the one in the source file for the same+    operator.++    Test cases:+      bkpfail37, bkpfail38+  -}+  TcRnHsigFixityMismatch :: !TyThing -- ^ The operator whose fixity is defined+                         -> !Fixity -- ^ the fixity used in the source file+                         -> !Fixity -- ^ the fixity used in the signature+                         -> TcRnMessage++  {-| TcRnHsigShapeMismatch is a group of errors related to mismatches between+    backpack signatures.+  -}+  TcRnHsigShapeMismatch :: !HsigShapeMismatchReason+                         -> TcRnMessage++  {-| TcRnHsigMissingModuleExport is an error indicating that a module doesn't+    export a name exported by its signature.++    Test cases:+      bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06+  -}+  TcRnHsigMissingModuleExport :: !OccName -- ^ The missing name+                              -> !UnitState -- ^ The module's unit state+                              -> !Module -- ^ The implementation module+                              -> TcRnMessage++  {-| TcRnBadGenericMethod+     This test ensures that if you provide a "more specific" type signatures+     for the default method, you must also provide a binding.++     Example:+     {-# LANGUAGE DefaultSignatures #-}++     class C a where+       meth :: a+       default meth :: Num a => a+       meth = 0++    Test case:+      typecheck/should_fail/MissingDefaultMethodBinding.hs+  -}+  TcRnBadGenericMethod :: !Name   -- ^ 'Name' of the class+                       -> !Name   -- ^ Problematic method+                       -> TcRnMessage++  {-| TcRnWarningMinimalDefIncomplete is a warning that one must+      specify which methods must be implemented by all instances.++     Example:+       class Cheater a where  -- WARNING LINE+       cheater :: a+       {-# MINIMAL #-} -- warning!++     Test case:+       warnings/minimal/WarnMinimal.hs:+  -}+  TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage++  {-| TcRnIllegalQuasiQuotes is an error that occurs when a quasi-quote+      is used without the QuasiQuotes extension.++      Example:++        foo = [myQuoter|x y z|]++      Test cases: none; the parser fails to parse this if QuasiQuotes is off.+  -}+  TcRnIllegalQuasiQuotes :: TcRnMessage++  {-| TcRnTHError is a family of errors involving Template Haskell.+      See 'THError'.+  -}+  TcRnTHError :: THError -> TcRnMessage++  {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when+      a default method pragma is missing an accompanying binding.++    Test cases:+      typecheck/should_fail/T5084.hs+      typecheck/should_fail/T2354.hs+  -}+  TcRnDefaultMethodForPragmaLacksBinding+            :: Id             -- ^ method+            -> Sig GhcRn      -- ^ the pragma+            -> TcRnMessage+  {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when+      a specialise pragma is put on a default method.++    Test cases: none+  -}+  TcRnIgnoreSpecialisePragmaOnDefMethod+            :: !Name+            -> TcRnMessage+  {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method+      in a class instance, when the class doesn't have a method by that name.++     Test case:+       th/T12387+  -}+  TcRnBadMethodErr+    :: { badMethodErrClassName  :: !Name+       , badMethodErrMethodName :: !Name+       } -> TcRnMessage++  {-| TcRnIllegalNewtype is an error that occurs when a newtype:++      * Does not have exactly one field, or+      * is non-linear, or+      * is a GADT, or+      * has a context in its constructor's type, or+      * has existential type variables in its constructor's type, or+      * has strictness annotations.++    Test cases:+      gadt/T14719+      indexed-types/should_fail/T14033+      indexed-types/should_fail/T2334A+      linear/should_fail/LinearGADTNewtype+      parser/should_fail/readFail008+      polykinds/T11459+      typecheck/should_fail/T15523+      typecheck/should_fail/T15796+      typecheck/should_fail/T17955+      typecheck/should_fail/T18891a+      typecheck/should_fail/T21447+      typecheck/should_fail/tcfail156+  -}+  TcRnIllegalNewtype+            :: DataCon+            -> Bool -- ^ True if linear types enabled+            -> IllegalNewtypeReason+            -> TcRnMessage++  {-| TcRnIllegalTypeData is an error that occurs when a @type data@+      declaration occurs without the TypeOperators extension.++      See Note [Type data declarations]++     Test case:+       type-data/should_fail/TDNoPragma+  -}+  TcRnIllegalTypeData :: TcRnMessage++  {-| TcRnTypeDataForbids is an error that occurs when a @type data@+      declaration contains @data@ declaration features that are+      forbidden in a @type data@ declaration.++      See Note [Type data declarations]++     Test cases:+       type-data/should_fail/TDDeriving+       type-data/should_fail/TDRecordsGADT+       type-data/should_fail/TDRecordsH98+       type-data/should_fail/TDStrictnessGADT+       type-data/should_fail/TDStrictnessH98+  -}+  TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage++  {-| TcRnOrPatBindsVariables is an error that happens when an+     or-pattern binds term or type variables, e.g. (A @x; B y).++     Test case:+     testsuite/tests/typecheck/should_fail/Or3+  -}+  TcRnOrPatBindsVariables+    :: NE.NonEmpty (IdP GhcRn) -- ^ List of binders+    -> TcRnMessage++  {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance+       is missing methods that are required by the minimal definition.++       Example:+          class C a where+            foo :: a -> a+          instance C ()        -- | foo needs to be defined here++       Test cases:+         typecheck/prog001/typecheck.prog001+         typecheck/should_compile/tc126+         typecheck/should_compile/T7903+         typecheck/should_compile/tc116+         typecheck/should_compile/tc175+         typecheck/should_compile/HasKey+         typecheck/should_compile/tc125+         typecheck/should_compile/tc078+         typecheck/should_compile/tc161+         typecheck/should_fail/T5051+         typecheck/should_compile/T21583+         backpack/should_compile/bkp47+         backpack/should_fail/bkpfail25+         parser/should_compile/T2245+         parser/should_compile/read014+         indexed-types/should_compile/Class3+         indexed-types/should_compile/Simple2+         indexed-types/should_fail/T7862+         deriving/should_compile/deriving-1935+         deriving/should_compile/T9968a+         deriving/should_compile/drv003+         deriving/should_compile/T4966+         deriving/should_compile/T14094+         perf/compiler/T15304+         warnings/minimal/WarnMinimal+         simplCore/should_compile/simpl020+         deSugar/should_compile/T14546d+         ghci/scripts/T5820+         ghci/scripts/ghci019+  -}+  TcRnUnsatisfiedMinimalDef :: ClassMinimalDef -> TcRnMessage++  {-| 'TcRnMisplacedInstSig' is an error that happens when a method in+       a class instance is given a type signature, but the user has not+       enabled the @InstanceSigs@ extension.++       Test case: module/mod45+  -}+  TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage+  {-| TcRnNoRebindableSyntaxRecordDot is an error triggered by an overloaded record update+      without RebindableSyntax enabled.++      Example(s):++     Test cases: parser/should_fail/RecordDotSyntaxFail5+  -}+  TcRnNoRebindableSyntaxRecordDot :: TcRnMessage++  {-| TcRnNoFieldPunsRecordDot is an error triggered by the use of record field puns+      in an overloaded record update without enabling NamedFieldPuns.++      Example(s):+      print $ a{ foo.bar.baz.quux }++     Test cases: parser/should_fail/RecordDotSyntaxFail12+  -}+  TcRnNoFieldPunsRecordDot :: TcRnMessage++  {-| TcRnIllegalStaticExpression is an error thrown when user creates a static+      pointer via TemplateHaskell without enabling the StaticPointers extension.++      Example(s):++     Test cases: th/T14204+  -}+  TcRnIllegalStaticExpression :: HsExpr GhcPs -> TcRnMessage++  {-| TcRnListComprehensionDuplicateBinding is an error triggered by duplicate+      let-bindings in a list comprehension.++      Example(s):+      [ () | let a = 13 | let a = 17 ]++     Test cases: typecheck/should_fail/tcfail092+  -}+  TcRnListComprehensionDuplicateBinding :: Name -> TcRnMessage++  {-| TcRnEmptyStmtsGroup is an error triggered by an empty list of statements+      in a statement block. For more information, see 'EmptyStatementGroupErrReason'++      Example(s):++        [() | then ()]++        do++        proc () -> do++     Test cases: rename/should_fail/RnEmptyStatementGroup1+  -}+  TcRnEmptyStmtsGroup:: EmptyStatementGroupErrReason -> TcRnMessage++  {-| TcRnLastStmtNotExpr is an error caused by the last statement+      in a statement block not being an expression.++      Example(s):++        do x <- pure ()++        do let x = 5++     Test cases: rename/should_fail/T6060+                 parser/should_fail/T3811g+                 parser/should_fail/readFail028+  -}+  TcRnLastStmtNotExpr+    :: HsStmtContextRn+    -> UnexpectedStatement+    -> TcRnMessage++  {-| TcRnUnexpectedStatementInContext is an error when a statement appears+      in an unexpected context (e.g. an arrow statement appears in a list comprehension).++      Example(s):++     Test cases: parser/should_fail/readFail042+                 parser/should_fail/readFail038+                 parser/should_fail/readFail043+  -}+  TcRnUnexpectedStatementInContext+    :: HsStmtContextRn+    -> UnexpectedStatement+    -> Maybe LangExt.Extension+    -> TcRnMessage++  {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section+      without enabling the TupleSections extension.++      Example(s):+        (5,)++     Test cases: rename/should_fail/rnfail056+  -}+  TcRnIllegalTupleSection :: TcRnMessage++  {-| TcRnIllegalImplicitParameterBindings is an error triggered by binding+      an implicit parameter in an mdo block.++      Example(s):+      mdo { let { ?x = 5 }; () }++     Test cases: rename/should_fail/RnImplicitBindInMdoNotation+  -}+  TcRnIllegalImplicitParameterBindings+    :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs)+    -> TcRnMessage++  {-| TcRnSectionWithoutParentheses is an error triggered by attempting to+      use an operator section without parentheses.++      Example(s):+      (`head` x, ())++     Test cases: rename/should_fail/T2490+                 rename/should_fail/T5657+  -}+  TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage++  {-| TcRnBindingOfExistingName is an error triggered by an attempt to rebind+     built-in syntax, punned list or tuple syntax, or a name quoted via Template Haskell.++     Examples:++       data []+       data (->)+       $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])++     Test cases: rename/should_fail/T14907b+                 rename/should_fail/T22839+                 rename/should_fail/rnfail042+                 th/T13968+  -}+  TcRnBindingOfExistingName :: RdrName -> TcRnMessage+  {-| TcRnMultipleFixityDecls is an error triggered by multiple+      fixity declarations for the same operator.++     Example(s):++       infixr 6 $$+       infixl 4 $$++     Test cases: rename/should_fail/RnMultipleFixityFail+  -}+  TcRnMultipleFixityDecls :: SrcSpan -> RdrName -> TcRnMessage++  {-| TcRnIllegalPatternSynonymDecl is an error thrown when a user+      defines a pattern synonyms without enabling the PatternSynonyms extension.++     Example:++       pattern O :: Int+       pattern O = 0++     Test cases: rename/should_fail/RnPatternSynonymFail+  -}+  TcRnIllegalPatternSynonymDecl :: TcRnMessage++  {-| TcRnIllegalClassBinding is an error triggered by a binding+      in a class or instance declaration of an illegal form.++     Examples:++        class ZeroOne a where+          zero :: a+          one :: a+        instance ZeroOne Int where+          (zero,one) = (0,1)++        class C a where+           pattern P = ()++     Test cases: module/mod48+                 patsyn/should_fail/T9705-1+                 patsyn/should_fail/T9705-2+                 typecheck/should_fail/tcfail021++  -}+  TcRnIllegalClassBinding :: DeclSort -> HsBindLR GhcPs GhcPs -> TcRnMessage++  {-| TcRnOrphanCompletePragma is an error triggered by a {-# COMPLETE #-}+      pragma which does not mention any data constructors or pattern synonyms+      defined in the current module.++     Test cases: patsyn/should_fail/T13349+  -}+  TcRnOrphanCompletePragma :: TcRnMessage++  {-| TcRnEmptyCase is an error thrown when a user uses+      a case expression with an empty list of alternatives without+      enabling the EmptyCase extension.++     Example for EmptyCaseWithoutFlag:++       {-# LANGUAGE NoEmptyCase #-}+       f :: Void -> a+       f = \case {}    -- extension not enabled++     Example for EmptyCaseDisallowedCtxt:++       f = \cases {}   -- multi-case requires n>0 alternatives++     Example for EmptyCaseForall:++       f :: forall (xs :: Type) -> ()+       f = \case {}    -- can't match on a type argument++     Test cases: rename/should_fail/RnEmptyCaseFail+                 typecheck/should_fail/T25004+  -}+  TcRnEmptyCase :: !HsMatchContextRn+                -> !BadEmptyCaseReason+                -> TcRnMessage++  {-| TcRnNonStdGuards is a warning thrown when a user uses+      non-standard guards (e.g. patterns in guards) without+      enabling the PatternGuards extension.+      More realistically: the user has explicitly disabled PatternGuards,+      as it is enabled by default with `-XHaskell2010`.++     Example(s):++       f | 5 <- 2 + 3 = ...++     Test cases: rename/should_compile/rn049+  -}+  TcRnNonStdGuards :: NonStandardGuards -> TcRnMessage++  {-| TcRnDuplicateSigDecl is an error triggered by two or more+      signatures for one entity.++     Examples:++       f :: Int -> Bool+       f :: Int -> Bool+       f _ = True++       g x = x+       {-# INLINE g #-}+       {-# NOINLINE g #-}++       pattern P = ()+       {-# COMPLETE P #-}+       {-# COMPLETE P #-}++     Test cases: module/mod68+                 parser/should_fail/OpaqueParseFail4+                 patsyn/should_fail/T12165+                 rename/should_fail/rnfail048+                 rename/should_fail/T5589+                 rename/should_fail/T7338+                 rename/should_fail/T7338a+  -}+  TcRnDuplicateSigDecl :: NE.NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRnMessage++  {-| TcRnMisplacedSigDecl is an error triggered by the pragma application+      in the wrong context, like `MINIMAL` applied to a function or+      `SPECIALIZE` to an instance.++     Example:++       f x = x+       {-# MINIMAL f #-}++     Test cases: rename/should_fail/T18138+                 warnings/minimal/WarnMinimalFail1+  -}+  TcRnMisplacedSigDecl :: Sig GhcRn -> TcRnMessage++  {-| TcRnUnexpectedDefaultSig is an error thrown when a user uses+      default signatures without enabling the DefaultSignatures extension.++     Example:++       class C a where+         m :: a+         default m :: Num a => a+         m = 0++     Test cases: rename/should_fail/RnDefaultSigFail+  -}+  TcRnUnexpectedDefaultSig :: Sig GhcPs -> TcRnMessage++  {-| TcRnDuplicateMinimalSig is an error triggered by two or more minimal+      signatures for one type class.++     Example:++       class C where+         f :: ()+         {-# MINIMAL f #-}+         {-# MINIMAL f #-}++     Test cases: rename/should_fail/RnMultipleMinimalPragmaFail+  -}+  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.++      Example:+        {-# LANGUAGE NoTypeAbstractions #-}         -- extension disabled+        data T @k (a :: k) @(j :: Type) (b :: j)+               ^^          ^^^^^^^^^^^^++      Test case: T22560_fail_ext+  -}+  TcRnIllegalInvisTyVarBndr+    :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)+    -> TcRnMessage++  {-| 'TcRnIllegalWildcardTyVarBndr' is an error that occurs+      when a wildcard binder is used in a type declaration+      without enabling the @TypeAbstractions@ extension.++      Example:+        {-# LANGUAGE NoTypeAbstractions #-}         -- extension disabled+        type Const a _ = a+                     ^++      Test case: T23501_fail_ext+  -}+  TcRnIllegalWildcardTyVarBndr+    :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)+    -> TcRnMessage++  {-| 'TcRnInvalidInvisTyVarBndr' is an error that occurs+      when an invisible type variable binder has no corresponding+      @forall k.@ quantifier in the standalone kind signature.++      Example:+        type P :: forall a -> Type+        data P @a = MkP++      Test cases: T22560_fail_a T22560_fail_b+  -}+  TcRnInvalidInvisTyVarBndr+    :: !Name+    -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)+    -> TcRnMessage++  {-| 'TcRnInvisBndrWithoutSig' is an error triggered by attempting to use+      an invisible type variable binder in a type declaration without a+      standalone kind signature or a complete user-supplied kind.++      Example:+        data T @k (a :: k)     -- No CUSK, no SAKS++      Test case: T22560_fail_d+  -}+  TcRnInvisBndrWithoutSig+    :: !Name+    -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn)+    -> TcRnMessage++  {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses+      standalone deriving without enabling the StandaloneDeriving extension.++      Example:++        deriving instance Eq Foo++      Test cases: rename/should_fail/RnUnexpectedStandaloneDeriving+  -}+  TcRnUnexpectedStandaloneDerivingDecl :: TcRnMessage++  {-| TcRnUnusedVariableInRuleDecl is an error triggered by forall'd variable in+      rewrite rule that does not appear on left-hand side++      Example:++        {-# RULES "rule" forall a. id = id #-}++      Test cases: rename/should_fail/ExplicitForAllRules2+  -}+  TcRnUnusedVariableInRuleDecl :: FastString -> Name -> TcRnMessage++  {-| TcRnUnexpectedStandaloneKindSig is an error thrown when a user uses standalone+      kind signature without enabling the StandaloneKindSignatures extension.++      Example:++        type D :: Type+        data D = D++      Test cases: saks/should_fail/saks_fail001+  -}+  TcRnUnexpectedStandaloneKindSig :: TcRnMessage++  {-| TcRnIllegalRuleLhs is an error triggered by malformed left-hand side+      of rewrite rule++      Examples:++        {-# RULES "test" forall x. f x = x #-}++        {-# RULES "test" forall x. case x of = x #-}++      Test cases: rename/should_fail/T15659+  -}+  TcRnIllegalRuleLhs+    :: RuleLhsErrReason+    -> 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++      Example:++        data D a+        type role D phantom+        type role D phantom++      Test cases: roles/should_fail/Roles8+  -}+  TcRnDuplicateRoleAnnot :: NE.NonEmpty (LRoleAnnotDecl GhcPs) -> TcRnMessage++  {-| TcRnDuplicateKindSig is an error triggered by two or more standalone+      kind signatures for one type++      Example:++        type D :: Type+        type D :: Type+        data D++      Test cases: saks/should_fail/saks_fail002+  -}+  TcRnDuplicateKindSig :: NE.NonEmpty (LStandaloneKindSig GhcPs) -> TcRnMessage++  {-| TcRnIllegalDerivStrategy  is an error thrown when a user uses deriving+      strategy without enabling the DerivingStrategies extension or uses deriving+      via without enabling the DerivingVia extension.++      Examples:++        data T = T deriving stock Eq++        data T = T deriving via Eq T++      Test cases: deriving/should_fail/deriving-via-fail3+                  deriving/should_fail/T10598_fail4+  -}+  TcRnIllegalDerivStrategy :: DerivStrategy GhcPs -> TcRnMessage++  {-| TcRnIllegalMultipleDerivClauses is an error thrown when a user uses two or more+      deriving clauses without enabling the DerivingStrategies extension.++      Example:++        data T = T+          deriving Eq+          deriving Ord++      Test cases: deriving/should_fail/T10598_fail5+  -}+  TcRnIllegalMultipleDerivClauses :: TcRnMessage++  {-| TcRnNoDerivStratSpecified is a warning implied by+      -Wmissing-deriving-strategies and triggered by deriving without+      mentioning a strategy.++      See 'TcRnNoDerivStratSpecifiedInfo' cases for examples.++      Test cases: deriving/should_compile/T15798a+                  deriving/should_compile/T15798b+                  deriving/should_compile/T15798c+                  deriving/should_compile/T24955a+                  deriving/should_compile/T24955b+                  deriving/should_compile/T24955c+  -}+  TcRnNoDerivStratSpecified+    :: Bool -- ^ True if DerivingStrategies is enabled+    -> TcRnNoDerivStratSpecifiedInfo+    -> TcRnMessage++  {-| TcRnStupidThetaInGadt is an error triggered by data contexts in GADT-style+      data declaration++      Example:++        data (Eq a) => D a where+          MkD :: D Int++      Test cases: rename/should_fail/RnStupidThetaInGadt+  -}+  TcRnStupidThetaInGadt :: HsDocContext -> TcRnMessage++  {-| TcRnShadowedTyVarNameInFamResult is an error triggered by type variable in+      type family result that shadows type variable from left hand side++      Example:++        type family F a b c = b++      Test cases: ghci/scripts/T6018ghcirnfail+                  rename/should_fail/T6018rnfail+  -}+  TcRnShadowedTyVarNameInFamResult :: IdP GhcPs -> TcRnMessage++  {-| TcRnIncorrectTyVarOnRhsOfInjCond is an error caused by a situation where the+      left-hand side of an injectivity condition of a type family is not a variable+      referring to the type family result.+      See Note [Renaming injectivity annotation] for more details.++      Example:++        type family F a = r | a -> a++      Test cases: ghci/scripts/T6018ghcirnfail+                  rename/should_fail/T6018rnfail+  -}+  TcRnIncorrectTyVarOnLhsOfInjCond+    :: IdP GhcRn -- Expected+    -> LIdP GhcPs -- Actual+    -> TcRnMessage++  {-| TcRnUnknownTyVarsOnRhsOfInjCond is an error triggered by out-of-scope type+      variables on the right-hand side of a of an injectivity condition of a type family++      Example:++        type family F a = res | res -> b++      Test cases: ghci/scripts/T6018ghcirnfail+                  rename/should_fail/T6018rnfail+  -}+  TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage++  {-| TcRnLookupInstance groups several errors emitted when looking up class instances.++    Test cases:+      none+  -}+  TcRnLookupInstance+    :: !Class+    -> ![Type]+    -> !LookupInstanceErrReason+    -> TcRnMessage++  {-| TcRnBadlyLevelled is an error that occurs when a TH binding is used at an+      invalid level.++    Test cases:+      T17820d, T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}+  -}+  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++  {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is+    used in an invalid stage.++    Controlled by flags:+       - Wbadly-levelled-type++    Test cases:+      T23829_timely T23829_tardy T23829_hasty+  -}+  TcRnBadlyLevelledType+    :: !Name  -- ^ The type binding being spliced.+    -> !(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+    thing was expected.++    Test cases:+      none+  -}+  TcRnTyThingUsedWrong+    :: !WrongThingSort -- ^ Expected thing.+    -> !TcTyThing -- ^ Thing used wrongly.+    -> !Name -- ^ Name of the thing used wrongly.+    -> TcRnMessage++  {-| TcRnCannotDefaultKindVar is an error that occurs when attempting to use+    unconstrained kind variables whose type isn't @Type@, without -XPolyKinds.++    Test cases:+      T11334b+  -}+  TcRnCannotDefaultKindVar+    :: !TyVar -- ^ The unconstrained variable.+    -> !Kind -- ^ Kind of the variable.+    -> TcRnMessage++  {-| TcRnUninferrableTyVar is an error that occurs when metavariables+    in a type could not be defaulted.++    Test cases:+      T17301, T17562, T17567, T17567StupidTheta, T15474, T21479+  -}+  TcRnUninferrableTyVar+    :: ![TyCoVar] -- ^ The variables that could not be defaulted.+    -> !UninferrableTyVarCtx -- ^ Description of the surrounding context.+    -> TcRnMessage++  {-| TcRnSkolemEscape is an error that occurs when type variables from an+    outer scope is used in a context where they should be locally scoped.++    Test cases:+      T15076, T15076b, T14880-2, T15825, T14880, T15807, T16946, T14350,+      T14040A, T15795, T15795a, T14552+  -}+  TcRnSkolemEscape+    :: ![TcTyVar] -- ^ The variables that would escape.+    -> !TcTyVar -- ^ The variable that is being quantified.+    -> !Type -- ^ The type in which they occur.+    -> TcRnMessage++  {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from+    a pattern synonym into a type.+    See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn++    Test cases:+      T14507+  -}+  TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable+                            -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions+                            -> TcRnMessage++  {-| TcRnPatSynExistentialInResult is an error indicating that the result type+    of a pattern synonym mentions an existential type variable.++    Test cases:+      PatSynExistential+  -}+  TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym+                                -> !TcSigmaType -- ^ The result type+                                -> ![TyVar] -- ^ The escaped existential variables+                                -> TcRnMessage++  {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a+    pattern synonym's equation differs from the number of parameters in its+    signature.++    Test cases:+      PatSynArity+  -}+  TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym+                          -> !Arity -- ^ The number of equation arguments+                          -> !Arity -- ^ The difference+                          -> TcRnMessage++  {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the+    right hand side of a pattern synonym is invalid.++    Test cases:+      unidir, T14112+  -}+  TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym+                       -> !(LPat GhcRn) -- ^ The pattern+                       -> ![LIdP GhcRn] -- ^ The LHS args+                       -> !PatSynInvalidRhsReason -- ^ The number of equation arguments+                       -> TcRnMessage++  {-| TcRnZonkerMessage is collection of errors that occur when zonking,+      i.e. filling in metavariables with their final values.++      See 'ZonkerMessage'+  -}+  TcRnZonkerMessage :: ZonkerMessage -> TcRnMessage++  {-| TcRnTyFamDepsDisabled is an error indicating that a type family injectivity+    annotation was used without enabling the extension TypeFamilyDependencies.++    Test cases:+      T11381+  -}+  TcRnTyFamDepsDisabled :: TcRnMessage++  {-| TcRnAbstractClosedTyFamDecl is an error indicating that an abstract closed+    type family was declared in a regular source file, while it is only allowed+    in hs-boot files.++    Test cases:+      ClosedFam4+  -}+  TcRnAbstractClosedTyFamDecl :: TcRnMessage++  {-| TcRnPartialFieldSelector is a warning indicating that a record field+    was not defined for all constructors of a data type.++    Test cases:+      DRFPartialFields, T7169+  -}+  TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector+                           -> TcRnMessage++  {-| TcRnHasFieldResolvedIncomplete is a warning triggered when a HasField constraint+      is resolved for a record field for which a `getField @"field"` application+      might not be successful. Currently, this means that the warning is triggered when+      the parent data type of that record field does not have that field in all+      its constructors.++      Example(s):+      data T = T1 | T2 {x :: Bool}+      f :: HasField t "x" Bool => t -> Bool+      f = getField @"x"+      g :: T -> Bool+      g = f++     Test cases:+       TcIncompleteRecSel+  -}+  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.+  -}+  TcRnBadFieldAnnotation :: !Int -- ^ The index of the field+                         -> !DataCon -- ^ The constructor in which the field is defined+                         -> !BadFieldAnnotationReason -- ^ The error specifics+                         -> TcRnMessage++  {-| TcRnSuperclassCycle is an error indicating that a class has a superclass+    cycle.++    Test cases:+      mod40, tcfail027, tcfail213, tcfail216, tcfail217, T9415, T9739+  -}+  TcRnSuperclassCycle :: !SuperclassCycle -- ^ The details of the cycle+                      -> TcRnMessage++  {-| TcRnDefaultSigMismatch is an error indicating that a default method+    signature doesn't match the regular method signature.++    Test cases:+      T7437, T12918a, T12918b, T12151+  -}+  TcRnDefaultSigMismatch :: !Id -- ^ The name of the method+                         -> !Type -- ^ The type of the default signature+                         -> TcRnMessage++  {-| TcRnTyFamsDisabled is an error indicating that a type family or instance+    was declared while the extension TypeFamilies was disabled.++    Test cases:+      TyFamsDisabled+  -}+  TcRnTyFamsDisabled :: !TyFamsDisabledReason -- ^ The name of the family or instance+                     -> TcRnMessage++  {-| TcRnBadTyConTelescope is an error caused by an ill-scoped 'TyCon' kind,+     due to type variables being out of dependency order.++     Example:++      class C a (b :: Proxy a) (c :: Proxy b) where+        type T c a++     Test cases:+       BadTelescope{∅,3,4}+       T14066{f,g}+       T14887+       T15591{b,c}+       T15743{c,d}+       T15764+       T23252++  -}+  TcRnBadTyConTelescope :: !TyCon -> TcRnMessage++  {-| TcRnTyFamResultDisabled is an error indicating that a result variable+    was used on a type family while the extension TypeFamilyDependencies was+    disabled.++    Test cases:+      T13571, T13571a+  -}+  TcRnTyFamResultDisabled :: !Name -- ^ The name of the type family+                          -> !(LHsTyVarBndr () GhcRn) -- ^ Name of the result variable+                          -> TcRnMessage++  {-| TcRnRoleValidationFailed is an error indicating that a variable was+    assigned an invalid role by the inference algorithm.+    This is only performed with -dcore-lint.+  -}+  TcRnRoleValidationFailed :: !Role -- ^ The validated role+                           -> !RoleValidationFailedReason -- ^ The failure reason+                           -> TcRnMessage++  {-| TcRnCommonFieldResultTypeMismatch is an error indicating that a sum type+    declares the same field name in multiple constructors, but the constructors'+    result types differ.++    Test cases:+      CommonFieldResultTypeMismatch+  -}+  TcRnCommonFieldResultTypeMismatch :: !DataCon -- ^ First constructor+                                    -> !DataCon -- ^ Second constructor+                                    -> !FieldLabelString -- ^ Field name+                                    -> TcRnMessage++  {-| TcRnCommonFieldTypeMismatch is an error indicating that a sum type+    declares the same field name in multiple constructors, but their types+    differ.++    Test cases:+      CommonFieldTypeMismatch+  -}+  TcRnCommonFieldTypeMismatch :: !DataCon -- ^ First constructor+                              -> !DataCon -- ^ Second constructor+                              -> !FieldLabelString -- ^ Field name+                              -> TcRnMessage++  {-| TcRnClassExtensionDisabled is an error indicating that a class+    was declared with an extension feature while the extension was disabled.+  -}+  TcRnClassExtensionDisabled :: !Class -- ^ The class+                             -> !DisabledClassExtension -- ^ The extension+                             -> TcRnMessage++  {-| TcRnDataConParentTypeMismatch is an error indicating that a data+    constructor was declared with a type that doesn't match its type+    constructor (i.e. a GADT result type and its data name).++    Test cases:+      T7175, T13300, T14719, T18357, T18357b, gadt11, tcfail155, tcfail176+  -}+  TcRnDataConParentTypeMismatch :: !DataCon -- ^ The data constructor+                                -> !Type -- ^ The parent type+                                -> TcRnMessage++  {-| TcRnGADTsDisabled is an error indicating that a GADT was declared+    while the extension GADTs was disabled.++    Test cases:+      ghci057, T9293+  -}+  TcRnGADTsDisabled :: !Name -- ^ The name of the GADT+                    -> TcRnMessage++  {-| TcRnExistentialQuantificationDisabled is an error indicating that+    a data constructor was declared with existential features while the+    extension ExistentialQuantification was disabled.++    Test cases:+      ghci057, T9293, gadtSyntaxFail001, gadtSyntaxFail002, gadtSyntaxFail003,+      prog006, rnfail053, T12083a+  -}+  TcRnExistentialQuantificationDisabled :: !DataCon -- ^ The constructor+                                        -> TcRnMessage++  {-| TcRnGADTDataContext is an error indicating that a GADT was declared with a+    data type context.+    This error is emitted in the tc, but it is also caught in the renamer.+  -}+  TcRnGADTDataContext :: !Name -- ^ The data type name+                      -> TcRnMessage++  {-| TcRnMultipleConForNewtype is an error indicating that a newtype was+    declared with multiple constructors.+    This error is caught by the parser.+  -}+  TcRnMultipleConForNewtype :: !Name -- ^ The newtype name+                            -> !Int -- ^ The number of constructors+                            -> TcRnMessage++  {-| TcRnKindSignaturesDisabled is an error indicating that a kind signature+    was used in a data type declaration while the extension KindSignatures was+    disabled.++    Test cases:+      T20873c, readFail036+  -}+  TcRnKindSignaturesDisabled :: !(Either (HsType GhcPs) (Name, HsType GhcRn))+                                -- ^ The data type name+                             -> TcRnMessage++  {-| TcRnEmptyDataDeclsDisabled is an error indicating that a data type+    was declared with no constructors while the extension EmptyDataDecls was+    disabled.++    Test cases:+      readFail035+  -}+  TcRnEmptyDataDeclsDisabled :: !Name -- ^ The data type name+                             -> TcRnMessage++  {-| TcRnRoleMismatch is an error indicating that the role specified+    in an annotation differs from its inferred role.++    Test cases:+      T7253, Roles11+  -}+  TcRnRoleMismatch :: !Name -- ^ The type variable+                   -> !Role -- ^ The annotated role+                   -> !Role -- ^ The inferred role+                   -> TcRnMessage++  {-| TcRnRoleCountMismatch is an error indicating that the number of+    roles in an annotation doesn't match the number of type parameters.++    Test cases:+      Roles6+  -}+  TcRnRoleCountMismatch :: !Int -- ^ The number of type variables+                        -> !(LRoleAnnotDecl GhcRn) -- ^ The role annotation+                        -> TcRnMessage++  {-| TcRnIllegalRoleAnnotation is an error indicating that a role+    annotation was attached to a decl that doesn't allow it.++    Test cases:+      Roles5+  -}+  TcRnIllegalRoleAnnotation :: !(RoleAnnotDecl GhcRn) -- ^ The role annotation+                            -> TcRnMessage++  {-| TcRnRoleAnnotationsDisabled is an error indicating that a role+    annotation was declared while the extension RoleAnnotations was disabled.++    Test cases:+      Roles5, TH_Roles1+  -}+  TcRnRoleAnnotationsDisabled :: !TyCon -- ^ The annotated type+                              -> TcRnMessage++  {-| TcRnIncoherentRoles is an error indicating that a role+    annotation for a class parameter was declared as not nominal.++    Test cases:+      T8773+  -}+  TcRnIncoherentRoles :: !TyCon -- ^ The class tycon+                      -> TcRnMessage+  {-| TcRnPrecedenceParsingError is an error caused by attempting to+      use operators with the same precedence in one infix expression.++      Example:+        eq :: (a ~ b ~ c) :~: ()++      Test cases: module/mod61+                  parser/should_fail/readFail016+                  rename/should_fail/rnfail017+                  rename/should_fail/T9077+                  typecheck/should_fail/T18252a+  -}+  TcRnPrecedenceParsingError+    :: (OpName, Fixity) -- ^ first operator's name and fixity+    -> (OpName, Fixity) -- ^ second operator's name and fixity+    -> TcRnMessage++  {-| TcRnPrecedenceParsingError is an error caused by attempting to+      use an operator with higher precedence than the operand.++      Example:+        k = (-3 **)+          where+                (**) = const+                infixl 7 **++      Test cases: overloadedrecflds/should_fail/T13132_duplicaterecflds+                  parser/should_fail/readFail023+                  rename/should_fail/rnfail019+                  th/TH_unresolvedInfix2+  -}+  TcRnSectionPrecedenceError+    :: (OpName, Fixity) -- ^ first operator's name and fixity+    -> (OpName, Fixity) -- ^ argument operator+    -> HsExpr GhcPs -- ^ Section+    -> TcRnMessage++  {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type+    synonyms has occurred.++    Test cases:+      mod27, ghc-e-fail2, bkpfail29+  -}+  TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle+                       -> TcRnMessage++  {-| TcRnSelfImport is an error indicating that a module contains an+    import of itself.++    Test cases:+      T9032+  -}+  TcRnSelfImport :: !ModuleName -- ^ The module+                 -> TcRnMessage++  {-| TcRnNoExplicitImportList is a warning indicating that an import+      statement did not include an explicit import list.++    Test cases:+      T1789, T4489+  -}+  TcRnNoExplicitImportList :: !ModuleName -- ^ The imported module+                           -> TcRnMessage++  {-| TcRnSafeImportsDisabled is an error indicating that an import was+    declared using the @safe@ keyword while SafeHaskell wasn't active.++    Test cases:+      Mixed01+  -}+  TcRnSafeImportsDisabled :: !ModuleName -- ^ The imported module+                           -> TcRnMessage++  {-| TcRnDeprecatedModule is a warning indicating that an imported module+    is annotated with a warning or deprecation pragma.++    Test cases:+      DeprU+  -}+  TcRnDeprecatedModule :: !ModuleName -- ^ The imported module+                       -> !(WarningTxt GhcRn) -- ^ The pragma data+                       -> TcRnMessage++  {-| TcRnRedundantSourceImport is a warning indicating that a {-# SOURCE #-}+    import was used when there is no import cycle.++    Test cases:+      none+  -}+  TcRnRedundantSourceImport :: !ModuleName -- ^ The imported module+                            -> TcRnMessage++  {-| TcRnImportLookup is a group of errors about bad imported names.+  -}+  TcRnImportLookup :: !ImportLookupReason -- ^ Details about the error+                   -> TcRnMessage++  {-| TcRnUnusedImport is a group of errors about unused imports.+  -}+  TcRnUnusedImport :: !(ImportDecl GhcRn) -- ^ The import+                   -> !UnusedImportReason -- ^ Details about the error+                   -> TcRnMessage++  {-| TcRnDuplicateDecls is an error indicating that the same name was used for+    multiple declarations.++    Test cases:+      FieldSelectors, overloadedrecfldsfail03, T17965, NFSDuplicate, T9975a,+      TDMultiple01, mod19, mod38, mod21, mod66, mod20, TDPunning, mod18, mod22,+      TDMultiple02, T4127a, ghci048, T8932, rnfail015, rnfail010, rnfail011,+      rnfail013, rnfail002, rnfail003, rn_dup, rnfail009, T7164, rnfail043,+      TH_dupdecl, rnfail012+  -}+  TcRnDuplicateDecls :: !OccName -- ^ The name of the declarations+                     -> !(NE.NonEmpty Name) -- ^ The individual declarations+                     -> TcRnMessage++  {-| TcRnPackageImportsDisabled is an error indicating that an import uses+    a package qualifier while the extension PackageImports was disabled.++    Test cases:+      PackageImportsDisabled+  -}+  TcRnPackageImportsDisabled :: TcRnMessage++  {-| TcRnIllegalDataCon is an error indicating that a data constructor was+    defined using a lowercase name, or a symbolic name in prefix position.+    Mostly caught by PsErrNotADataCon.++    Test cases:+      None+  -}+  TcRnIllegalDataCon :: !RdrName -- ^ The constructor name+                     -> TcRnMessage++  {-| TcRnNestedForallsContexts is an error indicating that multiple foralls or+    contexts are nested/curried where this is not supported,+    like @∀ x. ∀ y.@ instead of @∀ x y.@.++    Test cases:+      T12087, T14320, T16114, T16394, T16427, T18191, T18240a, T18240b, T18455, T5951+  -}+  TcRnNestedForallsContexts :: !NestedForallsContextsIn -> TcRnMessage++  {-| TcRnRedundantRecordWildcard is a warning indicating that a pattern uses+    a record wildcard even though all of the record's fields are bound explicitly.++    Test cases:+      T15957_Fail+  -}+  TcRnRedundantRecordWildcard :: TcRnMessage++  {-| TcRnUnusedRecordWildcard is a warning indicating that a pattern uses+    a record wildcard while none of the fields bound by it are used.++    Test cases:+      T15957_Fail+  -}+  TcRnUnusedRecordWildcard :: ![Name] -- ^ The names bound by the wildcard+                           -> TcRnMessage++  {-| TcRnUnusedName is a warning indicating that a defined or imported name+    is not used in the module.++    Test cases:+      ds053, mc10, overloadedrecfldsfail05, overloadedrecfldsfail06, prog018,+      read014, rn040, rn041, rn047, rn063, T13839, T13839a, T13919, T17171b,+      T17a, T17b, T17d, T17e, T18470, T1972, t22391, t22391j, T2497, T3371,+      T3449, T7145b, T7336, TH_recover_warns, unused_haddock, WarningGroups,+      werror+  -}+  TcRnUnusedName :: !OccName -- ^ The unused name+                 -> !UnusedNameProv -- ^ The provenance of the name+                 -> TcRnMessage++  {-| TcRnQualifiedBinder is an error indicating that a qualified name+    was used in binding position.++    Test cases:+      mod62, rnfail021, rnfail034, rnfail039, rnfail046+  -}+  TcRnQualifiedBinder :: !RdrName -- ^ The name used as a binder+                      -> TcRnMessage++  {-| TcRnTypeApplicationsDisabled is an error indicating that a type+    application was used while the extension TypeApplications was disabled.++    Test cases:+      T12411, T12446, T15527, T16133, T18251c+  -}+  TcRnTypeApplicationsDisabled :: !(HsType GhcPs)+                               -> !TypeOrKind+                               -> TcRnMessage++  {-| TcRnInvalidRecordField is an error indicating that a record field was+    used that doesn't exist in a constructor.++    Test cases:+      T13644, T13847, T17469, T8448, T8570, tcfail083, tcfail084+  -}+  TcRnInvalidRecordField :: !Name -- ^ The constructor name+                         -> !FieldLabelString -- ^ The name of the field+                         -> TcRnMessage++  {-| TcRnTupleTooLarge is an error indicating that the arity of a tuple+    exceeds mAX_TUPLE_SIZE.++    Test cases:+      T18723a, T18723b, T18723c, T6148a, T6148b, T6148c, T6148d+  -}+  TcRnTupleTooLarge :: !Int -- ^ The arity of the tuple+                    -> TcRnMessage++  {-| TcRnCTupleTooLarge is an error indicating that the arity of a constraint+    tuple exceeds mAX_CTUPLE_SIZE.++    Test cases:+      T10451+  -}+  TcRnCTupleTooLarge :: !Int -- ^ The arity of the constraint tuple+                     -> TcRnMessage++  {-| TcRnIllegalInferredTyVars is an error indicating that some type variables+    were quantified as inferred (like @∀ {a}.@) in a place where this is not+    allowed, like in an instance declaration.++    Test cases:+      ExplicitSpecificity5, ExplicitSpecificity6, ExplicitSpecificity8,+      ExplicitSpecificity9+  -}+  TcRnIllegalInferredTyVars :: !(NE.NonEmpty (HsTyVarBndr Specificity GhcPs))+                              -- ^ The offending type variables+                           -> TcRnMessage++  {-| TcRnAmbiguousName is an error indicating that an unbound name+    might refer to multiple names in scope.++    Test cases:+      BootFldReexport, DRFUnused, duplicaterecfldsghci01, GHCiDRF, mod110,+      mod151, mod152, mod153, mod164, mod165, NoFieldSelectorsFail,+      overloadedrecfldsfail02, overloadedrecfldsfail04, overloadedrecfldsfail11,+      overloadedrecfldsfail12, overloadedrecfldsfail13,+      overloadedrecfldswasrunnowfail06, rnfail044, T11167_ambig,+      T11167_ambiguous_fixity, T13132_duplicaterecflds, T15487, T16745, T17420,+      T18999_NoDisambiguateRecordFields, T19397E1, T19397E2, T23010_fail,+      tcfail037+  -}+  TcRnAmbiguousName :: !GlobalRdrEnv+                    -> !RdrName -- ^ The name+                    -> !(NE.NonEmpty GlobalRdrElt) -- ^ The possible matches+                    -> TcRnMessage++  {-| TcRnBindingNameConflict is an error indicating that multiple local or+    top-level bindings have the same name.++    Test cases:+      dsrun006, mdofail002, mdofail003, mod23, mod24, qq006, rnfail001,+      rnfail004, SimpleFail6, T14114, T16110_Fail1, tcfail038, TH_spliceD1,+      T22478b, TyAppPat_NonlinearMultiAppPat, TyAppPat_NonlinearMultiPat,+      TyAppPat_NonlinearSinglePat,+  -}+  TcRnBindingNameConflict :: !RdrName -- ^ The conflicting name+                          -> !(NE.NonEmpty SrcSpan)+                             -- ^ The locations of the duplicates+                          -> TcRnMessage++  {-| TcRnNonCanonicalDefinition is a warning indicating that an instance+    defines an implementation for a method that should not be defined in a way+    that deviates from its default implementation, for example because it has+    been scheduled to be absorbed into another method, like @pure@ making+    @return@ obsolete.++    Test cases:+      WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff+  -}+  TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics+                             -> !(LHsSigType GhcRn) -- ^ The instance type+                             -> TcRnMessage+  {-| TcRnImplicitImportOfPrelude is a warning, controlled by @Wimplicit-prelude@,+      that is triggered upon an implicit import of the @Prelude@ module.++      Example:++        {-# OPTIONS_GHC -fwarn-implicit-prelude #-}+        module M where {}++      Test case: rn055++  -}+  TcRnImplicitImportOfPrelude :: TcRnMessage++  {-| TcRnMissingMain is an error that occurs when a Main module does+      not define a main function (named @main@ by default, but overridable+      with the @main-is@ command line flag).++      Example:++        module Main where {}++      Test cases:+        T414, T7765, readFail021, rnfail007, T13839b, T17171a, T16453E1, tcfail030,+        T19397E3, T19397E4++  -}+  TcRnMissingMain+    :: !Bool -- ^ whether the module has an explicit export list+    -> !Module+    -> !OccName -- ^ the expected name of the main function+    -> TcRnMessage++  {-| TcRnGhciUnliftedBind is an error that occurs when a user attempts to+      bind an unlifted value in GHCi.++      Example (in GHCi):++        let a = (# 1#, 3# #)++      Test cases: T9140, T19035b+  -}+  TcRnGhciUnliftedBind :: !Id -> TcRnMessage++  {-| TcRnGhciMonadLookupFail is an error that occurs when the user sets+      the GHCi monad, using the GHC API 'setGHCiMonad' function, but GHC+      can't find which monad the user is referring to.++      Example:++        import GHC ( setGHCiMonad )++        ... setGHCiMonad "NoSuchThing"++      Test cases: none+  -}+  TcRnGhciMonadLookupFail+    :: String -- ^ the textual name of the monad requested by the user+    -> Maybe [GlobalRdrElt] -- ^ lookup result+    -> TcRnMessage++  {-| TcRnMissingRoleAnnotation is a warning that occurs when type declaration+     doesn't have a role annotatiosn++     Controlled by flags:+       - Wmissing-role-annotations++     Test cases:+       T22702++  -}+  TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage+  {-| TcRnPatersonCondFailure is an error that occurs when an instance+      declaration fails to conform to the Paterson conditions. Which particular condition+      fails depends on the constructor of PatersonCondFailure+      See Note [Paterson conditions].++      Test cases:+        T15231, tcfail157, T15316, T19187a, fd-loop, tcfail108, tcfail154,+        T15172, tcfail214+  -}+  TcRnPatersonCondFailure+    :: PatersonCondFailure -- ^ the failed Paterson Condition+    -> PatersonCondFailureContext+    -> Type                -- ^ the LHS+    -> Type                -- ^ the RHS+    -> TcRnMessage++  {-| TcRnImplicitRhsQuantification is a warning that occurs when GHC implicitly+      quantifies over a type variable that occurs free on the RHS of the type declaration+      that is not mentioned on the LHS++      Example:++        type T = 'Nothing :: Maybe a++      Controlled by flags:+       - Wimplicit-rhs-quantification++      Test cases:+          T23510a+          T23510b+  -}+  TcRnImplicitRhsQuantification :: LocatedN RdrName -> TcRnMessage++  {-| TcRnIllformedTypePattern is an error raised when the pattern+      corresponding to a required type argument (visible forall)+      does not have a form that can be interpreted as a type pattern.++      Example:++        vfun :: forall (a :: k) -> ()+        vfun !x = ()+        --   ^^+        -- bang-patterns not allowed as type patterns++      Test cases:+          T22326_fail_bang_pat+  -}+  TcRnIllformedTypePattern :: !(Pat GhcRn) -> TcRnMessage++  {-| TcRnIllegalTypePattern is an error raised when a pattern constructed+      with the @type@ keyword occurs in a position that does not correspond+      to a required type argument (visible forall).++      Example:++        case x of+          (type _) -> True     -- the (type _) pattern is illegal here+          _        -> False++      Test cases:+        T22326_fail_ado+        T22326_fail_caseof+  -}+  TcRnIllegalTypePattern :: TcRnMessage++  {-| TcRnIllformedTypeArgument is an error raised when an argument+      that specifies a required type argument (instantiates a visible forall)+      does not have a form that can be interpreted as a type argument.++      Example:++        vfun :: forall (a :: k) -> ()+        x = vfun (\_ -> _)+        --       ^^^^^^^^^+        -- lambdas not allowed in type arguments++      Test cases:+        T22326_fail_lam_arg+  -}+  TcRnIllformedTypeArgument :: !(LHsExpr GhcRn) -> TcRnMessage++  {- TcRnIllegalTypeExpr is an error raised when an expression constructed with+     type syntax (@type@, @->@, @=>@, @forall@) occurs in a position that+     doesn't correspond to required type argument (visible forall).++     Examples:++        -- Not a function argument:+        xtop1 = type Int+        xtop2 = (Int -> Int)+        xtop3 = (forall a. a)+        xtop4 = ((Show Int, Eq Bool) => Unit)++        -- The function does not expect a type argument:+        xarg1 = length (type Int)+        xarg2 = show (Int -> Int)++     Test cases:+        T22326_fail_app+        T22326_fail_top+        T24159_type_syntax_tc_fail+  -}+  TcRnIllegalTypeExpr :: TypeSyntax -> TcRnMessage++  {-| TcRnInvalidDefaultedTyVar is an error raised when a+      defaulting plugin proposes to default a type variable that is+      not an unfilled metavariable++      Test cases:+        T23832_invalid+  -}+  TcRnInvalidDefaultedTyVar+      :: ![Ct]                -- ^ The constraints passed to the plugin+      -> [(TcTyVar, Type)]    -- ^ The plugin-proposed type variable defaults+      -> NE.NonEmpty TcTyVar  -- ^ The invalid type variables of the proposal+      -> TcRnMessage++  {-| TcRnNamespacedWarningPragmaWithoutFlag is an error that occurs when+      a namespace specifier is used in {-# WARNING ... #-} or {-# DEPRECATED ... #-}+      pragmas without the -XExplicitNamespaces extension enabled++      Example:++        {-# LANGUAGE NoExplicitNamespaces #-}+        f = id+        {-# WARNING data f "some warning message" #-}++      Test cases:+        T24396c+  -}+  TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage++  {-| TcRnIllegalInvisibleTypePattern is an error raised when an invisible+      type pattern, i.e. a pattern of the form `@p`, is rejected.++      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]++      Examples for InvisPatMisplaced:++        f (smth, $(invisP (varT (newName "blah")))) = ...++        g = do+          $(invisP (varT (newName "blah"))) <- aciton1+          ...++      Test cases:+        T17694b          -- InvisPatWithoutFlag+        T17694c          -- InvisPatNoForall+        T17594d          -- InvisPatNoForall+        T24557a          -- InvisPatMisplaced+        T24557b          -- InvisPatMisplaced+        T24557c          -- InvisPatMisplaced+        T24557d          -- InvisPatMisplaced+  -}+  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+      without the -XExplicitNamespaces extension enabled++      Example:++        {-# LANGUAGE NoExplicitNamespaces #-}+        f = const+        infixl 7 data `f`++      Test cases:+        T14032c+  -}+  TcRnNamespacedFixitySigWithoutFlag :: FixitySig GhcPs -> TcRnMessage++  {-| TcRnDefaultedExceptionContext is a warning that is triggered when the+      backward-compatibility logic solving for implicit ExceptionContext+      constraints fires.++      Test cases: DefaultExceptionContext+  -}+  TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage++  {-| TcRnOutOfArityTyVar is an error raised when the arity of a type synonym+      (as determined by the SAKS and the LHS) is insufficiently high to+      accommodate an implicit binding for a free variable that occurs in the+      outermost kind signature on the RHS of the said type synonym.++      Example:++        type SynBad :: forall k. k -> Type+        type SynBad = Proxy :: j -> Type++      Test cases:+        T24770a+  -}+  TcRnOutOfArityTyVar+    :: Name -- ^ Type synonym's name+    -> Name -- ^ Type variable's name+    -> TcRnMessage++  {- TcRnUnexpectedTypeSyntaxInTerms is an error that occurs+     when type syntax is used in terms without -XRequiredTypeArguments+     extension enabled++     Examples:++       idVis (forall a. forall b -> (a ~ Int, b ~ Bool) => a -> b)++    Test cases: T24159_type_syntax_rn_fail+  -}+  TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage+  deriving Generic++----++data ZonkerMessage where+  {-| ZonkerCannotDefaultConcrete is an error occurring when a concrete+    type variable cannot be defaulted.++    Test cases:+      T23153+  -}+  ZonkerCannotDefaultConcrete+    :: !FixedRuntimeRepOrigin+    -> ZonkerMessage++  deriving Generic++----++-- | Things forbidden in @type data@ declarations.+-- See Note [Type data declarations]+data TypeDataForbids+  = TypeDataForbidsDatatypeContexts+  | TypeDataForbidsLabelledFields+  | TypeDataForbidsStrictnessAnnotations+  | TypeDataForbidsDerivingClauses+  deriving Generic++instance Outputable TypeDataForbids where+  ppr TypeDataForbidsDatatypeContexts      = text "Data type contexts"+  ppr TypeDataForbidsLabelledFields        = text "Labelled fields"+  ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags"+  ppr TypeDataForbidsDerivingClauses       = text "Deriving clauses"++-- | Specifies which back ends can handle a requested foreign import or export+type ExpectedBackends = [Backend]++-- | Specifies which calling convention is unsupported on the current platform+data UnsupportedCallConvention+  = StdCallConvUnsupported+  | PrimCallConvUnsupported+  | JavaScriptCallConvUnsupported+  deriving Eq++-- | Whether the error pertains to a function argument or a result.+data ArgOrResult+  = Arg | Result++-- | Which parts of a record field are affected by a particular error or warning.+data RecordFieldPart+  = RecordFieldDecl !Name+  | RecordFieldConstructor !Name+  | RecordFieldPattern !Name+  | RecordFieldUpdate++-- | Why did we reject a record update?+data BadRecordUpdateReason+   -- | No constructor has all of the required fields.+   = NoConstructorHasAllFields+       { conflictingFields :: [FieldLabelString] }++   -- | There are several possible parents which have all of the required fields,+   -- and we weren't able to disambiguate in any way.+   | MultiplePossibleParents+       (RecSelParent, RecSelParent, [RecSelParent])+         -- ^ The possible parents (at least 2)++   -- | We used type-directed disambiguation, but this resulted in+   -- an invalid parent (the type-directed parent is not among the+   -- parents we computed from the field labels alone).+   | InvalidTyConParent TyCon (NE.NonEmpty RecSelParent)++  deriving Generic++-- | Where a shadowed name comes from+data ShadowedNameProvenance+  = ShadowedNameProvenanceLocal !SrcLoc+    -- ^ The shadowed name is local to the module+  | 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+-- representation polymorphism errors when validity checking.+--+-- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+data FixedRuntimeRepProvenance+  -- | Data constructor fields must have a fixed runtime representation.+  --+  -- Tests: T11734, T18534.+  = FixedRuntimeRepDataConField++  -- | Pattern synonym signature arguments must have a fixed runtime representation.+  --+  -- Test: RepPolyPatSynArg.+  | FixedRuntimeRepPatSynSigArg++  -- | Pattern synonym signature scrutinee must have a fixed runtime representation.+  --+  -- Test: RepPolyPatSynRes.+  | FixedRuntimeRepPatSynSigRes++pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc+pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field"+pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument"+pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee"++-- | Why the particular illegal newtype error arose together with more+-- information, if any.+data IllegalNewtypeReason+  = DoesNotHaveSingleField !Int+  | IsNonLinear+  | IsGADT+  | HasConstructorContext+  | HasExistentialTyVar+  | HasStrictnessAnnotation+  deriving Generic++-- | Why the particular injectivity error arose together with more information,+-- if any.+data InjectivityErrReason+  = InjErrRhsBareTyVar [Type]+  | InjErrRhsCannotBeATypeFam+  | InjErrRhsOverlap+  | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances++data HasKinds+  = YesHasKinds+  | NoHasKinds+  deriving (Show, Eq)++hasKinds :: Bool -> HasKinds+hasKinds True  = YesHasKinds+hasKinds False = NoHasKinds++data SuggestUndecidableInstances+  = YesSuggestUndecidableInstaces+  | NoSuggestUndecidableInstaces+  deriving (Show, Eq)++suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances+suggestUndecidableInstances True  = YesSuggestUndecidableInstaces+suggestUndecidableInstances False = NoSuggestUndecidableInstaces++data SuggestUnliftedTypes+  = SuggestUnliftedNewtypes+  | SuggestUnliftedDatatypes++-- | A description of whether something is a+--+-- * @data@ or @newtype@ ('DataDeclSort')+--+-- * @data instance@ or @newtype instance@ ('DataInstanceSort')+--+-- * @data family@ ('DataFamilySort')+--+-- At present, this data type is only consumed by 'checkDataKindSig'.+data DataSort+  = DataDeclSort     NewOrData+  | DataInstanceSort NewOrData+  | DataFamilySort++ppDataSort :: DataSort -> SDoc+ppDataSort data_sort = text $+  case data_sort of+    DataDeclSort     DataType -> "Data type"+    DataDeclSort     NewType  -> "Newtype"+    DataInstanceSort DataType -> "Data instance"+    DataInstanceSort NewType  -> "Newtype instance"+    DataFamilySort            -> "Data family"++-- | Helper type used in 'checkDataKindSig'.+--+-- Superficially similar to 'ContextKind', but it lacks 'AnyKind'+-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@+-- provides 'LiftedKind', which is much simpler to match on and+-- handle in 'isAllowedDataResKind'.+data AllowedDataResKind+  = AnyTYPEKind+  | AnyBoxedKind+  | LiftedKind++-- | A data type to describe why a variable is not closed.+-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr+data NotClosedReason = NotLetBoundReason+                     | NotTypeClosed VarSet+                     | NotClosed Name NotClosedReason++data SuggestPartialTypeSignatures+  = YesSuggestPartialTypeSignatures+  | NoSuggestPartialTypeSignatures+  deriving (Show, Eq)++suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures+suggestPartialTypeSignatures True  = YesSuggestPartialTypeSignatures+suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures++data UsingGeneralizedNewtypeDeriving+  = YesGeneralizedNewtypeDeriving+  | NoGeneralizedNewtypeDeriving+  deriving Eq++usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving+usingGeneralizedNewtypeDeriving True  = YesGeneralizedNewtypeDeriving+usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving++data DeriveAnyClassEnabled+  = YesDeriveAnyClassEnabled+  | NoDeriveAnyClassEnabled+  deriving Eq++deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled+deriveAnyClassEnabled True  = YesDeriveAnyClassEnabled+deriveAnyClassEnabled False = NoDeriveAnyClassEnabled++-- | Why a particular typeclass instance couldn't be derived.+data DeriveInstanceErrReason+  =+    -- | The typeclass instance is not well-kinded.+    DerivErrNotWellKinded !TyCon+                          -- ^ The type constructor that occurs in+                          -- the typeclass instance declaration.+                          !Kind+                          -- ^ The typeclass kind.+                          !Int+                          -- ^ The number of typeclass arguments that GHC+                          -- kept. See Note [tc_args and tycon arity] in+                          -- GHC.Tc.Deriv.+  -- | Generic instances can only be derived using the stock strategy+  -- in Safe Haskell.+  | DerivErrSafeHaskellGenericInst+  | DerivErrDerivingViaWrongKind !Kind !Type !Kind+  | DerivErrNoEtaReduce !Type+                        -- ^ The instance type+  -- | We cannot derive instances in boot files+  | DerivErrBootFileFound+  | DerivErrDataConsNotAllInScope !TyCon+  -- | We cannot use GND on non-newtype types+  | DerivErrGNDUsedOnData+  -- | We cannot derive instances of nullary classes+  | DerivErrNullaryClasses+  -- | Last arg must be newtype or data application+  | DerivErrLastArgMustBeApp+  | DerivErrNoFamilyInstance !TyCon [Type]+  | DerivErrNotStockDeriveable !DeriveAnyClassEnabled+  | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts+                                   !AssociatedTyLastVarInKind+                                   !AssociatedTyNotParamOverLastTyVar+  | DerivErrNewtypeNonDeriveableClass+  | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK?+  | DerivErrOnlyAnyClassDeriveable !TyCon+                                   -- ^ Type constructor for which the instance+                                   -- is requested+                                   !DeriveAnyClassEnabled+                                   -- ^ Whether or not -XDeriveAnyClass is enabled+                                   -- already.+  -- | Stock deriving won't work, but perhaps DeriveAnyClass will.+  | DerivErrNotDeriveable !DeriveAnyClassEnabled+  -- | The given 'PredType' is not a class.+  | DerivErrNotAClass !PredType+  -- | The given (representation of the) 'TyCon' has no+  -- data constructors.+  | DerivErrNoConstructors !TyCon+  | DerivErrLangExtRequired !LangExt.Extension+  -- | GHC simply doesn't how to how derive the input 'Class' for the given+  -- 'Type'.+  | DerivErrDunnoHowToDeriveForType !Type+  -- | The given 'TyCon' must be an enumeration.+  -- See Note [Enumeration types] in GHC.Core.TyCon+  | DerivErrMustBeEnumType !TyCon+  -- | The given 'TyCon' must have /precisely/ one constructor.+  | DerivErrMustHaveExactlyOneConstructor !TyCon+  -- | The given data type must have some parameters.+  | DerivErrMustHaveSomeParameters !TyCon+  -- | The given data type must not have a class context.+  | DerivErrMustNotHaveClassContext !TyCon !ThetaType+  -- | We couldn't derive an instance for a particular data constructor+  -- for a variety of reasons.+  | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor]+  -- | We couldn't derive a 'Generic' instance for the given type for a+  -- variety of reasons+  | DerivErrGenerics [DeriveGenericsErrReason]+  -- | We couldn't derive an instance either because the type was not an+  -- enum type or because it did have more than one constructor.+  | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason+  deriving Generic++data DeriveInstanceBadConstructor+  =+  -- | The given 'DataCon' must be truly polymorphic in the+  -- last argument of the data type.+    DerivErrBadConExistential !DataCon+  -- | The given 'DataCon' must not use the type variable in a function argument"+  | DerivErrBadConCovariant !DataCon+  -- | The given 'DataCon' must not contain function types+  | DerivErrBadConFunTypes !DataCon+  -- | The given 'DataCon' must use the type variable only+  -- as the last argument of a data type+  | DerivErrBadConWrongArg !DataCon+  -- | The given 'DataCon' is a GADT so we cannot directly+  -- derive an istance for it.+  | DerivErrBadConIsGADT !DataCon+  -- | The given 'DataCon' has existentials type vars in its type.+  | DerivErrBadConHasExistentials !DataCon+  -- | The given 'DataCon' has constraints in its type.+  | DerivErrBadConHasConstraints !DataCon+  -- | The given 'DataCon' has a higher-rank type.+  | DerivErrBadConHasHigherRankType !DataCon++data DeriveGenericsErrReason+  = -- | The type must not have some datatype context.+    DerivErrGenericsMustNotHaveDatatypeContext !TyCon+    -- | The data constructor must not have exotic unlifted+    -- or polymorphic arguments.+  | DerivErrGenericsMustNotHaveExoticArgs !DataCon+    -- | The data constructor must be a vanilla constructor.+  | DerivErrGenericsMustBeVanillaDataCon  !DataCon+    -- | The type must have some type parameters.+    -- check (d) from Note [Requirements for deriving Generic and Rep]+    -- in GHC.Tc.Deriv.Generics.+  | DerivErrGenericsMustHaveSomeTypeParams !TyCon+    -- | The data constructor must not have existential arguments.+  | DerivErrGenericsMustNotHaveExistentials !DataCon+    -- | The derivation applies a type to an argument involving+    -- the last parameter but the applied type is not of kind * -> *.+  | DerivErrGenericsWrongArgKind !DataCon++data HasWildcard+  = YesHasWildcard+  | NoHasWildcard+  deriving Eq++hasWildcard :: Bool -> HasWildcard+hasWildcard True  = YesHasWildcard+hasWildcard False = NoHasWildcard++-- | A context in which we don't allow anonymous wildcards.+data BadAnonWildcardContext+  = WildcardNotLastInConstraint+  | ExtraConstraintWildcardNotAllowed+      SoleExtraConstraintWildcardAllowed+  | WildcardsNotAllowedAtAll++  -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type+  | WildcardBndrInForallTelescope+  | WildcardBndrInTyFamResultVar++-- | Whether a sole extra-constraint wildcard is allowed,+-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@.+data SoleExtraConstraintWildcardAllowed+  = SoleExtraConstraintWildcardNotAllowed+  | SoleExtraConstraintWildcardAllowed++-- | Why is a class instance head invalid?+data IllegalInstanceHeadReason+  -- | An instance for an abstract class from an hs-boot or Backpack+  -- hsig file.+  --+  --  Example:+  --+  --    -- A.hs-boot+  --    module A where+  --    class C a+  --+  --    -- B.hs+  --    module B where+  --    import {-# SOURCE #-} A+  --    instance C Int where+  --+  --    -- A.hs+  --    module A where+  --    import B+  --    class C a where+  --      f :: a+  --+  -- Test cases: typecheck/should_fail/T13068+  = InstHeadAbstractClass !(WithUserRdr Name) -- ^ name of the abstract 'Class'+  -- | An instance whose head is not a class.+  --+  -- Examples(s):+  --+  --   instance c+  --+  --   instance 42+  --+  --   instance !Show D+  --+  --   type C1 a = (Show (a -> Bool))+  --   instance C1 Int where+  --+  -- Test cases: typecheck/rename/T5513+  --             typecheck/rename/T16385+  --             parser/should_fail/T3811c+  --             rename/should_fail/T18240a+  --             polykinds/T13267+  --             deriving/should_fail/T23522+  | InstHeadNonClassHead InstHeadNonClassHead++  -- | Instance head was headed by a type synonym.+  --+  -- Example:+  --    type MyInt = Int+  --    class C a where {..}+  --    instance C MyInt where {..}+  --+  -- Test cases: drvfail015, mod42, TidyClassKinds, tcfail139+  | InstHeadTySynArgs+  -- | Instance head was not of the form @T a1 ... an@,+  -- where @a1, ..., an@ are all type variables or literals.+  --+  -- Example:+  --+  --    instance Num [Int] where {..}+  --+  -- Test cases: mod41, mod42, tcfail044, tcfail047.+  | InstHeadNonTyVarArgs+  -- | Multi-param instance without -XMultiParamTypeClasses.+  --+  -- Example:+  --+  --  instance C a b where {..}+  --+  -- Test case: IllegalMultiParamInstance+  | InstHeadMultiParam+  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'.++    Example:++      data D a = MkD+      type instance D Int = Bool++    Test case: indexed-types/should_fail/T3092+  -}+  = NotAFamilyTyCon+      !TypeOrData -- ^ was this a 'type' or a 'data' instance?+      !TyCon+  {-| A top-level (open) type family instance for a closed type family.++    Test cases:+      indexed-types/should_fail/Overlap7+      indexed-types/should_fail/Overlap3+  -}+  | NotAnOpenFamilyTyCon !TyCon++  {-| A family instance was declared for a family of a different kind,+      e.g. a data instance for a type family 'TyCon'.++     Test cases:+       T9896, SimpleFail3a+  -}+  | FamilyCategoryMismatch !TyCon -- ^ The family tycon+++  {-| A family instance was declared with a different number of arguments+      than expected.+      See Note [Oversaturated type family equations] in "GHC.Tc.Validity".++    Test cases:+      TyFamArity1, TyFamArity2, T11136, Overlap4, AssocTyDef05, AssocTyDef06,+      T14110+  -}+  | FamilyArityMismatch !TyCon -- ^ The family tycon+                        !Arity -- ^ The right number of parameters++  {-| A closed type family equation used a different name than the parent family.++    Example:++      type family F a where+        G Int = Bool++    Test cases:+      Overlap5, T15362, T16002, T20260, T11623+  -}+  | TyFamNameMismatch !Name -- ^ The family name+                      !Name -- ^ The name used in the equation+++  -- | There are out-of-scope type variables in the right-hand side+  -- of an associated type or data family instance.+  --+  -- Example:+  --+  --    instance forall a. C Int where+  --      data instance D Int = MkD1 a+  --+  -- Test cases: indexed-types/should_fail/T5515, polykinds/T9574, rename/should_fail/T18021+  | FamInstRHSOutOfScopeTyVars+      !(Maybe (TyCon, [Type], TyVarSet))+        -- ^ family 'TyCon', arguments, and set of "dodgy" type variables+        -- See Note [Dodgy binding sites in type family instances]+        -- in GHC.Tc.Validity+      !(NE.NonEmpty Name) -- ^ the out-of-scope type variables++  | FamInstLHSUnusedBoundTyVars+      !(NE.NonEmpty InvalidFamInstQTv) -- ^ the unused bound type variables++  | InvalidAssoc !InvalidAssoc+  deriving Generic++-- | A quantified type variable in a type or data family equation that+-- is either not bound in any LHS patterns or not used in the RHS (or both).+data InvalidFamInstQTv+  = InvalidFamInstQTv+    { ifiqtv :: TcTyVar+    , ifiqtv_user_written :: Bool+       -- ^ Did the user write this type variable, or was introduced by GHC?+       -- For example: with @-XPolyKinds@, in @type instance forall a. F = ()@,+       -- we have a user-written @a@ but GHC introduces a kind variable @k@+       -- as well. See #23734.+    , ifiqtv_reason       :: InvalidFamInstQTvReason+      -- ^ For what reason was the quantified type variable invalid?+    }++data InvalidFamInstQTvReason+  -- | A dodgy binder, i.e. a variable that syntactically appears in+  -- LHS patterns but only in non-injective positions.+  --+  -- See Note [Dodgy binding sites in type family instances]+  -- in GHC.Tc.Validity.+  = InvalidFamInstQTvDodgy+  -- | A quantified type variable in a type or data family equation+  -- that is not bound in any LHS patterns.+  | InvalidFamInstQTvNotBoundInPats+  -- | A quantified type variable in a type or data family equation+  -- that is not used on the RHS.+  | InvalidFamInstQTvNotUsedInRHS++-- The 'check_tvs' function in 'GHC.Tc.Validity.checkFamPatBinders'+-- uses 'getSrcSpan', so this 'NamedThing' instance is convenient.+instance NamedThing InvalidFamInstQTv where+  getName = getName . ifiqtv++data InvalidAssoc+  -- | An invalid associated family instance.+  --+  -- See t'InvalidAssocInstance'.Builder+  = InvalidAssocInstance !InvalidAssocInstance+  -- | An invalid associated family default declaration.+  --+  -- See t'InvalidAssocDefault'.+  | InvalidAssocDefault  !InvalidAssocDefault+  deriving Generic++-- | The reason that an associated family instance was invalid.+data InvalidAssocInstance+  -- | A class instance is missing its expected associated type/data instance.+  --+  -- Test cases: deriving/should_compile/T14094+  --             indexed-types/should_compile/Simple2+  --             typecheck/should_compile/tc254+  = AssocInstanceMissing !Name++  -- | A top-level instance for an associated family 'TyCon'.+  --+  -- Example:+  --+  --  class C a where { type T a }+  --  instance T Int = Bool+  --+  -- Test case: indexed-types/should_fail/SimpleFail7+  | AssocInstanceNotInAClass !TyCon++  -- | An associated type instance is provided for a class that doesn't have+  -- that associated type.+  --+  -- Examples(s):+  --   $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo)+  --               [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)]+  --        return [d])+  --   ======>+  --   instance Eq Foo where+  --     type Rep Foo = Maybe+  --+  -- Test cases: th/T12387a+  | AssocNotInThisClass !Class !TyCon+  -- | An associated family instance does not mention any of the parent 'Class'+  -- 'TyVar's.+  --+  -- Test cases: T2888, T9167, T12867+  | AssocNoClassTyVar !Class !TyCon++  | AssocTyVarsDontMatch+      !ForAllTyFlag+      !TyCon  -- ^ family 'TyCon'+      ![Type] -- ^ expected type arguments+      ![Type] -- ^ actual type arguments+  deriving Generic+++-- | The reason that an associated family default declaration was invalid.+data InvalidAssocDefault+    -- | An associated family default declaration for something that isn't+    -- an associated family.+  = AssocDefaultNotAssoc !Name -- ^ 'Class' 'Name'+                         !Name -- ^ 'TyCon' 'Name'+    -- | Multiple default declarations were given for an associated+    -- family instance.+    --+    -- Test cases: none.+  | AssocMultipleDefaults !Name+    -- | Invalid arguments in an associated family instance default declaration.+    --+    -- See t'AssocDefaultBadArgs'.+  | AssocDefaultBadArgs !TyCon ![Type] AssocDefaultBadArgs+  deriving Generic++-- | Invalid arguments in an associated family instance declaration.+data AssocDefaultBadArgs+  -- | An argument which isn't a type variable in an associated+  -- family instance default declaration.+  = AssocDefaultNonTyVarArg !(Type, ForAllTyFlag)+  -- | Duplicate occurrence of a type variable in an associated+  -- family instance default declaration.+  | AssocDefaultDuplicateTyVars !(NE.NonEmpty (TyCoVar, ForAllTyFlag))+  deriving Generic++-- | A type representing whether or not the input type has associated data family instances.+data HasAssociatedDataFamInsts+  = YesHasAdfs+  | NoHasAdfs+  deriving Eq++hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts+hasAssociatedDataFamInsts True = YesHasAdfs+hasAssociatedDataFamInsts False = NoHasAdfs++-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass+-- contains the last type variable of the class in a kind, which is not (yet) allowed+-- by GHC.+data AssociatedTyLastVarInKind+  = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class+  | NoAssocTyLastVarInKind+  deriving Eq++associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind+associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc+associatedTyLastVarInKind Nothing   = NoAssocTyLastVarInKind++-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a+-- typeclass is not parameterized over the last type variable of the class+data AssociatedTyNotParamOverLastTyVar+  = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class+  | NoAssociatedTyNotParamOverLastTyVar+  deriving Eq++associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar+associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc+associatedTyNotParamOverLastTyVar Nothing   = NoAssociatedTyNotParamOverLastTyVar++-- | What kind of thing is missing a type signature?+--+-- Used for reporting @"missing signature"@ warnings, see+-- 'tcRnMissingSignature'.+data MissingSignature+  = MissingTopLevelBindingSig Name Type+  | MissingPatSynSig PatSyn+  | MissingTyConKindSig+      TyCon+      Bool -- ^ whether -XCUSKs is enabled++-- | Is the object we are dealing with exported or not?+--+-- Used for reporting @"missing signature"@ warnings, see+-- 'TcRnMissingSignature'.+data Exported+  = IsNotExported+  | IsExported+  deriving Eq++instance Outputable Exported where+  ppr IsNotExported = text "IsNotExported"+  ppr IsExported    = text "IsExported"++-- | What declarations were not allowed in an hs-boot or hsig file?+data BadBootDecls+  = BootBindsPs      !(NE.NonEmpty (LHsBindLR GhcRn GhcPs))+  | BootBindsRn      !(NE.NonEmpty (LHsBindLR GhcRn GhcRn))+  | BootInstanceSigs !(NE.NonEmpty (LSig GhcRn))+  | BootFamInst      !TyCon+  | BootSpliceDecls  !(NE.NonEmpty (LocatedA (HsUntypedSplice GhcPs)))+  | BootForeignDecls !(NE.NonEmpty (LForeignDecl GhcRn))+  | BootDefaultDecls !(NE.NonEmpty (LDefaultDecl GhcRn))+  | BootRuleDecls    !(NE.NonEmpty (LRuleDecls GhcRn))++-- | A mismatch between an hs-boot or signature file and its implementing module.+data BootMismatch+  -- | Something defined or exported by an hs-boot or signature file+  -- is missing from the implementing module.+  = MissingBootThing !Name !MissingBootThing++  -- | A typeclass instance is declared in the hs-boot file but+  -- it is not present in the implementing module.+  | MissingBootInstance !DFunId -- ^ the boot instance 'DFunId'+    -- NB: we never trigger this for hsig files, as in that case we do+    -- a full round of constraint solving, and a missing instance gets reported+    -- as an unsolved Wanted constraint with a 'InstProvidedOrigin' 'CtOrigin'.+    -- See GHC.Tc.Utils.Backpack.check_inst.++  -- | A mismatch between an hsig file and its implementing module+  -- in the 'Name' that a particular re-export refers to.+  | BadReexportedBootThing !Name !Name++  -- | A mismatch between the declaration of something in the hs-boot or+  -- signature file and its implementation, e.g. a type mismatch or+  -- a type family implemented as a class.+  | BootMismatch+      !TyThing -- ^ boot thing+      !TyThing -- ^ real thing+      !BootMismatchWhat+  deriving Generic++-- | Something from the hs-boot or signature file is missing from the+-- implementing module.+data MissingBootThing+  -- | Something defined in the hs-boot or signature file is not defined in the+  -- implementing module.+  = MissingBootDefinition+  -- | Something exported by the hs-boot or signature file is not exported by the+  -- implementing module.+  | MissingBootExport+  deriving Generic++missingBootThing :: HsBootOrSig -> Name -> MissingBootThing -> TcRnMessage+missingBootThing src nm thing =+  TcRnBootMismatch src (MissingBootThing nm thing)++-- | A mismatch of two 'TyThing's between an hs-boot or signature file+-- and its implementing module.+data BootMismatchWhat+  -- | The 'Id's have different types.+  = BootMismatchedIdTypes !Id -- ^ boot 'Id'+                          !Id -- ^ real 'Id'+  -- | Two 'TyCon's aren't compatible.+  | BootMismatchedTyCons !TyCon -- ^ boot 'TyCon'+                         !TyCon -- ^ real 'TyCon'+                         !(NE.NonEmpty BootTyConMismatch)+  deriving Generic++-- | An error in the implementation of an abstract datatype using+-- a type synonym.+data SynAbstractDataError+  -- | The type synony was not nullary.+  = SynAbsDataTySynNotNullary+  -- | The type synonym RHS contained invalid types, e.g.+  -- a type family or a forall.+  | SynAbstractDataInvalidRHS !(NE.NonEmpty Type)++-- | Mismatched implementation of a 'TyCon' in an hs-boot or signature file.+data BootTyConMismatch+  -- | The 'TyCon' kinds differ.+  = TyConKindMismatch+  -- | The 'TyCon' 'Role's aren't compatible.+  | TyConRoleMismatch !Bool -- ^ True <=> role subtype check+  -- | Two type synonyms have different RHSs.+  | TyConSynonymMismatch !Kind !Kind+  -- | The two 'TyCon's are of a different flavour, e.g. one is+  -- a data family and the other is a type family.+  | TyConFlavourMismatch !FamTyConFlav !FamTyConFlav+  -- | The equations of a type family don't match.+  | TyConAxiomMismatch !(BootListMismatches CoAxBranch BootAxiomBranchMismatch)+  -- | The type family injectivity annotations don't match.+  | TyConInjectivityMismatch+  -- | The 'TyCon's are both datatype 'TyCon's, but they have diferent 'DataCon's.+  | TyConMismatchedData !AlgTyConRhs !AlgTyConRhs !BootDataMismatch+  -- | The 'TyCon's are both 'Class' 'TyCon's, but the classes don't match.+  | TyConMismatchedClasses !Class !Class !BootClassMismatch+  -- | The 'TyCon's are something completely different.+  | TyConsVeryDifferent+  -- | An abstract 'TyCon' is implemented using a type synonym in an invalid+  -- manner. See 'SynAbstractDataError'.+  | SynAbstractData !SynAbstractDataError+++-- | Utility datatype to record errors when checking compatibity+-- between two lists of things, e.g. class methods, associated types,+-- type family equations, etc.+data BootListMismatch item err+  -- | Different number of items.+  = MismatchedLength+  -- | The item at the given position in the list differs.+  | MismatchedThing !Int !item !item !err++type BootListMismatches item err =+  NE.NonEmpty (BootListMismatch item err)++data BootAxiomBranchMismatch+  -- | The quantified variables in an equation don't match.+  --+  -- Example: the quantification of @a@ in+  --+  --   @type family F a where { forall a. F a = Maybe a }@+  = MismatchedAxiomBinders+  -- | The LHSs of an equation don't match.+  | MismatchedAxiomLHS+  -- | The RHSs of an equation don't match.+  | MismatchedAxiomRHS++-- | A mismatch in a class, between its declaration in an hs-boot or signature+-- file, and its implementation in a source Haskell file.+data BootClassMismatch+  -- | The class methods don't match.+  = MismatchedMethods !(BootListMismatches ClassOpItem BootMethodMismatch)+  -- | The associated types don't match.+  | MismatchedATs !(BootListMismatches ClassATItem BootATMismatch)+  -- | The functional dependencies don't match.+  | MismatchedFunDeps+  -- | The superclasses don't match.+  | MismatchedSuperclasses+  -- | The @MINIMAL@ pragmas are not compatible.+  | MismatchedMinimalPragmas++-- | A mismatch in a class method, between its declaration in an hs-boot or signature+-- file, and its implementation in a source Haskell file.+data BootMethodMismatch+  -- | The class method names are different.+  = MismatchedMethodNames+  -- | The types of a class method are different.+  | MismatchedMethodTypes !Type !Type+  -- | The default method types are not compatible.+  | MismatchedDefaultMethods !Bool -- ^ True <=> subtype check++-- | A mismatch in an associated type of a class, between its declaration+-- in an hs-boot or signature file, and its implementation in a source Haskell file.+data BootATMismatch+  -- | Two associated types don't match.+  = MismatchedTyConAT !BootTyConMismatch+  -- | Two associated type defaults don't match.+  | MismatchedATDefaultType++-- | A mismatch in a datatype declaration, between an hs-boot file or signature+-- file and its implementing module.+data BootDataMismatch+  -- | A datatype is implemented as a newtype or vice-versa.+  = MismatchedNewtypeVsData+  -- | The constructors don't match.+  | MismatchedConstructors !(BootListMismatches DataCon BootDataConMismatch)+  -- | The datatype contexts differ.+  | MismatchedDatatypeContexts++-- | A mismatch in a data constrcutor, between its declaration in an hs-boot+-- file or signature file, and its implementation in a source Haskell module.+data BootDataConMismatch+  -- | The 'Name's of the 'DataCon's differ.+  = MismatchedDataConNames+  -- | The fixities of the 'DataCon's differ.+  | MismatchedDataConFixities+  -- | The strictness annotations of the 'DataCon's differ.+  | MismatchedDataConBangs+  -- | The 'DataCon's have different field labels.+  | MismatchedDataConFieldLabels+  -- | The 'DataCon's have incompatible types.+  | MismatchedDataConTypes++--------------------------------------------------------------------------------+--+--     Errors used in GHC.Tc.Errors+--+--------------------------------------------------------------------------------++{- Note [Error report]+~~~~~~~~~~~~~~~~~~~~~~+The idea is that error msgs are divided into three parts: the main msg, the+context block ("In the second argument of ..."), and the relevant bindings+block, which are displayed in that order, with a mark to divide them. The+the main msg ('report_important') varies depending on the error+in question, but context and relevant bindings are always the same, which+should simplify visual parsing.++See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'.+-}++-- | A collection of main error messages and supplementary information.+--+-- In practice, we will:+--  - display the important messages first,+--  - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'),+--  - then the supplementary information (e.g. relevant bindings, valid hole fits),+--  - then the hints ("Possible fix: ...").+--+-- So this is mostly just a way of making sure that the error context appears+-- early on rather than at the end of the message.+--+-- See Note [Error report] for details.+data SolverReport+  = SolverReport+  { sr_important_msg :: SolverReportWithCtxt+  , sr_supplementary :: [SupplementaryInfo]+  , sr_hints         :: [GhcHint]+  }++-- | Additional information to print in an error message, after the+-- important messages and after the error context.+--+-- See Note [Error report].+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.+data SolverReportWithCtxt =+  SolverReportWithCtxt+    { reportContext :: SolverReportErrCtxt+       -- ^ Context for what we wish to report.+       -- This can change as we enter implications, so is+       -- stored alongside the content.+    , reportContent :: TcSolverReportMsg+      -- ^ The content of the message to report.+    }+  deriving Generic++-- | Context needed when reporting a 'TcSolverReportMsg', such as+-- the enclosing implication constraints or whether we are deferring type errors.+data SolverReportErrCtxt+    = CEC { cec_encl :: [Implication]  -- ^ Enclosing implications+                                       --   (innermost first)+                                       -- ic_skols and givens are tidied, rest are not+          , cec_tidy  :: TidyEnv++          , cec_binds :: EvBindsVar    -- ^ We make some errors (depending on cec_defer)+                                       -- into warnings, and emit evidence bindings+                                       -- into 'cec_binds' for unsolved constraints++          , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime++          -- We might throw a warning on an error when encountering a hole,+          -- depending on the type of hole (expression hole, type hole, out of scope hole).+          -- We store the reasons for reporting a diagnostic for each type of hole.+          , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions.+          , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types.+          , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes.++          , cec_warn_redundant :: Bool    -- ^ True <=> -Wredundant-constraints+          , cec_expand_syns    :: Bool    -- ^ True <=> -fprint-expanded-synonyms++          , cec_suppress :: Bool    -- ^ True <=> More important errors have occurred,+                                    --            so create bindings if need be, but+                                    --            don't issue any more errors/warnings+                                    -- See Note [Suppressing error messages]+      }++getUserGivens :: SolverReportErrCtxt -> [UserGiven]+-- One item for each enclosing implication+getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics++----------------------------------------------------------------------------+--+--   ErrorItem+--+----------------------------------------------------------------------------++-- | A predicate with its arising location; used to encapsulate a constraint+-- that will give rise to a diagnostic.+data ErrorItem+-- We could perhaps use Ct here (and indeed used to do exactly that), but+-- having a separate type gives to denote errors-in-formation gives us+-- a nice place to do pre-processing, such as calculating ei_suppress.+-- Perhaps some day, an ErrorItem could eventually evolve to contain+-- the error text (or some representation of it), so we can then have all+-- the errors together when deciding which to report.+  = EI { ei_pred     :: PredType         -- report about this+         -- The ei_pred field will never be an unboxed equality with+         -- a (casted) tyvar on the right; this is guaranteed by the solver+       , ei_evdest   :: Maybe TcEvDest+         -- ^ for Wanteds, where to put the evidence+         --   for Givens, Nothing+       , ei_flavour  :: CtFlavour+       , ei_loc      :: CtLoc+       , ei_m_reason :: Maybe CtIrredReason  -- if this ErrorItem was made from a+                                             -- CtIrred, this stores the reason+       , ei_suppress :: Bool    -- Suppress because of Note [Wanteds rewrite Wanteds]+                                -- in GHC.Tc.Constraint+       }++instance Outputable ErrorItem where+  ppr (EI { ei_pred     = pred+          , ei_evdest   = m_evdest+          , ei_flavour  = flav+          , ei_suppress = supp })+    = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred+    where+      pp_dest Nothing   = empty+      pp_dest (Just ev) = ppr ev <+> dcolon++      pp_supp = if supp then text "suppress:" else empty++errorItemOrigin :: ErrorItem -> CtOrigin+errorItemOrigin = ctLocOrigin . ei_loc++errorItemEqRel :: ErrorItem -> EqRel+errorItemEqRel = predTypeEqRel . ei_pred++errorItemCtLoc :: ErrorItem -> CtLoc+errorItemCtLoc = ei_loc++errorItemPred :: ErrorItem -> PredType+errorItemPred = ei_pred++{- Note [discardProvCtxtGivens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In most situations we call all enclosing implications "useful". There is one+exception, and that is when the constraint that causes the error is from the+"provided" context of a pattern synonym declaration:++  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a+             --  required      => provided => type+  pattern Pat x <- (Just x, 4)++When checking the pattern RHS we must check that it does actually bind all+the claimed "provided" constraints; in this case, does the pattern (Just x, 4)+bind the (Show a) constraint.  Answer: no!++But the implication we generate for this will look like+   forall a. (Num a, Eq a) => [W] Show a+because when checking the pattern we must make the required+constraints available, since they are needed to match the pattern (in+this case the literal '4' needs (Num a, Eq a)).++BUT we don't want to suggest adding (Show a) to the "required" constraints+of the pattern synonym, thus:+  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a+It would then typecheck but it's silly.  We want the /pattern/ to bind+the alleged "provided" constraints, Show a.++So we suppress that Implication in discardProvCtxtGivens.  It's+painfully ad-hoc but the truth is that adding it to the "required"+constraints would work.  Suppressing it solves two problems.  First,+we never tell the user that we could not deduce a "provided"+constraint from the "required" context. Second, we never give a+possible fix that suggests to add a "provided" constraint to the+"required" context.++For example, without this distinction the above code gives a bad error+message (showing both problems):++  error: Could not deduce (Show a) ... from the context: (Eq a)+         ... Possible fix: add (Show a) to the context of+         the signature for pattern synonym `Pat' ...+-}+++discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]+discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]+  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig+  = filterOut (discard name) givens+  | otherwise+  = givens+  where+    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'+    discard _ _                                                  = False+++-- | An error reported after constraint solving.+-- This is usually, some sort of unsolved constraint error,+-- but we try to be specific about the precise problem we encountered.+data TcSolverReportMsg+  -- | Quantified variables appear out of dependency order.+  --+  -- Example:+  --+  --   forall (a :: k) k. ...+  --+  -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451.+  = BadTelescope TyVarBndrs [TyCoVar]++  -- | We came across a custom type error and we have decided to report it.+  --+  -- Example:+  --+  --   type family F a where+  --     F a = TypeError (Text "error")+  --+  --   err :: F ()+  --   err = ()+  --+  -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104.+  | UserTypeError ErrorMsgType -- ^ the message to report++  -- | Report a Wanted constraint of the form "Unsatisfiable msg".+  | UnsatisfiableError ErrorMsgType -- ^ the message to report++  -- | We want to report an out of scope variable or a typed hole.+  -- See 'HoleError'.+  | ReportHoleError Hole HoleError++  -- | Cannot unify a variable, because of a type mismatch.+  | CannotUnifyVariable+    { mismatchMsg         :: MismatchMsg+    , cannotUnifyReason   :: CannotUnifyVariableReason }++  -- | A mismatch between two types.+  | Mismatch+     { mismatchMsg           :: MismatchMsg+     , mismatchTyVarInfo     :: Maybe TyVarInfo+     , mismatchAmbiguityInfo :: [AmbiguityInfo]+     , mismatchCoercibleInfo :: Maybe CoercibleMsg }++   -- | A violation of the representation-polymorphism invariants.+   --+   -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information.+  | FixedRuntimeRepError [FixedRuntimeRepErrorInfo]++  -- | Something was not applied to sufficiently many arguments.+  --+  --  Example:+  --+  --    instance Eq Maybe where {..}+  --+  -- Test case: T11563.+  | ExpectingMoreArguments Int TypedThing++  -- | Trying to use an unbound implicit parameter.+  --+  -- Example:+  --+  --    foo :: Int+  --    foo = ?param+  --+  -- Test case: tcfail130.+  | UnboundImplicitParams+      (NE.NonEmpty ErrorItem)++  -- | A constraint couldn't be solved because it contains+  -- ambiguous type variables.+  --+  -- Example:+  --+  --   class C a b where+  --     f :: (a,b)+  --+  --   x = fst f+  --+  --+  -- Test case: T4921.+  | AmbiguityPreventsSolvingCt+      ErrorItem -- ^ always a class constraint+      ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively++  -- | Could not solve a constraint; there were several unifying candidate instances+  -- but no matching instances. This is used to report as much useful information+  -- as possible about why we couldn't choose any instance, e.g. because of+  -- ambiguous type variables.+  | CannotResolveInstance+    { cannotResolve_item         :: ErrorItem+    , cannotResolve_unifiers     :: [ClsInst]+    , cannotResolve_candidates   :: [ClsInst]+    , cannotResolve_relBinds     :: RelevantBindings+    }++  -- | Could not solve a constraint using available instances+  -- because the instances overlap.+  --+  -- Test cases: tcfail118, tcfail121, tcfail218.+  | OverlappingInstances+    { overlappingInstances_item     :: ErrorItem+    , overlappingInstances_matches  :: NE.NonEmpty ClsInst+    , overlappingInstances_unifiers :: [ClsInst] }++  -- | Could not solve a constraint from instances because+  -- instances declared in a Safe module cannot overlap instances+  -- from other modules (with -XSafeHaskell).+  --+  -- Test cases: SH_Overlap{1,2,5,6,7,11}.+  | UnsafeOverlap+    { unsafeOverlap_item    :: ErrorItem+    , unsafeOverlap_match   :: ClsInst+    , unsafeOverlapped      :: NE.NonEmpty ClsInst }++  | MultiplicityCoercionsNotSupported++  deriving Generic++data MismatchMsg+  =  -- | Couldn't unify two types or kinds.+  --+  --  Example:+  --+  --    3 + 3# -- can't match a lifted type with an unlifted type+  --+  --  Test cases: T1396, T8263, ...+    BasicMismatch+      { mismatch_ea           :: MismatchEA  -- ^ Should this be phrased in terms of expected vs actual?+      , mismatch_item         :: ErrorItem   -- ^ The constraint in which the mismatch originated.+      , mismatch_ty1          :: Type        -- ^ First type (the expected type if if mismatch_ea is True)+      , mismatch_ty2          :: Type        -- ^ Second type (the actual type if mismatch_ea is True)+      , mismatch_whenMatching :: Maybe WhenMatching+      , mismatch_mb_same_occ  :: Maybe SameOccInfo+      }++  -- | A mismatch between two types, which arose from a type equality.+  --+  -- Test cases: T1470, tcfail212, T2994, T7609.+  | TypeEqMismatch+      { teq_mismatch_item     :: ErrorItem+      , teq_mismatch_ty1      :: Type+      , teq_mismatch_ty2      :: Type+      , teq_mismatch_expected :: Type -- ^ The overall expected type+      , teq_mismatch_actual   :: Type -- ^ The overall actual type+      , teq_mismatch_what     :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of?+      , teq_mb_same_occ       :: Maybe SameOccInfo+      }+    -- TODO: combine with 'BasicMismatch'.++  -- | Couldn't solve some Wanted constraints using the Givens.+  -- Used for messages such as @"No instance for ..."@ and+  -- @"Could not deduce ... from"@.+  | CouldNotDeduce+     { cnd_user_givens :: [Implication]+        -- | The Wanted constraints we couldn't solve.+        --+        -- N.B.: the 'ErrorItem' at the head of the list has been tidied,+        -- perhaps not the others.+     , cnd_wanted      :: NE.NonEmpty ErrorItem++       -- | Some additional info consumed by 'mk_supplementary_ea_msg'.+     , cnd_extra       :: Maybe CND_Extra+     }+  deriving Generic++-- | Construct a basic mismatch message between two types.+--+-- See 'pprMismatchMsg' for how such a message is displayed to users.+mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg+mkBasicMismatchMsg ea item ty1 ty2+  = BasicMismatch+      { mismatch_ea           = ea+      , mismatch_item         = item+      , mismatch_ty1          = ty1+      , mismatch_ty2          = ty2+      , mismatch_whenMatching = Nothing+      , mismatch_mb_same_occ  = Nothing+      }++-- | Whether to use expected/actual in a type mismatch message.+data MismatchEA+  -- | Don't use expected/actual.+  = NoEA+  -- | Use expected/actual.+  | EA+  { mismatch_mbEA :: Maybe ExpectedActualInfo+    -- ^ Whether to also mention type synonym expansion.+  }++data CannotUnifyVariableReason+  =  -- | A type equality between a type variable and a polytype.+    --+    -- Test cases: T12427a, T2846b, T10194, ...+    CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo)++  -- | An occurs check.+  | OccursCheck+    { occursCheckInterestingTyVars :: [TyVar]+    , occursCheckAmbiguityInfos    :: [AmbiguityInfo] }++  -- | A skolem type variable escapes its scope.+  --+  -- Example:+  --+  --   data Ex where { MkEx :: a -> MkEx }+  --   foo (MkEx x) = x+  --+  -- Test cases: TypeSkolEscape, T11142.+  | SkolemEscape ErrorItem Implication [TyVar]++  -- | Can't unify the type variable with the other type+  -- due to the kind of type variable it is.+  --+  -- For example, trying to unify a 'SkolemTv' with the+  -- type Int, or with a 'TyVarTv'.+  | DifferentTyVars TyVarInfo+  | RepresentationalEq TyVarInfo (Maybe CoercibleMsg)+  deriving Generic++-- | Report a mismatch error without any extra+-- information.+mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg+mkPlainMismatchMsg msg+  = Mismatch+     { mismatchMsg           = msg+     , mismatchTyVarInfo     = Nothing+     , mismatchAmbiguityInfo = []+     , mismatchCoercibleInfo = Nothing }++-- | Additional information to be given in a 'CouldNotDeduce' message,+-- which is then passed on to 'mk_supplementary_ea_msg'.+data CND_Extra = CND_Extra TypeOrKind Type Type++-- | A cue to print out information about type variables,+-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@.+data TyVarInfo =+  TyVarInfo { thisTyVar :: TyVar+            , thisTyVarIsUntouchable :: Maybe Implication+            , otherTy   :: Maybe TyVar }++-- | Add some information to disambiguate errors in which+-- two 'Names' would otherwise appear to be identical.+--+-- See Note [Disambiguating (X ~ X) errors].+data SameOccInfo+  = SameOcc+    { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package.+    , sameOcc_lhs :: Name+    , sameOcc_rhs :: Name }++-- | Add some information about ambiguity+data AmbiguityInfo++  -- | Some type variables remained ambiguous: print them to the user.+  = Ambiguity+    { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..."+                                  --  False <=> create a message of the form "The type variable is ambiguous."+    , ambig_tyvars        :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively.+                                                -- Guaranteed to not both be empty.+    }++  -- | Remind the user that a particular type family is not injective.+  | NonInjectiveTyFam TyCon++-- | Expected/actual information.+data ExpectedActualInfo+  -- | Display the expected and actual types.+  = ExpectedActual+     { ea_expected, ea_actual :: Type }++  -- | Display the expected and actual types, after expanding type synonyms.+  | ExpectedActualAfterTySynExpansion+     { ea_expanded_expected, ea_expanded_actual :: Type }++-- | Explain how a kind equality originated.+data WhenMatching++  = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind)+  deriving Generic++data BadImportKind+  -- | Module does not export...+  = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant+  -- | 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+  -- | 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 !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++  -- | A run-of-the-mill @"not in scope"@ error.+  = NotInScope++  -- | Like 'NotInScope', but when we know we are looking for a+  -- record field.+  | NotARecordField++  -- | An exact 'Name' was not in scope.+  --+  -- This usually indicates a problem with a Template Haskell splice.+  --+  -- Test cases: T5971, T18263.+  | NoExactName Name++  -- The same exact 'Name' occurs in multiple name-spaces.+  --+  -- This usually indicates a problem with a Template Haskell splice.+  --+  -- Test case: T7241.+  | SameName [GlobalRdrElt] -- ^ always at least 2 elements++  -- A type signature, fixity declaration, pragma, standalone kind signature...+  -- is missing an associated binding.+  | MissingBinding SigLike [GhcHint]++  -- | Couldn't find a top-level binding.+  --+  -- Happens when specifying an annotation for something that+  -- is not in scope.+  --+  -- Test cases: annfail01, annfail02, annfail11.+  | NoTopLevelBinding++  -- | 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+      Name -- ^ name of the parent+      Subordinate -- ^ the kind of subordinate++  -- | A name is not in scope during type checking but passed the renamer.+  --+  -- Test cases:+  --   none+  | NotInScopeTc (NameEnv TcTyThing)+  deriving Generic++-- | Configuration for pretty-printing valid hole fits.+data HoleFitDispConfig =+  HFDC { showWrap, showWrapVars, showType, showProv, showMatches+          :: Bool }++-- | Report an error involving a 'Hole'.+--+-- This could be an out of scope data constructor or variable,+-- a typed hole, or a wildcard in a type.+data HoleError+  -- | Report an out-of-scope data constructor or variable+  -- masquerading as an expression hole.+  --+  -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint.+  -- See 'NotInScopeError' for other not-in-scope errors.+  --+  -- Test cases: T9177a.+  = OutOfScopeHole+  -- | Report a typed hole, or wildcard, with additional information.+  | HoleError HoleSort+              [TcTyVar]                     -- Other type variables which get computed on the way.+              [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole.++-- | A message that aims to explain why two types couldn't be seen+-- to be representationally equal.+data CoercibleMsg+  -- | Not knowing the role of a type constructor prevents us from+  -- concluding that two types are representationally equal.+  --+  -- Example:+  --+  --   foo :: Applicative m => m (Sum Int)+  --   foo = coerce (pure $ 1 :: Int)+  --+  -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`.+  --+  -- Test cases: T8984, TcCoercibleFail.+  = UnknownRoles Type++  -- | The fact that a 'TyCon' is abstract prevents us from decomposing+  -- a 'TyConApp' and deducing that two types are representationally equal.+  --+  -- Test cases: none.+  | TyConIsAbstract TyCon++  -- | We can't unwrap a newtype whose constructor is not in scope.+  --+  -- Example:+  --+  --   import Data.Ord (Down) -- NB: not importing the constructor+  --   foo :: Int -> Down Int+  --   foo = coerce+  --+  -- Test cases: TcCoercibleFail.+  | OutOfScopeNewtypeConstructor TyCon DataCon++-- | Explain a problem with an import.+data ImportError+  -- | 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) 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+  = PotentialInstances+  { matches  :: [ClsInst]+  , unifiers :: [ClsInst]+  }++-- | A collection of valid hole fits or refinement fits,+-- in which some fits might have been suppressed.+data FitsMbSuppressed+  = Fits+    { fits           :: [HoleFit]+    , fitsSuppressed :: Bool  -- ^ Whether we have suppressed any fits because there were too many.+    }++-- | A collection of hole fits and refinement fits.+data ValidHoleFits+  = ValidHoleFits+    { holeFits       :: FitsMbSuppressed+    , refinementFits :: FitsMbSuppressed+    }++noValidHoleFits :: ValidHoleFits+noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False)++data RelevantBindings+  = RelevantBindings+    { relevantBindingNamesAndTys :: [(Name, Type)]+    , ranOutOfFuel               :: Bool -- ^ Whether we ran out of fuel generating the bindings.+    }++-- | Display some relevant bindings.+pprRelevantBindings :: RelevantBindings -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but it's here for the moment as it's needed in "GHC.Tc.Errors".+pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) =+  ppUnless (null rel_bds) $+    hang (text "Relevant bindings include")+       2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg)+  where+    ppr_binding (nm, tidy_ty) =+      sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty+          , nest 2 (parens (text "bound at"+               <+> ppr (getSrcLoc nm)))]+    rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds++discardMsg :: SDoc+discardMsg = text "(Some bindings suppressed;" <+>+             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"+++-- | Stores the information to be reported in a representation-polymorphism+-- error message.+data FixedRuntimeRepErrorInfo+  = FRR_Info+  { frr_info_origin       :: FixedRuntimeRepOrigin+      -- ^ What is the original type we checked for+      -- representation-polymorphism, and what specific+      -- check did we perform?+  , 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').+  }++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++-- | 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 [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)+  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance+  | ConDeclCtx [LocatedN Name]+  | ClassDeclCtx (LocatedN RdrName)+  | ExprWithTySigCtx+  | TypBrCtx+  | HsTypeCtx+  | HsTypePatCtx+  | GHCiCtx+  | SpliceTypeCtx (LHsType GhcPs)+  | 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+data MatchArgsContext+  = EquationArgs+      !Name -- ^ Name of the function+  | PatternArgs+      !HsMatchContextRn -- ^ Pattern match specifics++-- | The information necessary to report mismatched+-- numbers of arguments in a match group.+data MatchArgBadMatches where+  MatchArgMatches+    ::  { matchArgFirstMatch :: LocatedA (Match GhcRn body)+        , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) }+    -> MatchArgBadMatches++data PragmaWarningInfo+  = PragmaWarningName { pwarn_occname :: OccName+                      , pwarn_impmod :: ModuleName+                      , pwarn_declmod :: ModuleName }+  | PragmaWarningExport { pwarn_occname :: OccName+                        , pwarn_impmod :: ModuleName }+  | PragmaWarningInstance { pwarn_dfunid :: DFunId+                          , pwarn_ctorig :: CtOrigin }+  | PragmaWarningDefault { pwarn_class :: TyCon+                         , pwarn_impmod :: ModuleName }+++-- | The context for an "empty statement group" error.+data EmptyStatementGroupErrReason+  = EmptyStmtsGroupInParallelComp+  -- ^ Empty statement group in a parallel list comprehension+  | EmptyStmtsGroupInTransformListComp+  -- ^ Empty statement group in a transform list comprehension+  --+  --   Example:+  --   [() | then ()]+  | EmptyStmtsGroupInDoNotation HsDoFlavour+  -- ^ Empty statement group in do notation+  --+  --   Example:+  --   do+  | EmptyStmtsGroupInArrowNotation+  -- ^ Empty statement group in arrow notation+  --+  --   Example:+  --   proc () -> do++  deriving (Generic)++-- | An existential wrapper around @'StmtLR' GhcPs GhcPs body@.+data UnexpectedStatement where+  UnexpectedStatement+    :: Outputable (StmtLR GhcPs GhcPs body)+    => StmtLR GhcPs GhcPs body+    -> UnexpectedStatement++data DeclSort = ClassDeclSort | InstanceDeclSort++data NonStandardGuards where+  NonStandardGuards+    :: (Outputable body,+        Anno (Stmt GhcRn body) ~ SrcSpanAnnA)+    => [LStmtLR GhcRn GhcRn body]+    -> NonStandardGuards++data RuleLhsErrReason+  = UnboundVariable RdrName NotInScopeError+  | IllegalExpression++data HsigShapeMismatchReason =+  {-| HsigShapeSortMismatch is an error indicating that an item in the+    export list of a signature doesn't match the item of the same name in+    another signature when merging the two – one is a type while the other is a+    plain identifier.++    Test cases:+      none+  -}+  HsigShapeSortMismatch !AvailInfo !AvailInfo+  |+  {-| HsigShapeNotUnifiable is an error indicating that a name in the+    export list of a signature cannot be unified with a name of the same name in+    another signature when merging the two.++    Test cases:+      bkpfail20, bkpfail21+  -}+  HsigShapeNotUnifiable !Name !Name !Bool+  deriving (Generic)++data WrongThingSort+  = WrongThingType+  | WrongThingDataCon+  | WrongThingPatSyn+  | WrongThingConLike+  | WrongThingClass+  | WrongThingTyCon+  | WrongThingAxiom++data LevelCheckReason+  = LevelCheckInstance !InstanceWhat !PredType+  | LevelCheckSplice !Name !(Maybe GlobalRdrElt)++data UninferrableTyVarCtx+  = UninfTyCtx_ClassContext [TcType]+  | UninfTyCtx_DataContext [TcType]+  | UninfTyCtx_ProvidedContext [TcType]+  | UninfTyCtx_TyFamRhs TcType+  | UninfTyCtx_TySynRhs TcType+  | UninfTyCtx_Sig TcType (LHsSigType GhcRn)++data PatSynInvalidRhsReason+  = PatSynNotInvertible !(Pat GhcRn)+  | PatSynUnboundVar !Name+  deriving (Generic)++data BadFieldAnnotationReason where+  {-| A lazy data type field annotation (~) was used without enabling the+    extension StrictData.++    Test cases:+    LazyFieldsDisabled+  -}+  LazyFieldsDisabled :: BadFieldAnnotationReason+  {-| An UNPACK pragma was applied to a field without strictness annotation (!).++    Test cases:+    T14761a, T7562+  -}+  UnpackWithoutStrictness :: BadFieldAnnotationReason+  {-| 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, T25672, T23307c++    Negative test cases (must not trigger this warning):+      T3990+  -}+  UnusableUnpackPragma :: BadFieldAnnotationReason+  deriving (Generic)++data SuperclassCycle =+  MkSuperclassCycle { cls :: Class, definite :: Bool, reasons :: [SuperclassCycleDetail] }++data SuperclassCycleDetail+  = SCD_HeadTyVar !PredType+  | SCD_HeadTyFam !PredType+  | SCD_Superclass !Class++data RoleValidationFailedReason+  = TyVarRoleMismatch !TyVar !Role+  | TyVarMissingInEnv !TyVar+  | BadCoercionRole !Coercion+  deriving (Generic)++data DisabledClassExtension where+  {-| MultiParamTypeClasses is required.++    Test cases:+    readFail037, TcNoNullaryTC+  -}+  MultiParamDisabled :: !Int -- ^ The arity+                     -> DisabledClassExtension+  {-| FunctionalDependencies is required.++    Test cases:+    readFail041+  -}+  FunDepsDisabled :: DisabledClassExtension+  {-| ConstrainedClassMethods is required.++    Test cases:+    mod39, tcfail150+  -}+  ConstrainedClassMethodsDisabled :: !Id+                                  -> !TcPredType+                                  -> DisabledClassExtension+  deriving (Generic)++data TyFamsDisabledReason+  = TyFamsDisabledFamily !Name+  | TyFamsDisabledInstance !TyCon+  deriving (Generic)++-- | Why was an invisible pattern `@p` rejected?+data BadInvisPatReason+  = InvisPatWithoutFlag+  | InvisPatNoForall+  | InvisPatMisplaced+  deriving (Generic)++-- | Why was the empty case rejected?+data BadEmptyCaseReason+  = EmptyCaseWithoutFlag+  | EmptyCaseDisallowedCtxt+  | EmptyCaseForall ForAllTyBinder++-- | Either `HsType p` or `HsSigType p`.+--+-- Used for reporting errors in `TcRnIllegalKind`.+data HsTypeOrSigType p+  = HsType    (HsType p)+  | HsSigType (HsSigType p)++instance OutputableBndrId p => Outputable (HsTypeOrSigType (GhcPass p)) where+  ppr (HsType ty) = ppr ty+  ppr (HsSigType sig_ty) = ppr sig_ty++-- | A wrapper around HsTyVarBndr.+-- Used for reporting errors in `TcRnUnusedQuantifiedTypeVar`.+data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed =>+  HsTyVarBndrExistentialFlag (HsTyVarBndr flag GhcRn)++instance Outputable HsTyVarBndrExistentialFlag where+  ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr++type TySynCycleTyCons =+  [Either TyCon (LTyClDecl GhcRn)]++-- | Different types of warnings for dodgy imports.+data DodgyImportsReason =+  {-| An import of the form 'T(..)' or 'f(..)' does not actually import anything beside+      'T'/'f' itself.++    Test cases:+      DodgyImports+  -}+  DodgyImportsEmptyParent !GlobalRdrElt+  |+  {-| A 'hiding' clause contains something that would be reported as an error in a+    regular import, but is relaxed to a warning.++    Test cases:+      DodgyImports_hiding+  -}+  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+    module.++    Test cases:+      T21826, recomp001, retc001, mod79, mod80, mod81, mod91, T6007, T7167,+      T9006, T11071, T9905fail2, T5385, T10668+  -}+  ImportLookupBad :: BadImportKind+                  -> ModIface+                  -> ImpDeclSpec+                  -> IE GhcPs+                  -> ImportLookupExtensions+                  -> ImportLookupReason+  {-| A name is specified with a qualifying module.++    Test cases:+      T3792+  -}+  ImportLookupQualified :: !RdrName -- ^ The name extracted from the import item+                        -> ImportLookupReason++  {-| Something completely unexpected is in an import list, like @module Foo@.++    Test cases:+      ImportLookupIllegal+  -}+  ImportLookupIllegal :: ImportLookupReason+  {-| An item in an import list matches multiple names exported from that module.++    Test cases:+      None+  -}+  ImportLookupAmbiguous :: !RdrName -- ^ The name extracted from the import item+                        -> ![GlobalRdrElt] -- ^ The potential matches+                        -> ImportLookupReason+  deriving (Generic)++-- | Distinguish record fields from other names for pretty-printing.+data UnusedImportName where+  UnusedImportNameRecField :: !Parent -> !OccName -> UnusedImportName+  UnusedImportNameRegular :: !Name -> UnusedImportName++-- | Different types of errors for unused imports.+data UnusedImportReason where+  {-| No names in the import list are used in the module.++    Test cases:+      overloadedrecfldsfail06, T10890_2, t22391, t22391j, T1074, prog018,+      mod177, rn046, rn037, T5211+  -}+  UnusedImportNone :: UnusedImportReason+  {-| A set of names in the import list are not used in the module.++    Test cases:+      overloadedrecfldsfail06, T17324, mod176, T11970A, rn046, T14881,+      T7454, T8149, T13064+  -}+  UnusedImportSome :: ![UnusedImportName] -- ^ The unsed names+                   -> UnusedImportReason+  deriving (Generic)++-- | Different places in which a nested foralls/contexts error might occur.+data NestedForallsContextsIn+  -- | Nested forall in @SPECIALISE instance@+  = NFC_Specialize+  -- | Nested forall in @deriving via@ (via-type)+  | NFC_ViaType+  -- | Nested forall in the type of a GADT constructor+  | NFC_GadtConSig+  -- | Nested forall in an instance head+  | NFC_InstanceHead+  -- | Nested forall in a standalone deriving instance head+  | NFC_StandaloneDerivedInstanceHead+  -- | Nested forall in deriving class type+  | NFC_DerivedClassType++-- | Provenance of an unused name.+data UnusedNameProv+  = UnusedNameTopDecl+  | UnusedNameImported !ModuleName+  | UnusedNameTypePattern+  | UnusedNameMatch+  | UnusedNameLocalBind++-- | Different reasons for TcRnNonCanonicalDefinition.+data NonCanonicalDefinition =+  -- | Related to @(<>)@ and @mappend@.+  NonCanonicalMonoid NonCanonical_Monoid+  |+  -- | Related to @(*>)@/@(>>)@ and @pure@/@return@.+  NonCanonicalMonad NonCanonical_Monad+  deriving (Generic)++-- | Possible cases for the -Wnoncanonical-monoid-instances.+data NonCanonical_Monoid =+  -- | @(<>) = mappend@ was defined.+  NonCanonical_Sappend+  |+  -- | @mappend@ was defined as something other than @(<>)@.+  NonCanonical_Mappend++-- | Possible cases for the -Wnoncanonical-monad-instances.+data NonCanonical_Monad =+  -- | @pure = return@ was defined.+  NonCanonical_Pure+  |+  -- | @(*>) = (>>)@ was defined.+  NonCanonical_ThenA+  |+  -- | @return@ was defined as something other than @pure@.+  NonCanonical_Return+  |+  -- | @(>>)@ was defined as something other than @(*>)@.+  NonCanonical_ThenM++-- | Why was an instance declaration rejected?+data IllegalInstanceReason+  = IllegalClassInstance+      !TypedThing -- ^ the instance head type+      !IllegalClassInstanceReason -- ^ the problem with the instance head+  | IllegalFamilyInstance !IllegalFamilyInstanceReason+  | IllegalFamilyApplicationInInstance+      !Type   -- ^ the instance head type+      !Bool   -- ^ is this an invisible argument?+      !TyCon  -- ^ type family+      ![Type] -- ^ type family argument+  deriving Generic++-- | Why was a class instance declaration rejected?+data IllegalClassInstanceReason+  -- | An illegal type at the head of the instance.+  --+  -- See t'IllegalInstanceHeadReason'.+  = IllegalInstanceHead !IllegalInstanceHeadReason+  -- | An illegal HasField instance. See t'IllegalHasFieldInstance'.+  | IllegalHasFieldInstance !IllegalHasFieldInstance+  -- | An illegal instance for a built-in typeclass such as+  --   'Coercible', 'Typeable', or 'KnownNat', outside of a signature file.+  --+  --   Test cases: deriving/should_fail/T9687+  --               deriving/should_fail/T14916+  --               polykinds/T8132+  --               typecheck/should_fail/TcCoercibleFail2+  --               typecheck/should_fail/T12837+  --               typecheck/should_fail/T14390+  | IllegalSpecialClassInstance !Class !Bool -- ^ Whether the error is due to Safe Haskell being enabled+  -- | The instance failed the coverage condition, i.e. the functional+  -- dependencies were not respected.+  --+  -- Example:+  --+  --  class C a b | a -> b where {..}+  --  instance C a b where {..}+  --+  -- Test cases: T9106, T10570, T2247, T12803, tcfail170.+  | IllegalInstanceFailsCoverageCondition+      !Class !CoverageProblem+  deriving Generic++-- | Why was a HasField instance declaration rejected?+data IllegalHasFieldInstance+  -- | HasField instance for a type not headed by a TyCon.+  --+  -- Example:+  --+  --   instance HasField a where {..}+  --+  -- Test case: hasfieldfail03+  = IllegalHasFieldInstanceNotATyCon+  -- | HasField instance for a data family.+  --+  -- Example:+  --+  --  data family D a+  --  data instance D Int = MkDInt Char+  --+  --  instance HasField "fld" (D Int) where {..}+  --+  -- Test case: hasfieldfail03+  | IllegalHasFieldInstanceFamilyTyCon+  -- | HasField instance for a type that already has that field.+  --+  -- Example+  --+  --  data T = MkT { quux :: Int }+  --  instance HasField "quux" T Int where {..}+  --+  -- Test case: hasfieldfail03+  | IllegalHasFieldInstanceTyConHasField !TyCon !FieldLabelString+  -- | HasField instance for a type that already has fields, when the+  -- field label could potentially unify with those fields.+  --+  -- Example:+  --+  --  data T = MkInt { quux :: Int }+  --  instance forall (fld :: Symbol). HasField fld T Int where {..}+  --+  -- Test case: hasfieldfail03+  | IllegalHasFieldInstanceTyConHasFields !TyCon !Type -- ^ the label type in the instance head+  deriving Generic++-- | Description of an instance coverage condition failure.+data CoverageProblem =+  CoverageProblem+    { not_covered_fundep        :: ([TyVar], [TyVar])+    , not_covered_fundep_inst   :: ([Type], [Type])+    , not_covered_invis_vis_tvs :: Pair VarSet+    , not_covered_liberal       :: FailedCoverageCondition+    }++-- | Which instance coverage condition failed? Was it the liberal+-- coverage condition?+data FailedCoverageCondition+  -- | Failed the instance coverage condition (ICC)+  = FailedICC+    { alsoFailedLICC :: !Bool+      -- ^ Whether the instance also failed the LICC+    }+  -- | Failed the liberal instance coverage condition (LICC)+  | FailedLICC++--------------------------------------------------------------------------------+-- Template Haskell errors++data THError+  -- | A syntax error with Template Haskel quotes & splices.+  -- See t'THSyntaxError'.+  = THSyntaxError !THSyntaxError+  -- | An error in Template Haskell involving 'Name's.+  -- See t'THNameError'.+  | THNameError !THNameError+  -- | An error in Template Haskell reification. See t'THReifyError'.+  | THReifyError !THReifyError+  -- | An error due to typing restrictions in Typed Template Haskell.+  -- See t'TypedTHError'.+  | TypedTHError !TypedTHError+  -- | An error occurred when trying to run a splice in Template Haskell.+  -- See 'SpliceFailReason'.+  | THSpliceFailed !SpliceFailReason+  -- | An error involving the 'addTopDecls' functionality. See t'AddTopDeclsError'.+  | AddTopDeclsError !AddTopDeclsError++  {-| IllegalStaticFormInSplice is an error when a user attempts to define+      a static pointer in a Template Haskell splice.++      Example(s):++     Test cases: th/TH_StaticPointers02+  -}+  | IllegalStaticFormInSplice !(HsExpr GhcPs)++  {-| FailedToLookupThInstName is a Template Haskell error that occurrs when looking up an+      instance fails.++      Example(s):++      Test cases: showIface/should_fail/THPutDocNonExistent+  -}+  | FailedToLookupThInstName !TH.Type !LookupTHInstNameErrReason++  {-| AddInvalidCorePlugin is a Template Haskell error indicating that a+      Core plugin being added has an invalid module due to being+      in the current package.++      Example(s):++      Test cases:+  -}+  | AddInvalidCorePlugin !String -- ^ Module name++  {-| AddDocToNonLocalDefn is a Template Haskell error for documentation being added to a+      definition which is not in the current module.++      Example(s):++      Test cases: showIface/should_fail/THPutDocExternal+  -}+  | AddDocToNonLocalDefn !TH.DocLoc++  {-| ReportCustomQuasiError is an error or warning thrown using 'qReport' from+      the 'Quasi' instance of 'TcM'.++      Example(s):++      Test cases:+  -}+  | ReportCustomQuasiError+    !Bool -- ^ True => Error, False => Warning+    !String -- ^ Error body+  deriving Generic++-- | An error involving Template Haskell quotes or splices, e.g. nested+-- quotation brackets or the use of an untyped bracket inside a typed splice.+data THSyntaxError+  = {-| IllegalTHQuotes is an error that occurs when a Template Haskell+        quote is used without the TemplateHaskell extension enabled.++        Test case: T18251e+    -}+    IllegalTHQuotes !(HsExpr GhcPs)++    {-| IllegalTHSplice is an error that occurs when a Template Haskell+        splice occurs without having enabled the TemplateHaskell extension.++        Test cases:+          bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06+    -}+  | IllegalTHSplice++    {-| NestedTHBrackets is an error that occurs when Template Haskell+        brackets are nested without any intervening splices.++        Example:++          foo = [| [| 'x' |] |]++        Test cases: TH_NestedSplicesFail{5,6,7,8}+    -}+  | NestedTHBrackets++  {-| MismatchedSpliceType is an error that happens when a typed bracket+      or splice is used inside a typed splice/bracket, or the other way around.++      Examples:++        f1 = [| $$x |]+        f2 = [|| $y ||]+        f3 = $$( [| 'x' |] )+        f4 = $( [|| 'y' ||] )++      Test cases: TH_NestedSplicesFail{1,2,3,4}+  -}+  | MismatchedSpliceType+      SpliceType -- ^ type of the splice+      SpliceOrBracket -- ^ what's nested inside+  {-| BadImplicitSplice is an error thrown when a user uses top-level implicit+      TH-splice without enabling the TemplateHaskell extension.++      Example:++        pure [] -- on top-level++      Test cases: ghci/prog019/prog019+                  ghci/scripts/T1914+                  ghci/scripts/T6106+                  rename/should_fail/T4042+                  rename/should_fail/T12146+  -}+  | BadImplicitSplice+  deriving Generic++data THNameError+  {-| NonExactName is a Template Haskell error that occurs when the user+      attempts to define a binder with a 'RdrName' that is not an exact 'Name'.++      Example(s):++      Test cases:+  -}+  = NonExactName !RdrName++  deriving Generic++data THReifyError+  = {-| CannotReifyInstance is a Template Haskell error for when an instance being reified+        via `reifyInstances` is not a class constraint or type family application.++        Example(s):++       Test cases:+    -}+    CannotReifyInstance !Type++  {-| CannotReifyOutOfScopeThing is a Template Haskell error indicating+      that the given name is not in scope and therefore cannot be reified.++      Example(s):++     Test cases: th/T16976f+  -}+ | CannotReifyOutOfScopeThing !TH.Name++  {-| CannotReifyThingNotInTypeEnv is a Template Haskell error occurring+      when the given name is not in the type environment and therefore cannot be reified.++      Example(s):++     Test cases:+  -}+  | CannotReifyThingNotInTypeEnv !Name++  {-| NoRolesAssociatedWithName is a Template Haskell error for when the user+      tries to reify the roles of a given name but it is not something that has+      roles associated with it.++      Example(s):++     Test cases:+  -}+  | NoRolesAssociatedWithThing !TcTyThing++  {-| CannotRepresentThing is a Template Haskell error indicating that a+      type cannot be reified because it does not have a representation in Template Haskell.++      Example(s):++     Test cases:+  -}+  | CannotRepresentType !UnrepresentableTypeDescr !Type+  deriving Generic++data AddTopDeclsError+  = {-| InvalidTopDecl is a Template Haskell error occurring when one of the 'Dec's passed to+      'addTopDecls' is not a function, value, annotation, or foreign import declaration.++       Example(s):++       Test cases:+    -}+    InvalidTopDecl !(HsDecl GhcPs)+    {-| UnexpectedDeclarationSplice is an error that occurs when a Template Haskell+        splice appears inside top-level declarations added with 'addTopDecls'.++        Example(s): none++        Test cases: none+  -}+  | AddTopDeclsUnexpectedDeclarationSplice++  | AddTopDeclsRunSpliceFailure !RunSpliceFailReason+  deriving Generic++data TypedTHError+  = {-| SplicePolymorphicLocalVar is the error that occurs when the expression+        inside typed Template Haskell brackets is a polymorphic local variable.++        Example(s):+        x = \(y :: forall a. a -> a) -> [|| y ||]++       Test cases: quotes/T10384+    -}+    SplicePolymorphicLocalVar !Id++    {-| TypedTHWithPolyType is an error that signifies the illegal use+        of a polytype in a typed Template Haskell expression.++        Example(s):+        bad :: (forall a. a -> a) -> ()+        bad = $$( [|| \_ -> () ||] )++       Test cases: th/T11452+    -}+  | TypedTHWithPolyType !TcType+  deriving Generic++data SpliceFailReason+  = {-| SpliceThrewException is an error that occurs when running a Template+        Haskell splice throws an exception.++        Example(s):++       Test cases: annotations/should_fail/annfail12+                   perf/compiler/MultiLayerModulesTH_Make+                   perf/compiler/MultiLayerModulesTH_OneShot+                   th/T10796b+                   th/T19470+                   th/T19709d+                   th/T5358+                   th/T5976+                   th/T7276a+                   th/T8987+                   th/TH_exn1+                   th/TH_exn2+                   th/TH_runIO+  -}+  SpliceThrewException+    !SplicePhase+    !SomeException+    !String -- ^ Result of showing the exception (cannot be done safely outside IO)+    !(LHsExpr GhcTc)+    !Bool -- True <=> Print the expression++  {-| RunSpliceFailure is an error indicating that a Template Haskell splice+      failed to be converted into a valid expression.++      Example(s):++     Test cases: th/T10828a+                 th/T10828b+                 th/T12478_4+                 th/T15270A+                 th/T15270B+                 th/T16895a+                 th/T16895b+                 th/T16895c+                 th/T16895d+                 th/T16895e+                 th/T18740d+                 th/T2597b+                 th/T2674+                 th/T3395+                 th/T7484+                 th/T7667a+                 th/TH_implicitParamsErr1+                 th/TH_implicitParamsErr2+                 th/TH_implicitParamsErr3+                 th/TH_invalid_add_top_decl+  -}+  | RunSpliceFailure !RunSpliceFailReason+  deriving Generic++data RunSpliceFailReason+  = ConversionFail !ThingBeingConverted !ConversionFailReason+  deriving Generic++-- | Identifies the TH splice attempting to be converted+data ThingBeingConverted+  = ConvDec !TH.Dec+  | ConvExp !TH.Exp+  | ConvPat !TH.Pat+  | ConvType !TH.Type++-- | The reason a TH splice could not be converted to a Haskell expression+data ConversionFailReason+  = IllegalOccName !OccName.NameSpace !String+  | SumAltArityExceeded !TH.SumAlt !TH.SumArity+  | IllegalSumAlt !TH.SumAlt+  | IllegalSumArity !TH.SumArity+  | MalformedType !TypeOrKind !TH.Type+  | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs))+  | KindSigsOnlyAllowedOnGADTs+  | IllegalDeclaration !THDeclDescriptor !IllegalDecls+  | CannotMixGADTConsWith98Cons+  | EmptyStmtListInDoBlock+  | NonVarInInfixExpr+  | MultiWayIfWithoutAlts+  | CasesExprWithoutAlts+  | ImplicitParamsWithOtherBinds+  | InvalidCCallImpent !String -- ^ Source+  | RecGadtNoCons+  | GadtNoCons+  | InvalidTypeInstanceHeader !TH.Type+  | InvalidTyFamInstLHS !TH.Type+  | InvalidImplicitParamBinding+  | DefaultDataInstDecl ![LDataFamInstDecl GhcPs]+  | FunBindLacksEquations !TH.Name+  | EmptyGuard+  | EmptyParStmt+  deriving Generic++data IllegalDecls+  = IllegalDecls    !(NE.NonEmpty (LHsDecl GhcPs))+  | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs))++-- | Label for a TH declaration+data THDeclDescriptor+  = InstanceDecl+  | WhereClause+  | LetBinding+  | LetExpression+  | ClssDecl++-- | The phase in which an exception was encountered when dealing with a TH splice+data SplicePhase+  = SplicePhase_Run+  | SplicePhase_CompileAndLink++data LookupTHInstNameErrReason+  = NoMatchesFound+  | CouldNotDetermineInstance++data UnrepresentableTypeDescr+  = LinearInvisibleArgument+  | CoercionsInTypes+  | DataConVisibleForall++-- FFI error types+data IllegalForeignTypeReason+  = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason+  | ForeignDynNotPtr+      !Type -- ^ Expected type+      !Type -- ^ Actual type+  | SafeHaskellMustBeInIO+  | IOResultExpected+  | UnexpectedNestedForall+  | LinearTypesNotAllowed+  | OneArgExpected+  | AtLeastOneArgExpected+  deriving Generic++-- | Reason why a type cannot be marshalled through the FFI.+data TypeCannotBeMarshaledReason+  = NotADataType+  | NewtypeDataConNotInScope !TyCon ![Type]+  | UnliftedFFITypesNeeded+  | NotABoxedMarshalableTyCon+  | ForeignLabelNotAPtr+  | NotSimpleUnliftedType+  | NotBoxedKindAny+  deriving Generic++data TcRnNoDerivStratSpecifiedInfo where+  {-| 'TcRnNoDerivStratSpecified TcRnNoDerivingClauseStrategySpecified' is+       a warning implied by -Wmissing-deriving-strategies and triggered by a+       deriving clause without a specified deriving strategy.++      Example:++        newtype T = T Int+          deriving (Eq, Ord, Show)++      Here we would suggest fixing the deriving clause to:++        deriving stock (Show)+        deriving newtype (Eq, Ord)++      Test cases: deriving/should_compile/T15798a+                  deriving/should_compile/T15798c+                  deriving/should_compile/T24955a+                  deriving/should_compile/T24955b+   -}+  TcRnNoDerivingClauseStrategySpecified+    :: Map AssumedDerivingStrategy [LHsSigType GhcRn]+    -> TcRnNoDerivStratSpecifiedInfo++  {-| 'TcRnNoDerivStratSpecified TcRnNoStandaloneDerivingStrategySpecified' is+       a warning implied by -Wmissing-deriving-strategies and triggered by a+       standalone deriving declaration without a specified deriving strategy.++      Example:++        data T a = T a+        deriving instance Show a => Show (T a)++      Here we would suggest fixing the instance to:++        deriving stock instance Show a => Show (T a)++      Test cases: deriving/should_compile/T15798b+                  deriving/should_compile/T24955c+   -}+  TcRnNoStandaloneDerivingStrategySpecified+    :: AssumedDerivingStrategy+    -> LHsSigWcType GhcRn -- ^ The instance signature (e.g @Show a => Show (T a)@)+    -> TcRnNoDerivStratSpecifiedInfo++-- | Label for syntax that may occur in terms (expressions) only as part of a+--   required type argument.+data TypeSyntax+  = TypeKeywordSyntax      -- ^ @type t@+  | ContextArrowSyntax     -- ^ @ctx => t@+  | FunctionArrowSyntax    -- ^ @t1 -> t2@+  | ForallTelescopeSyntax  -- ^ @forall tvs. t@+  deriving Generic++typeSyntaxExtension :: TypeSyntax -> LangExt.Extension+typeSyntaxExtension TypeKeywordSyntax     = LangExt.ExplicitNamespaces+typeSyntaxExtension ContextArrowSyntax    = LangExt.RequiredTypeArguments+typeSyntaxExtension FunctionArrowSyntax   = LangExt.RequiredTypeArguments+typeSyntaxExtension ForallTelescopeSyntax = LangExt.RequiredTypeArguments
+ compiler/GHC/Tc/Errors/Types/PromotionErr.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..)+                                        , pprPECategory+                                        , peCategory+                                        , TermLevelUseErr(..)+                                        , TermLevelUseCtxt(..)+                                        , pprTermLevelUseCtxt+                                        , teCategory+                                        ) where++import GHC.Prelude+import GHC.Core.Type (ThetaType)+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+                     --     data T :: T -> * where ...+  | ClassPE          -- Ditto Class++  | FamDataConPE     -- Data constructor for a data family+                     -- See Note [AFamDataCon: not promoting data family constructors]+                     -- in GHC.Tc.Utils.Env.+  | ConstrainedDataConPE ThetaType -- Data constructor with a context+                                   -- See Note [No constraints in kinds] in GHC.Tc.Validity+  | PatSynPE         -- Pattern synonyms+                     -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env++  | RecDataConPE     -- Data constructor in a recursive loop+                     -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl+  | TermVariablePE   -- See Note [Demotion of unqualified variables] in GHC.Rename.Env+  | TypeVariablePE   -- See Note [Type variable scoping errors during typechecking]+  deriving (Generic)++instance Outputable PromotionErr where+  ppr ClassPE              = text "ClassPE"+  ppr TyConPE              = text "TyConPE"+  ppr PatSynPE             = text "PatSynPE"+  ppr FamDataConPE         = text "FamDataConPE"+  ppr (ConstrainedDataConPE theta) = text "ConstrainedDataConPE" <+> parens (ppr theta)+  ppr RecDataConPE         = text "RecDataConPE"+  ppr TermVariablePE       = text "TermVariablePE"+  ppr TypeVariablePE       = text "TypeVariablePE"++pprPECategory :: PromotionErr -> SDoc+pprPECategory = text . capitalise . peCategory++peCategory :: PromotionErr -> String+peCategory ClassPE              = "class"+peCategory TyConPE              = "type constructor"+peCategory PatSynPE             = "pattern synonym"+peCategory FamDataConPE         = "data constructor"+peCategory ConstrainedDataConPE{} = "data constructor"+peCategory RecDataConPE         = "data constructor"+peCategory TermVariablePE       = "term variable"+peCategory TypeVariablePE       = "type variable"++-- The opposite of a promotion error (a demotion error, in a sense).+data TermLevelUseErr+  = TyConTE   -- Type constructor used at the term level, e.g. x = Int+  | ClassTE   -- Class used at the term level,            e.g. x = Functor+  | TyVarTE   -- Type variable used at the term level,    e.g. f (Proxy :: Proxy a) = a+  deriving (Generic)++teCategory :: TermLevelUseErr -> String+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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the scoping of the type variable `a` in the following+term-level example:++  -- f :: [forall b . Either b ()]+  f = [Right @a @() () :: forall a. Either a ()]++Here `@a` in the type application and `a` in the type signature refer to+the same type variable. Indeed, this term elaborates to the following Core:++  f = [(\@a -> Right @a @() ()) :: forall a . Either a ()]++But how does this work with types? Suppose we have:++  type F = '[Right @a @() () :: forall a. Either a ()]++To be consistent with the term-level language, we would have to elaborate+this using a big lambda:++  type F = '[(/\ a . Right @a @() ()) :: forall a. Either a ()]++Core has no such construct, so this is not a valid type.++Conclusion: Even with -XExtendedForAllScope, the forall'd variables of a+kind signature on a type cannot scope over the type.++In implementation terms, to get a helpful error message we do this:++* The renamer treats the type variable as bound by the forall+  (so it doesn't just say "out of scope"); see the `HsKindSig` case of GHC.Rename.HsType.rnHsTyKi.++* The typechecker adds the forall-bound type variables to the type environent,+  but bound to `APromotionErr TypeVariablePE`; see the call to `tcAddKindSigPlaceholders`+  in the `HsKindSig` case of `GHC.Tc.Gen.HsType.tc_infer_hs_type`.++* The occurrence site of a type variable then complains when it finds `APromotionErr`;+  see `GHC.Tc.Gen.HsType.tcTyVar`.+-}
compiler/GHC/Tc/Solver/InertSet.hs view
@@ -1,1839 +1,2142 @@ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Tc.Solver.InertSet (-    -- * The work list-    WorkList(..), isEmptyWorkList, emptyWorkList,-    extendWorkListNonEq, extendWorkListCt,-    extendWorkListCts, extendWorkListEq,-    appendWorkList, extendWorkListImplic,-    workListSize,-    selectWorkItem,--    -- * The inert set-    InertSet(..),-    InertCans(..),-    InertEqs,-    emptyInert,-    addInertItem,--    noMatchableGivenDicts,-    noGivenNewtypeReprEqs,-    mightEqualLater,-    prohibitedSuperClassSolve,--    -- * Inert equalities-    foldTyEqs, delEq, findEq,-    partitionInertEqs, partitionFunEqs,--    -- * Kick-out-    kickOutRewritableLHS,--    -- * Cycle breaker vars-    CycleBreakerVarStack,-    pushCycleBreakerVarStack,-    insertCycleBreakerBinding,-    forAllCycleBreakerBindings_--  ) where--import GHC.Prelude--import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin-import GHC.Tc.Solver.Types-import GHC.Tc.Utils.TcType--import GHC.Types.Var-import GHC.Types.Var.Env--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.Unify--import GHC.Data.Bag-import GHC.Utils.Misc       ( partitionWith )-import GHC.Utils.Outputable-import GHC.Utils.Panic--import Data.List          ( partition )-import Data.List.NonEmpty ( NonEmpty(..), (<|) )-import qualified Data.List.NonEmpty as NE-import GHC.Utils.Panic.Plain-import GHC.Data.Maybe-import Control.Monad      ( forM_ )--{--************************************************************************-*                                                                      *-*                            Worklists                                *-*  Canonical and non-canonical constraints that the simplifier has to  *-*  work on. Including their simplification depths.                     *-*                                                                      *-*                                                                      *-************************************************************************--Note [WorkList priorities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A WorkList contains canonical and non-canonical items (of all flavours).-Notice that each Ct now has a simplification depth. We may-consider using this depth for prioritization as well in the future.--As a simple form of priority queue, our worklist separates out--* equalities (wl_eqs); see Note [Prioritise equalities]-* all the rest (wl_rest)--Note [Prioritise equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to process equalities /first/:--* (Efficiency)  The general reason to do so is that if we process a-  class constraint first, we may end up putting it into the inert set-  and then kicking it out later.  That's extra work compared to just-  doing the equality first.--* (Avoiding fundep iteration) As #14723 showed, it's possible to-  get non-termination if we-      - Emit the fundep equalities for a class constraint,-        generating some fresh unification variables.-      - That leads to some unification-      - Which kicks out the class constraint-      - Which isn't solved (because there are still some more-        equalities in the work-list), but generates yet more fundeps-  Solution: prioritise equalities over class constraints--* (Class equalities) We need to prioritise equalities even if they-  are hidden inside a class constraint;-  see Note [Prioritise class equalities]--* (Kick-out) We want to apply this priority scheme to kicked-out-  constraints too (see the call to extendWorkListCt in kick_out_rewritable-  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become-  homo-kinded when kicked out, and hence we want to prioritise it.--Note [Prioritise class equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prioritise equalities in the solver (see selectWorkItem). But class-constraints like (a ~ b) and (a ~~ b) are actually equalities too;-see Note [The equality types story] in GHC.Builtin.Types.Prim.--Failing to prioritise these is inefficient (more kick-outs etc).-But, worse, it can prevent us spotting a "recursive knot" among-Wanted constraints.  See comment:10 of #12734 for a worked-out-example.--So we arrange to put these particular class constraints in the wl_eqs.--  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     :: [Ct]  -- CEqCan, CDictCan, CIrredCan-                             -- Given and Wanted-                       -- Contains both equality constraints and their-                       -- class-level variants (a~b) and (a~~b);-                       -- See Note [Prioritise equalities]-                       -- See Note [Prioritise class equalities]--       , wl_rest    :: [Ct]--       , wl_implics :: Bag Implication  -- See Note [Residual implications]-    }--appendWorkList :: WorkList -> WorkList -> WorkList-appendWorkList-    (WL { wl_eqs = eqs1, wl_rest = rest1-        , wl_implics = implics1 })-    (WL { wl_eqs = eqs2, wl_rest = rest2-        , wl_implics = implics2 })-   = WL { wl_eqs     = eqs1     ++ eqs2-        , wl_rest    = rest1    ++ rest2-        , wl_implics = implics1 `unionBags`   implics2 }--workListSize :: WorkList -> Int-workListSize (WL { wl_eqs = eqs, wl_rest = rest })-  = length eqs + length rest--extendWorkListEq :: Ct -> WorkList -> WorkList-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }--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-extendWorkListCt ct wl- = case classifyPredType (ctPred ct) of-     EqPred {}-       -> extendWorkListEq ct wl--     ClassPred cls _  -- See Note [Prioritise class equalities]-       |  isEqPredClass cls-       -> extendWorkListEq ct wl--     _ -> extendWorkListNonEq ct wl--extendWorkListCts :: [Ct] -> WorkList -> WorkList--- Agnostic-extendWorkListCts cts wl = foldr extendWorkListCt wl cts--isEmptyWorkList :: WorkList -> Bool-isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-  = null eqs && null rest && isEmptyBag implics--emptyWorkList :: WorkList-emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }--selectWorkItem :: WorkList -> Maybe (Ct, WorkList)--- See Note [Prioritise equalities]-selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })-  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })-  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })-  | otherwise      = Nothing---- Pretty printing-instance Outputable WorkList where-  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-   = text "WL" <+> (braces $-     vcat [ ppUnless (null eqs) $-            text "Eqs =" <+> vcat (map ppr 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)")-          ])--{- *********************************************************************-*                                                                      *-                InertSet: the inert set-*                                                                      *-*                                                                      *-********************************************************************* -}--type CycleBreakerVarStack = NonEmpty [(TcTyVar, TcType)]-   -- ^ a stack of (CycleBreakerTv, original family applications) lists-   -- first element in the stack corresponds to current implication;-   --   later elements correspond to outer implications-   -- used to undo the cycle-breaking needed to handle-   -- Note [Type equality cycles] in GHC.Tc.Solver.Canonical-   -- Why store the outer implications? For the use in mightEqualLater (only)--data InertSet-  = IS { inert_cans :: InertCans-              -- Canonical Given, Wanted-              -- Sometimes called "the inert set"--       , inert_cycle_breakers :: CycleBreakerVarStack--       , inert_famapp_cache :: FunEqMap Reduction-              -- Just a hash-cons cache for use when reducing family applications-              -- only-              ---              -- If    F tys :-> (co, rhs, flav),-              -- then  co :: F tys ~N rhs-              -- all evidence is from instances or Givens; no coercion holes here-              -- (We have no way of "kicking out" from the cache, so putting-              --  wanteds here means we can end up solving a Wanted with itself. Bad)--       , inert_solved_dicts   :: DictMap CtEvidence-              -- All Wanteds, of form ev :: C t1 .. tn-              -- See Note [Solved dictionaries]-              -- and Note [Do not add superclasses of solved dictionaries]-       }--instance Outputable InertSet where-  ppr (IS { inert_cans = ics-          , inert_solved_dicts = solved_dicts })-      = vcat [ ppr ics-             , ppUnless (null dicts) $-               text "Solved dicts =" <+> vcat (map ppr dicts) ]-         where-           dicts = bagToList (dictsToBag solved_dicts)--emptyInertCans :: InertCans-emptyInertCans-  = IC { inert_eqs          = emptyDVarEnv-       , inert_given_eq_lvl = topTcLevel-       , inert_given_eqs    = False-       , inert_dicts        = emptyDictMap-       , inert_safehask     = emptyDictMap-       , inert_funeqs       = emptyFunEqs-       , inert_insts        = []-       , inert_irreds       = emptyCts }--emptyInert :: InertSet-emptyInert-  = IS { inert_cans           = emptyInertCans-       , inert_cycle_breakers = [] :| []-       , inert_famapp_cache   = emptyFunEqs-       , inert_solved_dicts   = emptyDictMap }---{- Note [Solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we apply a top-level instance declaration, we add the "solved"-dictionary to the inert_solved_dicts.  In general, we use it to avoid-creating a new EvVar when we have a new goal that we have solved in-the past.--But in particular, we can use it to create *recursive* dictionaries.-The simplest, degenerate case is-    instance C [a] => C [a] where ...-If we have-    [W] d1 :: C [x]-then we can apply the instance to get-    d1 = $dfCList d-    [W] d2 :: C [x]-Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.-    d1 = $dfCList d-    d2 = d1--See Note [Example of recursive dictionaries]--VERY IMPORTANT INVARIANT:-- (Solved Dictionary Invariant)-    Every member of the inert_solved_dicts is the result-    of applying an instance declaration that "takes a step"--    An instance "takes a step" if it has the form-        dfunDList d1 d2 = MkD (...) (...) (...)-    That is, the dfun is lazy in its arguments, and guarantees to-    immediately return a dictionary constructor.  NB: all dictionary-    data constructors are lazy in their arguments.--    This property is crucial to ensure that all dictionaries are-    non-bottom, which in turn ensures that the whole "recursive-    dictionary" idea works at all, even if we get something like-        rec { d = dfunDList d dx }-    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.-- Reason:-   - All instances, except two exceptions listed below, "take a step"-     in the above sense--   - Exception 1: local quantified constraints have no such guarantee;-     indeed, adding a "solved dictionary" when applying a quantified-     constraint led to the ability to define unsafeCoerce-     in #17267.--   - Exception 2: the magic built-in instance for (~) has no-     such guarantee.  It behaves as if we had-         class    (a ~# b) => (a ~ b) where {}-         instance (a ~# b) => (a ~ b) where {}-     The "dfun" for the instance is strict in the coercion.-     Anyway there's no point in recording a "solved dict" for-     (t1 ~ t2); it's not going to allow a recursive dictionary-     to be constructed.  Ditto (~~) and Coercible.--THEREFORE we only add a "solved dictionary"-  - when applying an instance declaration-  - subject to Exceptions 1 and 2 above--In implementation terms-  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,-    conditional on the kind of instance--  - It is only called when applying an instance decl,-    in GHC.Tc.Solver.Interact.doTopReactDict--  - ClsInst.InstanceWhat says what kind of instance was-    used to solve the constraint.  In particular-      * LocalInstance identifies quantified constraints-      * BuiltinEqInstance identifies the strange built-in-        instances for equality.--  - ClsInst.instanceReturnsDictCon says which kind of-    instance guarantees to return a dictionary constructor--Other notes about solved dictionaries--* See also Note [Do not add superclasses of solved dictionaries]--* The inert_solved_dicts field is not rewritten by equalities,-  so it may get out of date.--* The inert_solved_dicts are all Wanteds, never givens--* We only cache dictionaries from top-level instances, not from-  local quantified constraints.  Reason: if we cached the latter-  we'd need to purge the cache when bringing new quantified-  constraints into scope, because quantified constraints "shadow"-  top-level instances.--Note [Do not add superclasses of solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every member of inert_solved_dicts is the result of applying a-dictionary function, NOT of applying superclass selection to anything.-Consider--        class Ord a => C a where-        instance Ord [a] => C [a] where ...--Suppose we are trying to solve-  [G] d1 : Ord a-  [W] d2 : C [a]--Then we'll use the instance decl to give--  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3-  [W] d3 : Ord [a]--We must not add d4 : Ord [a] to the 'solved' set (by taking the-superclass of d2), otherwise we'll use it to solve d3, without ever-using d1, which would be a catastrophe.--Solution: when extending the solved dictionaries, do not add superclasses.-That's why each element of the inert_solved_dicts is the result of applying-a dictionary function.--Note [Example of recursive dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Example 1--    data D r = ZeroD | SuccD (r (D r));--    instance (Eq (r (D r))) => Eq (D r) where-        ZeroD     == ZeroD     = True-        (SuccD a) == (SuccD b) = a == b-        _         == _         = False;--    equalDC :: D [] -> D [] -> Bool;-    equalDC = (==);--We need to prove (Eq (D [])). Here's how we go:--   [W] d1 : Eq (D [])-By instance decl of Eq (D r):-   [W] d2 : Eq [D []]      where   d1 = dfEqD d2-By instance decl of Eq [a]:-   [W] d3 : Eq (D [])      where   d2 = dfEqList d3-                                   d1 = dfEqD d2-Now this wanted can interact with our "solved" d1 to get:-    d3 = d1---- Example 2:-This code arises in the context of "Scrap Your Boilerplate with Class"--    class Sat a-    class Data ctx a-    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1-    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2--    class Data Maybe a => Foo a--    instance Foo t => Sat (Maybe t)                             -- dfunSat--    instance Data Maybe a => Foo a                              -- dfunFoo1-    instance Foo a        => Foo [a]                            -- dfunFoo2-    instance                 Foo [Char]                         -- dfunFoo3--Consider generating the superclasses of the instance declaration-         instance Foo a => Foo [a]--So our problem is this-    [G] d0 : Foo t-    [W] d1 : Data Maybe [t]   -- Desired superclass--We may add the given in the inert set, along with its superclasses-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  WorkList-    [W] d1 : Data Maybe [t]--Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-  WorkList:-    [W] d2 : Sat (Maybe [t])-    [W] d3 : Data Maybe t--Now, we may simplify d2 using dfunSat; d2 := dfunSat d4-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList:-    [W] d3 : Data Maybe t-    [W] d4 : Foo [t]--Now, we can just solve d3 from d01; d3 := d01-  Inert-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList-    [W] d4 : Foo [t]--Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5-  Inert-    [G] d0  : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-        d4 : Foo [t]-  WorkList:-    [W] d5 : Foo t--Now, d5 can be solved! d5 := d0--Result-   d1 := dfunData2 d2 d3-   d2 := dfunSat d4-   d3 := d01-   d4 := dfunFoo2 d5-   d5 := d0--}--{- *********************************************************************-*                                                                      *-                InertCans: the canonical inerts-*                                                                      *-*                                                                      *-********************************************************************* -}--{- Note [Tracking Given equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify-Note [Unification preconditions], we can't unify-   alpha[2] ~ Int-under a level-4 implication if there are any Given equalities-bound by the implications at level 3 of 4.  To that end, the-InertCans tracks--  inert_given_eq_lvl :: TcLevel-     -- The TcLevel of the innermost implication that has a Given-     -- equality of the sort that make a unification variable untouchable-     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).--We update inert_given_eq_lvl whenever we add a Given to the-inert set, in updateGivenEqs.--Then a unification variable alpha[n] is untouchable iff-    n < inert_given_eq_lvl-that is, if the unification variable was born outside an-enclosing Given equality.--Exactly which constraints should trigger (UNTOUCHABLE), and hence-should update inert_given_eq_lvl?--* We do /not/ need to worry about let-bound skolems, such ast-     forall[2] a. a ~ [b] => blah-  See Note [Let-bound skolems]--* Consider an implication-      forall[2]. beta[1] => alpha[1] ~ Int-  where beta is a unification variable that has already been unified-  to () in an outer scope.  Then alpha[1] is perfectly touchable and-  we can unify alpha := Int. So when deciding whether the givens contain-  an equality, we should canonicalise first, rather than just looking at-  the /original/ givens (#8644).-- * However, we must take account of *potential* equalities. Consider the-   same example again, but this time we have /not/ yet unified beta:-      forall[2] beta[1] => ...blah...--   Because beta might turn into an equality, updateGivenEqs conservatively-   treats it as a potential equality, and updates inert_give_eq_lvl-- * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?--   That Given cannot affect the Wanted, because the Given is entirely-   *local*: it mentions only skolems bound in the very same-   implication. Such equalities need not make alpha untouchable. (Test-   case typecheck/should_compile/LocalGivenEqs has a real-life-   motivating example, with some detailed commentary.)-   Hence the 'mentionsOuterVar' test in updateGivenEqs.--   However, solely to support better error messages-   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track-   these "local" equalities in the boolean inert_given_eqs field.-   This field is used only to set the ic_given_eqs field to LocalGivenEqs;-   see the function getHasGivenEqs.--   Here is a simpler case that triggers this behaviour:--     data T where-       MkT :: F a ~ G b => a -> b -> T--     f (MkT _ _) = True--   Because of this behaviour around local equality givens, we can infer the-   type of f. This is typecheck/should_compile/LocalGivenEqs2.-- * We need not look at the equality relation involved (nominal vs-   representational), because representational equalities can still-   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.--Note [Let-bound skolems]-~~~~~~~~~~~~~~~~~~~~~~~~-If   * the inert set contains a canonical Given CEqCan (a ~ ty)-and  * 'a' is a skolem bound in this very implication,--then:-a) The Given is pretty much a let-binding, like-      f :: (a ~ b->c) => a -> a-   Here the equality constraint is like saying-      let a = b->c in ...-   It is not adding any new, local equality  information,-   and hence can be ignored by has_given_eqs--b) 'a' will have been completely substituted out in the inert set,-   so we can safely discard it.--For an example, see #9211.--See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure-that the right variable is on the left of the equality when both are-tyvars.--You might wonder whether the skolem really needs to be bound "in the-very same implication" as the equality constraint.-Consider this (c.f. #15009):--  data S a where-    MkS :: (a ~ Int) => S a--  g :: forall a. S a -> a -> blah-  g x y = let h = \z. ( z :: Int-                      , case x of-                           MkS -> [y,z])-          in ...--From the type signature for `g`, we get `y::a` .  Then when we-encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the-body of the lambda we'll get--  [W] alpha[1] ~ Int                             -- From z::Int-  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]--Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!-So we must treat alpha as untouchable under the forall[2] implication.--Note [Detailed InertCans Invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The InertCans represents a collection of constraints with the following properties:--  * All canonical--  * No two dictionaries with the same head-  * No two CIrreds with the same type--  * Family equations inert wrt top-level family axioms--  * Dictionaries have no matching top-level instance--  * Given family or dictionary constraints don't mention touchable-    unification variables--  * Non-CEqCan constraints are fully rewritten with respect-    to the CEqCan equalities (modulo eqCanRewrite of course;-    eg a wanted cannot rewrite a given)--  * CEqCan equalities: see Note [inert_eqs: the inert equalities]-    Also see documentation in Constraint.Ct for a list of invariants--Note [inert_eqs: the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Definition [Can-rewrite relation]-A "can-rewrite" relation between flavours, written f1 >= f2, is a-binary relation with the following properties--  (R1) >= is transitive-  (R2) If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1-  (See Note [Why R2?].)--Lemma (L0). If f1 >= f then f1 >= f1-Proof.      By property (R2), with f1=f2--Definition [Generalised substitution]-A "generalised substitution" S is a set of triples (lhs -f-> t), where-  lhs is a type variable or an exactly-saturated type family application-    (that is, lhs is a CanEqLHS)-  t is a type-  f is a flavour-such that-  (WF1) if (lhs1 -f1-> t1) in S-           (lhs2 -f2-> t2) in S-        then (f1 >= f2) implies that lhs1 does not appear within lhs2-  (WF2) if (lhs -f-> t) is in S, then t /= lhs--Definition [Applying a generalised substitution]-If S is a generalised substitution-   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f-           = apply S to components of t0, otherwise-See also Note [Flavours with roles].--Theorem: S(f,t0) is well defined as a function.-Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,-               and  f1 >= f and f2 >= f-       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)--Notation: repeated application.-  S^0(f,t)     = t-  S^(n+1)(f,t) = S(f, S^n(t))--Definition: terminating generalised substitution-A generalised substitution S is *terminating* iff--  (IG1) there is an n such that-        for every f,t, S^n(f,t) = S^(n+1)(f,t)--By (IG1) we define S*(f,t) to be the result of exahaustively-applying S(f,_) to t.--------------------------------------------------------------------------------Our main invariant:-   the CEqCans in inert_eqs should be a terminating generalised substitution--------------------------------------------------------------------------------Note that termination is not the same as idempotence.  To apply S to a-type, you may have to apply it recursively.  But termination does-guarantee that this recursive use will terminate.--Note [Why R2?]-~~~~~~~~~~~~~~-R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=-f1. If we do not have R2, we will easily fall into a loop.--To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our-inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And-yet, we have a hard time noticing an occurs-check problem when building S, as-the two equalities cannot rewrite one another.--R2 actually restricts our ability to accept user-written programs. See-Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example.--Note [Rewritable]-~~~~~~~~~~~~~~~~~-This Note defines what it means for a type variable or type family application-(that is, a CanEqLHS) to be rewritable in a type. This definition is used-by the anyRewritableXXX family of functions and is meant to model the actual-behaviour in GHC.Tc.Solver.Rewrite.--Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the-lhs tree appears as a subtree within t without traversing any of the following-components of t:-  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)-  * kinds of variable occurrences-The check for rewritability *does* look in kinds of the bound variable of a-ForAllTy.--Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised-substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f-for all f.--The reason for this definition is that the rewriter does not rewrite in coercions-or variables' kinds. In turn, the rewriter does not need to rewrite there because-those places are never used for controlling the behaviour of the solver: these-places are not used in matching instances or in decomposing equalities.--There is one exception to the claim that non-rewritable parts of the tree do-not affect the solver: we sometimes do an occurs-check to decide e.g. how to-orient an equality. (See the comments on-GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a-variable in a kind or coercion just might influence the solver. Here is an-example:--  type family Const x y where-    Const x y = x--  AxConst :: forall x y. Const x y ~# x--  alpha :: Const Type Nat-  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;-                      AxConst Type alpha ;;-                      sym (AxConst Type Nat))--The cast is clearly ludicrous (it ties together a cast and its symmetric version),-but we can't quite rule it out. (See (EQ1) from-Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need-the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha-from unifying with the RHS. I (Richard E) don't have an example of where this-problem can arise from a Haskell program, but we don't have an air-tight argument-for why the definition of *rewritable* given here is correct.--Taking roles into account: we must consider a rewrite at a given role. That is,-a rewrite arises from some equality, and that equality has a role associated-with it. As we traverse a type, we track what role we are allowed to rewrite with.--For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in-Maybe b but not in F b, where F is a type function. This role-aware logic is-present in both the anyRewritableXXX functions and in the rewriter.-See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.--Note [Extending the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Main Theorem [Stability under extension]-   Suppose we have a "work item"-       lhs -fw-> t-   and a terminating generalised substitution S,-   THEN the extended substitution T = S+(lhs -fw-> t)-        is a terminating generalised substitution-   PROVIDED-      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)-      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)-      (T3) lhs not in t      -- No occurs check in the work item-          -- If lhs is a type family application, we require only that-          -- lhs is not *rewritable* in t. See Note [Rewritable] and-          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--      AND, for every (lhs1 -fs-> s) in S:-           (K0) not (fw >= fs)-                Reason: suppose we kick out (lhs1 -fs-> s),-                        and add (lhs -fw-> t) to the inert set.-                        The latter can't rewrite the former,-                        so the kick-out achieved nothing--              -- From here, we can assume fw >= fs-           OR (K4) lhs1 is a tyvar AND fs >= fw--           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].-                     Reason: if fw >= fs, WF1 says we can't have both-                             lhs0 -fw-> t  and  F lhs0 -fs-> s--                AND (K2): guarantees termination of the new substitution-                    {  (K2a) not (fs >= fs)-                    OR (K2b) lhs not in s }--                AND (K3) See Note [K3: completeness of solving]-                    { (K3a) If the role of fs is nominal: s /= lhs-                      (K3b) If the role of fs is representational:-                            s is not of form (lhs t1 .. tn) } }---Conditions (T1-T3) are established by the canonicaliser-Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable--The idea is that-* T1 and T2 are guaranteed by exhaustively rewriting the work-item-  with S(fw,_).--* T3 is guaranteed by an occurs-check on the work item.-  This is done during canonicalisation, in checkTypeEq; invariant-  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--* (K1-3) are the "kick-out" criteria.  (As stated, they are really the-  "keep" criteria.) If the current inert S contains a triple that does-  not satisfy (K1-3), then we remove it from S by "kicking it out",-  and re-processing it.--* Note that kicking out is a Bad Thing, because it means we have to-  re-process a constraint.  The less we kick out, the better.-  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed-  this but haven't done the empirical study to check.--* Assume we have  G>=G, G>=W and that's all.  Then, when performing-  a unification we add a new given  a -G-> ty.  But doing so does NOT require-  us to kick out an inert wanted that mentions a, because of (K2a).  This-  is a common case, hence good not to kick out. See also (K2a) below.--* Lemma (L1): The conditions of the Main Theorem imply that there is no-              (lhs -fs-> t) in S, s.t.  (fs >= fw).-  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),-  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we-  have (lhs -fs-> lhs) in S, which contradicts (WF2).--* The extended substitution satisfies (WF1) and (WF2)-  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).-  - (T3) guarantees (WF2).--* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),-  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely-  often, since the substitution without the work item is terminating; and must-  pass through at least one of the triples in S infinitely often.--  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)-    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).-    It is always safe to extend S with such a triple.--    (NB: we could strengthen K1) in this way too, but see K3.--  - (K2b): if lhs not in s, we have no further opportunity to apply the-    work item--  - (K4): See Note [K4]--* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then-  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.-  Proof. K4 holds; thus, we keep.--Key lemma to make it watertight.-  Under the conditions of the Main Theorem,-  forall f st fw >= f, a is not in S^k(f,t), for any k--Also, consider roles more carefully. See Note [Flavours with roles]--Note [K4]-~~~~~~~~~-K4 is a "keep" condition of Note [Extending the inert equalities].-Here is the scenario:--* We are considering adding (lhs -fw-> t) to the inert set S.-* S already has (lhs1 -fs-> s).-* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.-  See Note [Rewritable]. These are (T1), (T2), and (T3).-* We further know fw >= fs. (If not, then we short-circuit via (K0).)--K4 says that we may keep lhs1 -fs-> s in S if:-  lhs1 is a tyvar AND fs >= fw--Why K4 guarantees termination:-  * If fs >= fw, we know a is not rewritable in t, because of (T2).-  * We further know lhs /= a, because of (T1).-  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions-    for a use of a -fs-> s (precisely because t does not mention a), and hence,-    the extended substitution (with lhs -fw-> t in it) is a terminating-    generalised substitution.--Recall that the termination generalised substitution includes only mappings that-pass an occurs check. This is (T3). At one point, we worried that the-argument here would fail if s mentioned a, but (T3) rules out this possibility.-Put another way: the terminating generalised substitution considers only the inert_eqs,-not other parts of the inert set (such as the irreds).--Can we liberalise K4? No.--Why we cannot drop the (fs >= fw) condition:-  * Suppose not (fs >= fw). It might be the case that t mentions a, and this-    can cause a loop. Example:--      Work:  [G] b ~ a-      Inert: [W] a ~ b--    (where G >= G, G >= W, and W >= W)-    If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int.--  * Note that the above example is different if the inert is a Given G, because-    (T1) won't hold.--Why we cannot drop the tyvar condition:-  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).-  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?-    Yes! This can happen if t appears within tys.--    Here is an example:--      Work:  [G] a ~ Int-      Inert: [G] F Int ~ F a--    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand-    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:-    if the right-hand side of an equality does not mention a variable a, then it-    cannot allow an equality with an LHS of a to fire. This is not the case for-    type family applications.--Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,-K4 will never prevent an inert with a type family on the left from being kicked-out.--Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.-This is Lemma (L3) of Note [Extending the inert equalities]. It is good because-it means we can effectively model the mutable filling of metavariables with-Given/Nominal equalities. That is: it should be the case that we could rewrite-our solver never to fill in a metavariable; instead, it would "solve" a wanted-like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.-We would want the solver to behave the same whether it uses metavariables or-Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,-just like we never unfill a metavariable. Nice.--Getting this wrong (that is, allowing K4 to apply to situations with the type-family on the left) led to #19042. (At that point, K4 was known as K2b.)--Originally, this condition was part of K2, but #17672 suggests it should be-a top-level K condition.--Note [K3: completeness of solving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(K3) is not necessary for the extended substitution-to be terminating.  In fact K1 could be made stronger by saying-   ... then (not (fw >= fs) or not (fs >= fs))-But it's not enough for S to be terminating; we also want completeness.-That is, we want to be able to solve all soluble wanted equalities.-Suppose we have--   work-item   b -G-> a-   inert-item  a -W-> b--Assuming (G >= W) but not (W >= W), this fulfills all the conditions,-so we could extend the inerts, thus:--   inert-items   b -G-> a-                 a -W-> b--But if we kicked-out the inert item, we'd get--   work-item     a -W-> b-   inert-item    b -G-> a--Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.-So we add one more clause to the kick-out criteria--Another way to understand (K3) is that we treat an inert item-        a -f-> b-in the same way as-        b -f-> a-So if we kick out one, we should kick out the other.  The orientation-is somewhat accidental.--When considering roles, we also need the second clause (K3b). Consider--  work-item    c -G/N-> a-  inert-item   a -W/R-> b c--The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.-But we don't kick out the inert item because not (W/R >= W/R).  So we just-add the work item. But then, consider if we hit the following:--  work-item    b -G/N-> Id-  inert-items  a -W/R-> b c-               c -G/N-> a-where-  newtype Id x = Id x--For similar reasons, if we only had (K3a), we wouldn't kick the-representational inert out. And then, we'd miss solving the inert, which-now reduced to reflexivity.--The solution here is to kick out representational inerts whenever the-lhs of a work item is "exposed", where exposed means being at the-head of the top-level application chain (lhs t1 .. tn).  See-is_can_eq_lhs_head. This is encoded in (K3b).--Beware: if we make this test succeed too often, we kick out too much,-and the solver might loop.  Consider (#14363)-  work item:   [G] a ~R f b-  inert item:  [G] b ~R f a-In GHC 8.2 the completeness tests more aggressive, and kicked out-the inert item; but no rewriting happened and there was an infinite-loop.  All we need is to have the tyvar at the head.--Note [Flavours with roles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The system described in Note [inert_eqs: the inert equalities]-discusses an abstract-set of flavours. In GHC, flavours have two components: the flavour proper,-taken from {Wanted, Given} and the equality relation (often called-role), taken from {NomEq, ReprEq}.-When substituting w.r.t. the inert set,-as described in Note [inert_eqs: the inert equalities],-we must be careful to respect all components of a flavour.-For example, if we have--  inert set: a -G/R-> Int-             b -G/R-> Bool--  type role T nominal representational--and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT-T Int Bool. The reason is that T's first parameter has a nominal role, and-thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of-substitution means that the proof in Note [inert_eqs: the inert equalities] may-need to be revisited, but we don't think that the end conclusion is wrong.--}--data InertCans   -- See Note [Detailed InertCans Invariants] for more-  = IC { inert_eqs :: InertEqs-              -- See Note [inert_eqs: the inert equalities]-              -- All CEqCans with a TyVarLHS; index is the LHS tyvar-              -- Domain = skolems and untouchables; a touchable would be unified--       , inert_funeqs :: FunEqMap EqualCtList-              -- All CEqCans with a TyFamLHS; index is the whole family head type.-              -- LHS is fully rewritten (modulo eqCanRewrite constraints)-              --     wrt inert_eqs-              -- Can include both [G] and [W]--       , inert_dicts :: DictMap Ct-              -- Dictionaries only-              -- All fully rewritten (modulo flavour constraints)-              --     wrt inert_eqs--       , inert_insts :: [QCInst]--       , inert_safehask :: DictMap Ct-              -- 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_irreds :: Cts-              -- Irreducible predicates that cannot be made canonical,-              --     and which don't interact with others (e.g.  (c a))-              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])--       , inert_given_eq_lvl :: TcLevel-              -- The TcLevel of the innermost implication that has a Given-              -- equality of the sort that make a unification variable untouchable-              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).-              -- See Note [Tracking Given equalities]--       , inert_given_eqs :: Bool-              -- True <=> The inert Givens *at this level* (tcl_tclvl)-              --          could includes at least one equality /other than/ a-              --          let-bound skolem equality.-              -- Reason: report these givens when reporting a failed equality-              -- See Note [Tracking Given equalities]-       }--type InertEqs    = DTyVarEnv EqualCtList--instance Outputable InertCans where-  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 })--    = braces $ vcat-      [ ppUnless (isEmptyDVarEnv eqs) $-        text "Equalities:"-          <+> pprCts (foldDVarEnv folder emptyCts eqs)-      , ppUnless (isEmptyTcAppMap funeqs) $-        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)-      , ppUnless (isEmptyTcAppMap dicts) $-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)-      , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)-      , ppUnless (isEmptyCts irreds) $-        text "Irreds =" <+> pprCts irreds-      , ppUnless (null insts) $-        text "Given instances =" <+> vcat (map ppr insts)-      , text "Innermost given equalities =" <+> ppr ge_lvl-      , text "Given eqs at this level =" <+> ppr given_eqs-      ]-    where-      folder eqs rest = listToBag eqs `andCts` rest--{- *********************************************************************-*                                                                      *-                   Inert equalities-*                                                                      *-********************************************************************* -}--addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs-addTyEq old_eqs tv ct-  = extendDVarEnv_C add_eq old_eqs tv [ct]-  where-    add_eq old_eqs _ = addToEqualCtList ct old_eqs--addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct-            -> FunEqMap EqualCtList-addCanFunEq old_eqs fun_tc fun_args ct-  = alterTcApp old_eqs fun_tc fun_args upd-  where-    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list-    upd Nothing                  = Just [ct]--foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b-foldTyEqs k eqs z-  = foldDVarEnv (\cts z -> foldr k z cts) z eqs--findTyEqs :: InertCans -> TyVar -> [Ct]-findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv)--delEq :: InertCans -> CanEqLHS -> TcType -> InertCans-delEq ic lhs rhs = case lhs of-    TyVarLHS tv-      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }-    TyFamLHS tf args-      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }-  where-    isThisOne :: Ct -> Bool-    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1-    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)--    upd :: Maybe EqualCtList -> Maybe EqualCtList-    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list-    upd Nothing           = Nothing--findEq :: InertCans -> CanEqLHS -> [Ct]-findEq icans (TyVarLHS tv) = findTyEqs icans tv-findEq icans (TyFamLHS fun_tc fun_args)-  = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args)--{-# INLINE partition_eqs_container #-}-partition_eqs_container-  :: forall container-   . container    -- empty container-  -> (forall b. (EqualCtList -> b -> b) -> b -> container -> b) -- folder-  -> (container -> CanEqLHS -> EqualCtList -> container)  -- extender-  -> (Ct -> Bool)-  -> container-  -> ([Ct], container)-partition_eqs_container empty_container fold_container extend_container pred orig_inerts-  = fold_container folder ([], empty_container) orig_inerts-  where-    folder :: EqualCtList -> ([Ct], container) -> ([Ct], container)-    folder eqs (acc_true, acc_false)-      = (eqs_true ++ acc_true, acc_false')-      where-        (eqs_true, eqs_false) = partition pred eqs--        acc_false'-          | CEqCan { cc_lhs = lhs } : _ <- eqs_false-          = extend_container acc_false lhs eqs_false-          | otherwise-          = acc_false--partitionInertEqs :: (Ct -> Bool)   -- Ct will always be a CEqCan with a TyVarLHS-                  -> InertEqs-                  -> ([Ct], InertEqs)-partitionInertEqs = partition_eqs_container emptyDVarEnv foldDVarEnv extendInertEqs---- precondition: CanEqLHS is a TyVarLHS-extendInertEqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs-extendInertEqs eqs (TyVarLHS tv) new_eqs = extendDVarEnv eqs tv new_eqs-extendInertEqs _ other _ = pprPanic "extendInertEqs" (ppr other)--partitionFunEqs :: (Ct -> Bool)    -- Ct will always be a CEqCan with a TyFamLHS-                -> FunEqMap EqualCtList-                -> ([Ct], FunEqMap EqualCtList)-partitionFunEqs-  = partition_eqs_container emptyFunEqs (\ f z eqs -> foldFunEqs f eqs z) extendFunEqs---- precondition: CanEqLHS is a TyFamLHS-extendFunEqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList -> FunEqMap EqualCtList-extendFunEqs eqs (TyFamLHS tf args) new_eqs = insertTcApp eqs tf args new_eqs-extendFunEqs _ other _ = pprPanic "extendFunEqs" (ppr other)--{- *********************************************************************-*                                                                      *-                Adding to and removing from the inert set-*                                                                      *-*                                                                      *-********************************************************************* -}--addInertItem :: TcLevel -> InertCans -> Ct -> InertCans-addInertItem tc_lvl-             ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })-             item@(CEqCan { cc_lhs = lhs })-  = updateGivenEqs tc_lvl item $-    case lhs of-       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }-       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }--addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})-  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an-                                 -- equality, so we play safe-    ics { inert_irreds = irreds `snocBag` item }--addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item }--addInertItem _ _ item-  = pprPanic "upd_inert set: can't happen! Inserting " $-    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds--updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans--- Set the inert_given_eq_level to the current level (tclvl)--- if the constraint is a given equality that should prevent--- filling in an outer unification variable.--- See Note [Tracking Given equalities]-updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })-  | not (isGivenCt ct) = inerts-  | not_equality ct    = inerts -- See Note [Let-bound skolems]-  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'-                                , inert_given_eqs    = True }-  where-    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)-              -- Includes things like (c a), which *might* be an equality-            = tclvl-            | otherwise-            = ge_lvl--    not_equality :: Ct -> Bool-    -- True <=> definitely not an equality of any kind-    --          except for a let-bound skolem, which doesn't count-    --          See Note [Let-bound skolems]-    -- NB: no need to spot the boxed CDictCan (a ~ b) because its-    --     superclass (a ~# b) will be a CEqCan-    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)-    not_equality (CDictCan {})                     = True-    not_equality _                                 = False--kickOutRewritableLHS :: CtFlavourRole  -- Flavour/role of the equality that-                                       -- is being added to the inert set-                     -> CanEqLHS       -- The new equality is lhs ~ ty-                     -> InertCans-                     -> (WorkList, InertCans)--- See Note [kickOutRewritable]-kickOutRewritableLHS new_fr new_lhs-                     ics@(IC { inert_eqs      = tv_eqs-                             , inert_dicts    = dictmap-                             , inert_funeqs   = funeqmap-                             , inert_irreds   = irreds-                             , inert_insts    = 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 }--    kicked_out :: WorkList-    -- NB: use extendWorkList to ensure that kicked-out equalities get priority-    -- See Note [Prioritise equalities] (Kick-out).-    -- The irreds may include non-canonical (hetero-kinded) equality-    -- constraints, which perhaps may have become soluble after new_lhs-    -- is substituted; ditto the dictionaries, which may include (a~b)-    -- or (a~~b) constraints.-    kicked_out = foldr extendWorkListCt-                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })-                          ((dicts_out `andCts` irs_out)-                            `extendCtsList` insts_out)--    (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs-    (feqs_out,   feqs_in)   = partitionFunEqs   kick_out_eq funeqmap-    (dicts_out,  dicts_in)  = partitionDicts    kick_out_ct dictmap-    (irs_out,    irs_in)    = partitionBag      kick_out_ct irreds-      -- Kick out even insolubles: See Note [Rewrite insolubles]-      -- Of course we must kick out irreducibles like (c a), in case-      -- we can rewrite 'c' to something more useful--    -- Kick-out for inert instances-    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-    insts_out :: [Ct]-    insts_in  :: [QCInst]-    (insts_out, insts_in)-       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens-       = partitionWith kick_out_qci old_insts-       | otherwise-       = ([], old_insts)-    kick_out_qci qci-      | let ev = qci_ev qci-      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))-      = Left (mkNonCanonical ev)-      | otherwise-      = Right qci--    (_, new_role) = new_fr--    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool-    fr_tv_can_rewrite_ty new_tv role ty-      = anyRewritableTyVar role can_rewrite ty-      where-        can_rewrite :: EqRel -> TyVar -> Bool-        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv--    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool-    fr_tf_can_rewrite_ty new_tf new_tf_args role ty-      = anyRewritableTyFamApp role can_rewrite ty-      where-        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool-        can_rewrite old_role old_tf old_tf_args-          = new_role `eqCanRewrite` old_role &&-            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args-              -- it's possible for old_tf_args to have too many. This is fine;-              -- we'll only check what we need to.--    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once-    fr_can_rewrite_ty :: EqRel -> Type -> Bool-    fr_can_rewrite_ty = case new_lhs of-      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv-      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args--    fr_may_rewrite :: CtFlavourRole -> Bool-    fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs-        -- Can the new item rewrite the inert item?--    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once-    kick_out_ct :: Ct -> Bool-    -- Kick it out if the new CEqCan can rewrite the inert one-    -- See Note [kickOutRewritable]-    kick_out_ct = case new_lhs of-      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in-                                fr_may_rewrite fs-                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)-      TyFamLHS new_tf new_tf_args-        -> \ct -> let fs@(_, role) = ctFlavourRole ct in-                  fr_may_rewrite fs-               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)--    -- Implements criteria K1-K3 in Note [Extending the inert equalities]-    kick_out_eq :: Ct -> Bool-    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty-                        , cc_ev = ev, cc_eq_rel = eq_rel })-      | not (fr_may_rewrite fs)-      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it--      -- Below here (fr_may_rewrite fs) is True--      | TyVarLHS _ <- lhs-      , fs `eqCanRewriteFR` new_fr-      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and-               -- it can rewrite the work item. See Note [K4]--      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)-      = True   -- (K1)-         -- The above check redundantly checks the role & flavour,-         -- but it's very convenient--      | kick_out_for_inertness    = True   -- (K2)-      | kick_out_for_completeness = True   -- (K3)-      | otherwise                 = False--      where-        fs = (ctEvFlavour ev, eq_rel)-        kick_out_for_inertness-          =    (fs `eqCanRewriteFR` fs)           -- (K2a)-            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)--        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]-          = case eq_rel of-              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)-              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)--    kick_out_eq ct = pprPanic "kick_out_eq" (ppr ct)--    is_can_eq_lhs_head (TyVarLHS tv) = go-      where-        go (Rep.TyVarTy tv')   = tv == tv'-        go (Rep.AppTy fun _)   = go fun-        go (Rep.CastTy ty _)   = go ty-        go (Rep.TyConApp {})   = False-        go (Rep.LitTy {})      = False-        go (Rep.ForAllTy {})   = False-        go (Rep.FunTy {})      = False-        go (Rep.CoercionTy {}) = False-    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go-      where-        go (Rep.TyVarTy {})       = False-        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy-        go (Rep.CastTy ty _)      = go ty-        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args-        go (Rep.LitTy {})         = False-        go (Rep.ForAllTy {})      = False-        go (Rep.FunTy {})         = False-        go (Rep.CoercionTy {})    = False--{- Note [kickOutRewritable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [inert_eqs: the inert equalities].--When we add a new inert equality (lhs ~N ty) to the inert set,-we must kick out any inert items that could be rewritten by the-new equality, to maintain the inert-set invariants.--  - We want to kick out an existing inert constraint if-    a) the new constraint can rewrite the inert one-    b) 'lhs' is free in the inert constraint (so that it *will*)-       rewrite it if we kick it out.--    For (b) we use anyRewritableCanLHS, which examines the types /and-    kinds/ that are directly visible in the type. Hence-    we will have exposed all the rewriting we care about to make the-    most precise kinds visible for matching classes etc. No need to-    kick out constraints that mention type variables whose kinds-    contain this LHS!--  - We don't kick out constraints from inert_solved_dicts, and-    inert_solved_funeqs optimistically. But when we lookup we have to-    take the substitution into account--NB: we could in principle avoid kick-out:-  a) When unifying a meta-tyvar from an outer level, because-     then the entire implication will be iterated; see-     Note [The Unification Level Flag] in GHC.Tc.Solver.Monad.--  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType-     Note [TcLevel invariants], a Given can't include a meta-tyvar from-     its own level, so it falls under (a).  Of course, we must still-     kick out Givens when adding a new non-unification Given.--But kicking out more vigorously may lead to earlier unification and fewer-iterations, so we don't take advantage of these possibilities.--Note [Rewrite insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an insoluble alpha ~ [alpha], which is insoluble-because an occurs check.  And then we unify alpha := [Int].  Then we-really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can-be decomposed.  Otherwise we end up with a "Can't match [Int] ~-[[Int]]" which is true, but a bit confusing because the outer type-constructors match.--Hence:- * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,-   simpl_loop), we feed the insolubles in solveSimpleWanteds,-   so that they get rewritten (albeit not solved).-- * We kick insolubles out of the inert set, if they can be-   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)-- * We rewrite those insolubles in GHC.Tc.Solver.Canonical.-   See Note [Make sure that insolubles are fully rewritten]-   in GHC.Tc.Solver.Canonical.--}--{- *********************************************************************-*                                                                      *-                 Queries-*                                                                      *-*                                                                      *-********************************************************************* -}--mentionsOuterVar :: TcLevel -> CtEvidence -> Bool-mentionsOuterVar tclvl ev-  = anyFreeVarsOfType (isOuterTyVar tclvl) $-    ctEvPred ev--isOuterTyVar :: TcLevel -> TyCoVar -> Bool--- True of a type variable that comes from a--- shallower level than the ambient level (tclvl)-isOuterTyVar tclvl tv-  | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $-                 tclvl `strictlyDeeperThan` tcTyVarLevel tv-    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from-    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't-    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,-    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby-    -- becomes "outer" even though its level numbers says it isn't.-  | 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.Canonical---     This is the only call site.-noGivenNewtypeReprEqs tc inerts-  = not (anyBag might_help (inert_irreds (inert_cans inerts)))-  where-    might_help ct-      = case classifyPredType (ctPred ct) 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 consraint. 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.Interact"-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-  where-    pred_w = mkClassPred clas tys--    matchable_given :: Ct -> Bool-    matchable_given ct-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct-      = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w--      | 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.Interact-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--      | otherwise-      = Apart--    -- 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-      | otherwise-      = False--    -- like startSolvingByUnification, 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@:------   - @ct1@ and @ct2@ both arise from superclass expansion,---   - @ct1@ is a Given and @ct2@ is a Wanted.------ See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2).-prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ...-                          -> CtLoc -- ^ ... to solve this one?-                          -> Bool  -- ^ True ==> don't solve it-prohibitedSuperClassSolve given_loc wanted_loc-  | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc-  , blocked-  , ScOrigin _ NakedSc <- ctLocOrigin wanted_loc-  = True    -- Prohibited if the Wanted is a superclass-            -- and the Given has come via a superclass selection from-            -- a predicate bigger than the head-  | 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.Canonical.-   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 (lookup 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-pushCycleBreakerVarStack = ([] <|)---- | Add a new cycle-breaker binding to the top environment on the stack.-insertCycleBreakerBinding :: TcTyVar   -- ^ cbv, must be a CycleBreakerTv-                          -> TcType    -- ^ cbv's expansion-                          -> CycleBreakerVarStack -> CycleBreakerVarStack-insertCycleBreakerBinding cbv expansion (top_env :| rest_envs)-  = assert (isCycleBreakerTyVar cbv) $-    ((cbv, expansion) : top_env) :| rest_envs---- | Perform a monadic operation on all pairs in the top environment--- in the stack.-forAllCycleBreakerBindings_ :: Monad m-                            => CycleBreakerVarStack-                            -> (TcTyVar -> TcType -> m ()) -> m ()-forAllCycleBreakerBindings_ (top_env :| _rest_envs) action-  = forM_ top_env (uncurry action)-{-# INLINABLE forAllCycleBreakerBindings_ #-}  -- to allow SPECIALISE later+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module GHC.Tc.Solver.InertSet (+    -- * The work list+    WorkList(..), isEmptyWorkList, emptyWorkList,+    extendWorkListNonEq, extendWorkListCt,+    extendWorkListCts, extendWorkListCtList,+    extendWorkListEq, extendWorkListChildEqs,+    extendWorkListRewrittenEqs,+    appendWorkList,+    workListSize,++    -- * The inert set+    InertSet(..),+    InertCans(..),+    emptyInertSet, emptyInertCans,++    noGivenNewtypeReprEqs, updGivenEqs,+    prohibitedSuperClassSolve,++    -- * Inert equalities+    InertEqs,+    foldTyEqs, delEq, findEq,+    partitionInertEqs, partitionFunEqs,+    filterInertEqs, filterFunEqs,+    foldFunEqs, addEqToCans,++    -- * Inert Dicts+    updDicts, delDict, addDict, filterDicts, partitionDicts,+    addSolvedDict, lookupSolvedDict, lookupInertDict,++    -- * Inert Irreds+    InertIrreds, delIrred, addIrreds, addIrred, foldIrreds,+    findMatchingIrreds, updIrreds, addIrredToCans,++    -- * Kick-out+    KickOutSpec(..), kickOutRewritableLHS,++    -- * Cycle breaker vars+    CycleBreakerVarStack,+    pushCycleBreakerVarStack,+    addCycleBreakerBindings,+    forAllCycleBreakerBindings_,++    -- * Solving one from another+    InteractResult(..), solveOneFromTheOther++  ) where++import GHC.Prelude++import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, ctLocSpan, ctLocLevel )+import GHC.Tc.Solver.Types+import GHC.Tc.Utils.TcType++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 qualified GHC.Core.TyCo.Rep as Rep+import GHC.Core.TyCon+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.Bag++import Control.Monad      ( forM_ )+import Data.List.NonEmpty ( NonEmpty(..), (<|) )+import Data.Function      ( on )++{-+************************************************************************+*                                                                      *+*                            Worklists                                *+*  Canonical and non-canonical constraints that the simplifier has to  *+*  work on. Including their simplification depths.                     *+*                                                                      *+*                                                                      *+************************************************************************++Note [WorkList priorities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkList contains canonical and non-canonical items (of all flavours).+Notice that each Ct now has a simplification depth. We may+consider using this depth for prioritization as well in the future.++As a simple form of priority queue, our worklist separates out++* equalities (wl_eqs); see Note [Prioritise equalities]+* all the rest (wl_rest)++Note [Prioritise equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to process equalities over class constraints:++* (Efficiency)  The general reason to do so is that if we process a+  class constraint first, we may end up putting it into the inert set+  and then kicking it out later.  That's extra work compared to just+  doing the equality first.++* (Avoiding fundep iteration) As #14723 showed, it's possible to+  get non-termination if we+      - Emit the fundep equalities for a class constraint,+        generating some fresh unification variables.+      - That leads to some unification+      - Which kicks out the class constraint+      - Which isn't solved (because there are still some more+        equalities in the work-list), but generates yet more fundeps+  Solution: prioritise equalities over class constraints++* (Class equalities) We need to prioritise equalities even if they+  are hidden inside a class constraint; see Note [Prioritise class equalities]++* (Kick-out) We want to apply this priority scheme to kicked-out+  constraints too (see the call to extendWorkListCt in kick_out_rewritable)+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become+  homo-kinded when kicked out, and hence we want to prioritise it.++Further refinements:++* Among the equalities we prioritise ones with an empty rewriter set;+  see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint, wrinkle (W1).++* Among equalities with an empty rewriter set, we prioritise nominal equalities.+   * They have more rewriting power, so doing them first is better.+   * Prioritising them ameliorates the incompleteness of newtype+     solving: see (Ex2) in Note [Decomposing newtype equalities] in+     GHC.Tc.Solver.Equality.++Note [Prioritise class equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prioritise equalities in the solver (see selectWorkItem). But class+constraints like (a ~ b) and (a ~~ b) are actually equalities too;+see Note [The equality types story] in GHC.Builtin.Types.Prim.++Failing to prioritise these is inefficient (more kick-outs etc).+But, worse, it can prevent us spotting a "recursive knot" among+Wanted constraints.  See comment:10 of #12734 for a worked-out+example.++So we arrange to put these particular class constraints in the wl_eqs.++  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.+-}++-- See Note [WorkList priorities]+data WorkList+  = WL { wl_eqs_N :: [Ct]  -- /Nominal/ equalities (s ~#N t), (s ~ t), (s ~~ t)+                           -- with definitely-empty rewriter set++       , wl_eqs_X :: [Ct]  -- CEqCan, CDictCan, CIrredCan+                           -- 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 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]+    }++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 { 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 }++workListSize :: WorkList -> Int+workListSize (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs, wl_rest = rest })+  = length eqs_N + length eqs_X + length rw_eqs + length rest++extendWorkListEq :: RewriterSet -> Ct -> WorkList -> WorkList+extendWorkListEq rewriters ct+    wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs })+  | isEmptyRewriterSet rewriters      -- A wanted that has not been rewritten+    -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]+    --                         in GHC.Tc.Types.Constraint+  = 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 }++extendWorkListChildEqs :: CtEvidence -> Bag Ct -> WorkList -> WorkList+-- Add [eq1,...,eqn] to the work-list+-- 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+extendWorkListChildEqs parent_ev new_eqs+    wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs })+  | isEmptyRewriterSet (ctEvRewriters parent_ev)+    -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]+    --                         in GHC.Tc.Types.Constraint+    -- 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 }+          | otherwise            -> wl { wl_eqs_N = new_eqs_N `push_on_front` eqs_N+                                       , wl_eqs_X = new_eqs_X `push_on_front` eqs_X }+          -- These isEmptyBag tests are just trying+          -- to avoid creating unnecessary thunks++  | 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 equalities on the front of the queue+    push_on_front new_eqs eqs = foldr (:) eqs new_eqs++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 }++extendWorkListCt :: Ct -> WorkList -> WorkList+-- Agnostic about what kind of constraint+extendWorkListCt ct wl+ = case classifyPredType (ctEvPred ev) of+     EqPred {}+       -> extendWorkListEq rewriters ct wl++     ClassPred cls _  -- See Note [Prioritise class equalities]+       |  isEqualityClass cls+       -> extendWorkListEq rewriters ct wl++     _ -> extendWorkListNonEq ct wl+  where+    ev = ctEvidence ct+    rewriters = ctEvRewriters ev++extendWorkListCtList :: [Ct] -> WorkList -> WorkList+extendWorkListCtList cts wl = foldr extendWorkListCt wl cts++extendWorkListCts :: Cts -> WorkList -> WorkList+extendWorkListCts cts wl = foldr extendWorkListCt wl cts++isEmptyWorkList :: WorkList -> Bool+isEmptyWorkList (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X+                    , 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 = [] }++-- 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 })+   = text "WL" <+> (braces $+     vcat [ ppUnless (null eqs_N) $+            text "Eqs_N =" <+> vcat (map ppr eqs_N)+          , ppUnless (null eqs_X) $+            text "Eqs_X =" <+> vcat (map ppr eqs_X)+          , ppUnless (null rw_eqs) $+            text "RwEqs =" <+> vcat (map ppr rw_eqs)+          , ppUnless (null rest) $+            text "Non-eqs =" <+> vcat (map ppr rest)+          ])++{- *********************************************************************+*                                                                      *+                InertSet: the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++type CycleBreakerVarStack = NonEmpty (Bag (TcTyVar, TcType))+   -- ^ a stack of (CycleBreakerTv, original family applications) lists+   -- first element in the stack corresponds to current implication;+   --   later elements correspond to outer implications+   -- used to undo the cycle-breaking needed to handle+   -- Note [Type equality cycles] in GHC.Tc.Solver.Equality+   -- Why store the outer implications? For the use in mightEqualLater (only)+   --+   -- Why NonEmpty? So there is always a top element to add to++data InertSet+  = IS { inert_cans :: InertCans+              -- 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+              -- Just a hash-cons cache for use when reducing family applications+              -- only+              --+              -- If    F tys :-> (co, rhs, flav),+              -- then  co :: F tys ~N rhs+              -- all evidence is from instances or Givens; no coercion holes here+              -- (We have no way of "kicking out" from the cache, so putting+              --  wanteds here means we can end up solving a Wanted with itself. Bad)++       , inert_solved_dicts :: DictMap DictCt+              -- All Wanteds, of form (C t1 .. tn)+              -- 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)+             , ppUnless (isEmptyTcAppMap safehask) $+               text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask) ]+         where+           dicts = bagToList (dictsToBag solved_dicts)++emptyInertCans :: TcLevel -> InertCans+emptyInertCans given_eq_lvl+  = IC { inert_eqs          = emptyTyEqs+       , inert_funeqs       = emptyFunEqs+       , inert_given_eq_lvl = given_eq_lvl+       , inert_given_eqs    = False+       , inert_dicts        = emptyDictMap+       , inert_qcis         = []+       , inert_irreds       = emptyBag }++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_safehask       = emptyDictMap }+  where+    empty_cans = emptyInertCans given_eq_lvl++{- Note [Solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we apply a top-level instance declaration, we add the "solved"+dictionary to the inert_solved_dicts.  In general, we use it to avoid+creating a new EvVar when we have a new goal that we have solved in+the past.++But in particular, we can use it to create *recursive* dictionaries.+The simplest, degenerate case is+    instance C [a] => C [a] where ...+If we have+    [W] d1 :: C [x]+then we can apply the instance to get+    d1 = $dfCList d+    [W] d2 :: C [x]+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.+    d1 = $dfCList d+    d2 = d1++See Note [Example of recursive dictionaries]++VERY IMPORTANT INVARIANT:++ (Solved Dictionary Invariant)+    Every member of the inert_solved_dicts is the result+    of applying an instance declaration that "takes a step"++    An instance "takes a step" if it has the form+        dfunDList d1 d2 = MkD (...) (...) (...)+    That is, the dfun is lazy in its arguments, and guarantees to+    immediately return a dictionary constructor.  NB: all dictionary+    data constructors are lazy in their arguments.++    This property is crucial to ensure that all dictionaries are+    non-bottom, which in turn ensures that the whole "recursive+    dictionary" idea works at all, even if we get something like+        rec { d = dfunDList d dx }+    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.++ Reason:+   - All instances, except two exceptions listed below, "take a step"+     in the above sense++   - Exception 1: local quantified constraints have no such guarantee;+     indeed, adding a "solved dictionary" when applying a quantified+     constraint led to the ability to define unsafeCoerce+     in #17267.++   - Exception 2: the magic built-in instance for (~) has no+     such guarantee.  It behaves as if we had+         class    (a ~# b) => (a ~ b) where {}+         instance (a ~# b) => (a ~ b) where {}+     The "dfun" for the instance is strict in the coercion.+     Anyway there's no point in recording a "solved dict" for+     (t1 ~ t2); it's not going to allow a recursive dictionary+     to be constructed.  Ditto (~~) and Coercible.++THEREFORE we only add a "solved dictionary"+  - when applying an instance declaration+  - subject to Exceptions 1 and 2 above++In implementation terms+  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,+    conditional on the kind of instance++  - It is only called when applying an instance decl,+    in GHC.Tc.Solver.Dict.tryInstances++  - ClsInst.InstanceWhat says what kind of instance was+    used to solve the constraint.  In particular+      * LocalInstance identifies quantified constraints+      * BuiltinEqInstance identifies the strange built-in+        instances for equality.++  - ClsInst.instanceReturnsDictCon says which kind of+    instance guarantees to return a dictionary constructor++Other notes about solved dictionaries++* See also Note [Do not add superclasses of solved dictionaries]++* The inert_solved_dicts field is not rewritten by equalities,+  so it may get out of date.++* The inert_solved_dicts are all Wanteds, never givens++* We only cache dictionaries from top-level instances, not from+  local quantified constraints.  Reason: if we cached the latter+  we'd need to purge the cache when bringing new quantified+  constraints into scope, because quantified constraints "shadow"+  top-level instances.++Note [Do not add superclasses of solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every member of inert_solved_dicts is the result of applying a+dictionary function, NOT of applying superclass selection to anything.+Consider++        class Ord a => C a where+        instance Ord [a] => C [a] where ...++Suppose we are trying to solve+  [G] d1 : Ord a+  [W] d2 : C [a]++Then we'll use the instance decl to give++  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3+  [W] d3 : Ord [a]++We must not add d4 : Ord [a] to the 'solved' set (by taking the+superclass of d2), otherwise we'll use it to solve d3, without ever+using d1, which would be a catastrophe.++Solution: when extending the solved dictionaries, do not add superclasses.+That's why each element of the inert_solved_dicts is the result of applying+a dictionary function.++Note [Example of recursive dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--- Example 1++    data D r = ZeroD | SuccD (r (D r));++    instance (Eq (r (D r))) => Eq (D r) where+        ZeroD     == ZeroD     = True+        (SuccD a) == (SuccD b) = a == b+        _         == _         = False;++    equalDC :: D [] -> D [] -> Bool;+    equalDC = (==);++We need to prove (Eq (D [])). Here's how we go:++   [W] d1 : Eq (D [])+By instance decl of Eq (D r):+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2+By instance decl of Eq [a]:+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3+                                   d1 = dfEqD d2+Now this wanted can interact with our "solved" d1 to get:+    d3 = d1++-- Example 2:+This code arises in the context of "Scrap Your Boilerplate with Class"++    class Sat a+    class Data ctx a+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2++    class Data Maybe a => Foo a++    instance Foo t => Sat (Maybe t)                             -- dfunSat++    instance Data Maybe a => Foo a                              -- dfunFoo1+    instance Foo a        => Foo [a]                            -- dfunFoo2+    instance                 Foo [Char]                         -- dfunFoo3++Consider generating the superclasses of the instance declaration+         instance Foo a => Foo [a]++So our problem is this+    [G] d0 : Foo t+    [W] d1 : Data Maybe [t]   -- Desired superclass++We may add the given in the inert set, along with its superclasses+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  WorkList+    [W] d1 : Data Maybe [t]++Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+  WorkList:+    [W] d2 : Sat (Maybe [t])+    [W] d3 : Data Maybe t++Now, we may simplify d2 using dfunSat; d2 := dfunSat d4+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList:+    [W] d3 : Data Maybe t+    [W] d4 : Foo [t]++Now, we can just solve d3 from d01; d3 := d01+  Inert+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList+    [W] d4 : Foo [t]++Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5+  Inert+    [G] d0  : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+        d4 : Foo [t]+  WorkList:+    [W] d5 : Foo t++Now, d5 can be solved! d5 := d0++Result+   d1 := dfunData2 d2 d3+   d2 := dfunSat d4+   d3 := d01+   d4 := dfunFoo2 d5+   d5 := d0+-}++{- *********************************************************************+*                                                                      *+                InertCans: the canonical inerts+*                                                                      *+*                                                                      *+********************************************************************* -}++{- Note [Tracking Given equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify+Note [Unification preconditions], we can't unify+   alpha[2] ~ Int+under a level-4 implication if there are any Given equalities+bound by the implications at level 3 of 4.  To that end, the+InertCans tracks++  inert_given_eq_lvl :: TcLevel+     -- The TcLevel of the innermost implication that has a Given+     -- equality of the sort that make a unification variable untouchable+     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).++We update inert_given_eq_lvl whenever we add a Given to the+inert set, in updGivenEqs.++Then a unification variable alpha[n] is untouchable iff+    n < inert_given_eq_lvl+that is, if the unification variable was born outside an+enclosing Given equality.++Exactly which constraints should trigger (UNTOUCHABLE), and hence+should update inert_given_eq_lvl?++(TGE1) We do /not/ need to worry about let-bound skolems, such as+     forall[2] a. a ~ [b] => blah+  See Note [Let-bound skolems] and the isOuterTyVar tests in `updGivenEqs`++(TGE2) However, solely to support better error messages (see Note [HasGivenEqs] in+   GHC.Tc.Types.Constraint) we also track these "local" equalities in the+   boolean inert_given_eqs field.  This field is used only subsequntly (see+   `getHasGivenEqs`), to set the ic_given_eqs field to LocalGivenEqs.++(TGE3) Consider an implication+      forall[2]. beta[1] => alpha[1] ~ Int+  where beta is a unification variable that has already been unified+  to () in an outer scope.  Then alpha[1] is perfectly touchable and+  we can unify alpha := Int. So when deciding whether the givens contain+  an equality, we should canonicalise first, rather than just looking at+  the /original/ givens (#8644).++(TGE4) However, we must take account of *potential* equalities. Consider the+   same example again, but this time we have /not/ yet unified beta:+      forall[2] beta[1] => ...blah...++   Because beta might turn into an equality, updGivenEqs conservatively+   treats it as a potential equality, and updates inert_give_eq_lvl++(TGE5) We should not look at the equality relation involved (nominal vs+   representational), because representational equalities can still+   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+   data T where+      MkT :: F a ~ G b => a -> b -> T+   f (MkT _ _) = True+We should not infer the type for `f`; let-bound-skolems does not apply.++Note [Let-bound skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+If   * the inert set contains a canonical Given CEqCan (a ~ ty)+and  * 'a' is a skolem bound in this very implication,++then:+   a) The Given is pretty much a let-binding, like+         f :: (a ~ b->c) => a -> a+      Here the equality constraint is like saying+         let a = b->c in ...+      It is not adding any new, local equality  information,+      and hence can be ignored by has_given_eqs++   b) 'a' will have been completely substituted out in the inert set,+      so we can safely discard it.++For an example, see #9211.++The actual test is in `isLetBoundSkolemCt`++Wrinkles:++(LBS1) See GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure+       that the correct variable is on the left of the equality when both are+       tyvars.++(LBS2) We also want this to work for+            forall a. [G] F b ~ a   (CEqCt with TyFamLHS)+   Here the Given will have a TyFamLHS, with the skolem-bound tyvar on the RHS.+   See tests T24938a, and LocalGivenEqs.++(LBS3) Happily (LBS2) also makes cycle-breakers work. Suppose we have+            forall a. [G] (F a) Int ~ a+  where F has arity 1, and `a` is the locally-bound skolem.  Then, as+  Note [Type equality cycles] explains, we split into+           [G] F a ~ cbv, [G] cbv Int ~ a+  where `cbv` is the cycle breaker variable.  But cbv has the same level+  as `a`, so `isOuterTyVar` (called in `isLetBoundSkolemCt`) will return False.++  This actually matters occasionally: see test LocalGivenEqs.++You might wonder whether the skolem really needs to be bound "in the+very same implication" as the equality constraint.+Consider this (c.f. #15009):++  data S a where+    MkS :: (a ~ Int) => S a++  g :: forall a. S a -> a -> blah+  g x y = let h = \z. ( z :: Int+                      , case x of+                           MkS -> [y,z])+          in ...++From the type signature for `g`, we get `y::a` .  Then when we+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the+body of the lambda we'll get++  [W] alpha[1] ~ Int                             -- From z::Int+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]++Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!+So we must treat alpha as untouchable under the forall[2] implication.++Possible future improvements.  The current test just looks to see whether one+side of an equality is a locally-bound skolem.  But actually we could, in+theory, do better: if one side (or both sides, actually) of an equality+ineluctably mentions a local skolem, then the equality cannot possibly impact+types outside of the implication (because doing to would cause those types to be+ill-scoped). The problem is the "ineluctably": this means that no expansion,+other solving, etc., could possibly get rid of the variable. This is hard,+perhaps impossible, to know for sure, especially when we think about type family+interactions. (And it's a user-visible property so we don't want it to be hard+to predict.) So we keep the existing check, looking for one lone variable,+because we're sure that variable isn't going anywhere.++Note [Detailed InertCans Invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The InertCans represents a collection of constraints with the following properties:++  * All canonical++  * No two dictionaries with the same head+  * No two CIrreds with the same type++  * Family equations inert wrt top-level family axioms++  * Dictionaries have no matching top-level instance++  * Given family or dictionary constraints don't mention touchable+    unification variables++  * Non-CEqCan constraints are fully rewritten with respect+    to the CEqCan equalities (modulo eqCanRewrite of course;+    eg a wanted cannot rewrite a given)++  * CEqCan equalities: see Note [inert_eqs: the inert equalities]+    Also see documentation in Constraint.Ct for a list of invariants++Note [inert_eqs: the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our main invariant:+   the EqCts in inert_eqs should be a+        terminating generalised substitution++-------------- Definition [Can-rewrite relation] --------------+A "can-rewrite" relation between flavours, written f1 >= f2, is a+binary relation with the following properties++  (R1) >= is transitive+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+  (See Note [Why R2?].)++Lemma (L0). If f1 >= f then f1 >= f1+Proof.      By property (R2), with f1=f2++--------- Definition [Generalised substitution] ---------------+A "generalised substitution" S is a set of triples (lhs -f-> t), where+  - lhs is a type variable or an exactly-saturated type family application+                  (that is, lhs is a CanEqLHS)+  - t is a type+  - f is a flavour++such that++  (WF1) if (lhs1 -f1-> t1) in S+           (lhs2 -f2-> t2) in S+        then (f1 >= f2) implies that lhs1 does not appear within lhs2++  (WF2) if (lhs -f-> t) is in S, then t /= lhs++  (WF3) No LHS in S is rewritable in an RHS in S,+        in the argument of a type family application (F ty1..tyn)+        where F heads a LHS in S++--------- Definition [Applying a generalised substitution] ----------+If S is a generalised substitution+   S(f,lhs)      = rhs,             if (lhs -fs-> rhs) in S, and fs >= f+   S(f,T t1..tn) = T S(f1,t1)..S(fn,tn)+   S(f,t1 t2)    = S(f,t1) S(f_N,t2)+   S(f,t)        = t+Here f1..fn are obtained from f and T using the roles of T, and f_N is+the nominal version of f.  See Note [Flavours with roles].++Notation: repeated application.+  S^0(f,t)     = t+  S^(n+1)(f,t) = S(f, S^n(t))+  S*(f,t) is the result of applying S until you reach a fixpoint++---------  Definition [Terminating generalised substitution] ---------+A generalised substitution S is *terminating* iff++  (IG1) for every f,t, there is an n such that+             S^n(f,t) = S^(n+1)(f,t)++By (IG1) we define S*(f,t) to be the result of exahaustively+applying S(f,_) to t.+--------- End of definitions ------------------------------------+++Rationale for (WF1)-(WF3)+-------------------------+* (WF1) guarantees that S is well-defined /as a function/;+  see Theorem (S is a function)++   Theorem (S is a function): S(f,t0) is well defined as a function.+   Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,+               and  f1 >= f and f2 >= f+          Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)+   Note: this argument isn't quite right.  WF1 ensures that lhs1 does+   not appear inside lhs2, and that guarantees confluence. But I can't quite+   see how to make that argument precise.++* (WF2) is a bit trivial.  It means that if S is terminating, so that+  S^(n+1)(f,t) = S^n(f,t), then there is no LHS of S in S^n(f,t).  We+  never get a silly infinite sequence a -> a -> a -> a  .... which is+  technically a fixed point but would still go on for ever.++* (WF3) is need for the termination proof.++Note that termination is not the same as idempotence.  To apply S to a+type, you may have to apply it recursively.  But termination does+guarantee that this recursive use will terminate.++Note [Why R2?]+~~~~~~~~~~~~~~+R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=+f1. If we do not have R2, we will easily fall into a loop.++To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our+inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And+yet, we have a hard time noticing an occurs-check problem when building S, as+the two equalities cannot rewrite one another.++R2 actually restricts our ability to accept user-written programs. See+Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example.++Note [Rewritable]+~~~~~~~~~~~~~~~~~+Definition. A CanEqLHS lhs is *rewritable* in a type t if the+lhs tree appears as a subtree within t without traversing any of the following+components of t:+  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)+  * kinds of variable occurrences+The check for rewritability *does* look in kinds of the bound variable of a+ForAllTy.++The reason for this definition is that the rewriter does not rewrite in coercions+or variables' kinds. In turn, the rewriter does not need to rewrite there because+those places are never used for controlling the behaviour of the solver: these+places are not used in matching instances or in decomposing equalities.++This definition is used by the anyRewritableXXX family of functions and is meant+to model the actual behaviour in GHC.Tc.Solver.Rewrite.++Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised+substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f+for all f.++Wrinkles++* Taking roles into account: we must consider a rewrite at a given role. That is,+  a rewrite arises from some equality, and that equality has a role associated+  with it. As we traverse a type, we track what role we are allowed to rewrite with.++  For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in+  Maybe b but not in F b, where F is a type function. This role-aware logic is+  present in both the anyRewritableXXX functions and in the rewriter.+  See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.++* There is one exception to the claim that non-rewritable parts of the tree do+  not affect the solver: we sometimes do an occurs-check to decide e.g. how to+  orient an equality. (See the comments on GHC.Tc.Solver.Equality.canEqTyVarFunEq.)+  Accordingly, the presence of a variable in a kind or coercion just might+  influence the solver. Here is an example:++    type family Const x y where+      Const x y = x++    AxConst :: forall x y. Const x y ~# x++    alpha :: Const Type Nat+    [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;+                        AxConst Type alpha ;;+                        sym (AxConst Type Nat))++  The cast is clearly ludicrous (it ties together a cast and its symmetric+  version), but we can't quite rule it out. (See (EQ1) from Note [Respecting+  definitional equality] in GHC.Core.TyCo.Rep to see why we need the Const Type+  Nat bit.) And yet this cast will (quite rightly) prevent alpha from unifying+  with the RHS. I (Richard E) don't have an example of where this problem can+  arise from a Haskell program, but we don't have an air-tight argument for why+  the definition of *rewritable* given here is correct.++Note [Extending the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Main Theorem [Stability under extension]+   GIVEN a "work item" [lhs_w -fw-> rhs_w]+         and a terminating generalised substitution S,++   SUCH THAT+      (T1) S(fw,lhs_w) = lhs_w   -- LHS of work-item is a fixpoint of S(fw,_)+      (T2) S(fw,rhs_w) = rhs_w   -- RHS of work-item is a fixpoint of S(fw,_)+      (T3) lhs_w not in rhs_w    -- No occurs check in the work item+             -- If lhs is a type family application, we require only that+             -- lhs is not *rewritable* in rhs_w. See Note [Rewritable] and+             -- Note [EqCt occurs check] in GHC.Tc.Types.Constraint.+      (T4) no [lhs_s -fs-> rhs_s] in S meets [The KickOut Criteria]+           (i.e. we already kicked any such items out!)++   THEN the extended substitution T = S+(lhs_w -fw-> rhs_w)+        is a terminating generalised substitution++How do we establish these conditions?++  * (T1) and (T2) are guaranteed by exhaustively rewriting the work-item+    with S(fw,_).++  * (T3) is guaranteed by an occurs-check on the work item.+    This is done during canonicalisation, in checkTypeEq; invariant+    (TyEq:OC) of CEqCan. See also Note [EqCt occurs check] in GHC.Tc.Types.Constraint.++  * (T4) is established by GHC.Tc.Solver.Monad.kickOutRewritable.  If the inert+    set contains a triple that meets the KickOut Criteria, we kick it out and+    add it to the work list for later re-examination.  See+    Note [The KickOut Criteria]++Theorem: T (defined in "THEN" above) is a generalised substitution;+  that is, it satisfies (WF1)-(WF3)+Proof:+  (WF1) Suppose we are adding [lhs_w -fw-> rhs_w], and [lhs_s -fs-> rhs_s] is in S.+        Then:+          - by (T1)  if fs>=fw, lhs_s does not occur within lhs_w.+          - by (KK1) if fw>=fs, lhs_w is not rewritable in lhs_s, or we'd have+            kicked out the stable constraint.++  (WF2) is directly guaranteed by (T3)++  (WF3) No lhs_s in S is rewritable in rhs_w at all, because of (T2)+        And (KK2) guarantees that lhs_w is not rewritable under a type+        family in rhs_s++Note [The KickOut Criteria]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kicking out is a Bad Thing:+* It means we have to re-process a constraint.  The less we kick out, the better.+* In the limit, kicking can lead to non-termination: imagine that we /always/+  kick out the entire inert set!+* Because (mid 2024) we don't support sharing in constraints, excessive kicking out+  can lead to exponentially big constraints (#24984).++So we seek to do as little kicking out as possible.  For example, consider this,+which happens a lot:++   Inert:  g1: a ~ Maybe b+   Work:   g2: b ~ Int++We do /not/ kick out g1 when adding g2.  The new substitution S' = {g1,g2} is still+/terminating/ but it is not /idmempotent/.  To apply S' to, say, (Tree a), we may+need to apply it twice:  Tree a --> Tree (Maybe b) --> Tree (Maybe Int)++Here are the KickOut Criteria:++    When adding [lhs_w -fw-> rhs_w] to a well-formed terminating substitution S,+    element [lhs_s -fs-> rhs_s] in S meets the KickOut Criteria if:++    (KK0) fw >= fs    AND   any of (KK1), (KK2) or (KK3) hold++    * (KK1: satisfy WF1) `lhs_w` is rewritable in `lhs_s`.++    * (KK2: termination) `lhs_w` is rewritable in `rhs_s` in these positions:+        If not(fs>=fw)+        then (KK2a) anywhere+        else (KK2b) look only in the argument of type family applications,+                    whose type family heads some LHS in `S`++    * (KK3: completeness)+      If not(fs >= fw)   -- If fs can rewrite fw, kick-out is redundant/harmful+      * (KK3a) If the role of `fs` is Nominal:+           kick out if `rhs_s = lhs_w`+      * (KK3b) If the role of `fs` is Representational:+           kick out if `rhs_s` is of form `(lhs_w t1 .. tn)`++Rationale++* (KK0) kick out only if `fw` can rewrite `fs`.+  Reason: suppose we kick out (lhs1 -fs-> s), and add (lhs -fw-> t) to the ineart+  set. The latter can't rewrite the former, so the kick-out achieved nothing++* (KK1) `lhs_w` is rewritable in `lhs_s`.+  Reason: needed to guarantee (WF1).  See Theorem: T is well formed++* (KK2) see Note [KK2: termination of the extended substitution]++* (KK3) see Note [KK3: completeness of solving]++The above story is a bit vague wrt roles, but the code is not.+See Note [Flavours with roles]++Note [KK2: termination of the extended substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Proving termination of the extended substitution T is surprisingly tricky.++* Reason for (KK2a).  Consider+      Work:  [G] b ~ a+      Inert: [W] a ~ b+  If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int.+  But if both were Wanted we really should not kick out (the substitution does not+  have to be idempotent). So we only look everywhere for the `lhs_w` if+  not (fs>=fw), that is the inert item cannot rewrite the work item.  So in the+  above example we will kick out; but if both were Wanted we won't.++* Reason for (KK2b).  Consider the case where (fs >= fw)+      Work:  [G] a ~ Int+      Inert: [G] F Int ~ F a+  If we just added the work item, the substitution would loop on type (F Int).+  So we must kick out the inert item, even though (fs>=fw). (KK2b) does this+  by looking for lhs_w under type family applications in rhs_s.++  (KK2b) makes kick-out less aggressive by looking only under type-family applications,+  in the case where (fs >= fw), and that made a /huge/ difference to #24944.++Tricky examples in: #19042, #17672, #24984. The last (#24984) is particular subtle:++  Inert:   [W] g1: F a0 ~ F a1+           [W] g2: F a2 ~ F a1+           [W] g3: F a3 ~ F a1++Now we add [W] g4: F a1 ~ F a7.  Should we kick out g1,g2,g3?  No!  The+substitution doesn't need to be idempotent, merely terminating.  And in #24984+it turned out that we kept adding one new constraint and kicking out all the+previous inert ones (and that rewriting led to exponentially big constraints due+to lack of contraint sharing.)  So we only want to look /under/ type family applications.++The proof is hard. We start by ignoring flavours. Suppose that:+* We are adding [lhs_w -fw-> rhs_w] to a well-formed, terminating substitution S.+* None of the constraints in S meet the KickOut Criteria.+* Define T = S+[lhs_w -fw-> rhs_w]+* `f` is an arbitrary flavour++Lemma 1: for any lhs_s in S, T*(f,lhs_s) terminates.+  Proof.+  * We know that r1 = S*(f,lhs_s) terminates.+  * Moreover, we know there are no occurrences of lhs_w under a type family (which+    is the head of a LHS) in r1 (KK2)+(WF3).  We need (WF3) because you might wonder+    what if rhs_s is (F a), and [a --> lhs_w] was in S.  But (WF3) prevents that.+  * Define r2 = r1{rhs_w/lhs_w}.  We know that rhs_w has no occurrences of any lhs in S,+    nor of lhs_w.+  * Since any occurrence of lhs_w does not occur under a type family, the substitution+    won't make any F t1..tn ~ s in S match.+  * So r2 is a fixed point of T.++Lemma 2: T*(f,lhs_w) teminates.+  Proof: no occurrences of any LHS in rhs_w.++Theorem. For any type r, T*(r) terminates.+  Proof:+  1. Consider any sub-term of r, which is a LHS of T.+     - Rewrite it with T*; this terminates (Lemma 1).+     - Do this simultaneously to all sub-terms that match a LHS of T, yielding r1.+  2. Could this new r1 have a sub-term that is an LHS of T?  Yes, but only if r has a+     sub-term F w, and w rewrote in Step 1 to w' and F w' matches a LHS in T.+  3. Very well: apply step 1 again, but note that /doing so consumes one of the family+     applications in the original r/.+  4. After Step 1 either we have reached a fixed point, or we repeat Step 1 consuming at+     least one family application of r.+  5. There are only a finite number of family applications in r, so this process terminates.++Example:++Inert set:   gs : F Int ~ b+Work item:   gw : b ~ Int++F (F (F b)) --[gw]--> F (F (F Int)) --[gs]--> F (F b)+            --[gw]--> F (F Int)     --[gs]--> F b+            --[gw]--> F Int         --[gs]--> b+            --[gw]--> Int++Notice that each iteration of Step 1 strips off one of the layers of F, all+of which were in the original r.++The argument is even more tricky when flavours are involved, and we have not+fleshed it out in detail.++Note [KK3: completeness of solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(KK3) is not necessary for the extended substitution+to be terminating.  In fact (KK0) could be made stronger by saying+   ... then (not (fw >= fs) or not (fs >= fs))+But it's not enough for S to be /terminating/; we also want /completeness/.+That is, we want to be able to solve all soluble wanted equalities.+Suppose we have+   work-item   b -G-> a+   inert-item  a -W-> b+Assuming (G >= W) but not (W >= W), this fulfills all the conditions,+so we could extend the inerts, thus:+   inert-items   b -G-> a+                 a -W-> b+But if we kicked-out the inert item, we'd get+   work-item     a -W-> b+   inert-item    b -G-> a++Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.+So we add one more clause (KK3) to the kick-out criteria:++    * (KK3: completeness)+      If not(fs >= fw)   (KK3a)+      * (KK3b) If the role of `fs` is Nominal:+           kick out if `rhs_s = lhs_w`+      * (KK3c) If the role of `fs` is Representational:+           kick out if `rhs_s` is of form `(lhs_w t1 .. tn)`++Wrinkles:++* (KK3a) All this can only happen if the work-item can rewrite the inert+  one, /but not vice versa/; that is not(fs >= fw).  It is useless to kick+  out if (fs >= fw) becuase then the work-item is already fully rewritten+  by the inert item.  And too much kick-out is positively harmful.+  (Historical example #14363.)++* (KK3b) addresses teh main example above for KK3. Another way to understand+  (KK3b) is that we treat an inert item+        a -f-> b+  in the same way as+        b -f-> a+  So if we kick out one, we should kick out the other.  The orientation+  is somewhat accidental.++* (KK3c) When considering roles, we also need the second clause (KK3b). Consider+      work-item    c -G/N-> a+      inert-item   a -W/R-> b c+  The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.+  But we don't kick out the inert item because not (W/R >= W/R).  So we just+  add the work item. But then, consider if we hit the following:+      work-item    b -G/N-> Id+      inert-items  a -W/R-> b c+                 c -G/N-> a+    where+      newtype Id x = Id x++  For similar reasons, if we only had (KK3a), we wouldn't kick the+  representational inert out. And then, we'd miss solving the inert, which now+  reduced to reflexivity.++  The solution here is to kick out representational inerts whenever the lhs of a+  work item is "exposed", where exposed means being at the head of the top-level+  application chain (lhs t1 .. tn).  See head_is_new_lhs. This is encoded in+  (KK3c)).+++Note [Flavours with roles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The system described in Note [inert_eqs: the inert equalities]+discusses an abstract+set of flavours. In GHC, flavours have two components: the flavour proper,+taken from {Wanted, Given} and the equality relation (often called+role), taken from {NomEq, ReprEq}.+When substituting w.r.t. the inert set,+as described in Note [inert_eqs: the inert equalities],+we must be careful to respect all components of a flavour.+For example, if we have++  inert set: a -G/R-> Int+             b -G/R-> Bool++  type role T nominal representational++and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT+T Int Bool. The reason is that T's first parameter has a nominal role, and+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of+substitution means that the proof in Note [inert_eqs: the inert equalities] may+need to be revisited, but we don't think that the end conclusion is wrong.+-}++data InertCans   -- See Note [Detailed InertCans Invariants] for more+  = IC { inert_eqs :: InertEqs+              -- See Note [inert_eqs: the inert equalities]+              -- All EqCt with a TyVarLHS; index is the LHS tyvar+              -- Domain = skolems and untouchables; a touchable would be unified++       , inert_funeqs :: InertFunEqs+              -- All EqCt with a TyFamLHS; index is the whole family head type.+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)+              --     wrt inert_eqs+              -- Can include both [G] and [W]++       , inert_dicts :: DictMap DictCt+              -- Dictionaries only+              -- All fully rewritten (modulo flavour constraints)+              --     wrt inert_eqs++       , inert_qcis :: [QCInst] -- See Note [Quantified constraints]+                                -- in GHC.Tc.Solver.Solve++       , inert_irreds :: InertIrreds+              -- Irreducible predicates that cannot be made canonical,+              --     and which don't interact with others (e.g.  (c a))+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])++       , inert_given_eq_lvl :: TcLevel+              -- The TcLevel of the innermost implication that has a Given+              -- equality of the sort that make a unification variable untouchable+              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).+              -- See Note [Tracking Given equalities]++       , inert_given_eqs :: Bool+              -- True <=> The inert Givens *at this level* (tcl_tclvl)+              --          could includes at least one equality /other than/ a+              --          let-bound skolem equality.+              -- Reason: report these givens when reporting a failed equality+              -- See Note [Tracking Given equalities]+       }++type InertEqs    = DTyVarEnv EqualCtList+type InertFunEqs = FunEqMap  EqualCtList+type InertIrreds = Bag IrredCt++instance Outputable InertCans where+  ppr (IC { inert_eqs = eqs+          , inert_funeqs = funeqs+          , inert_dicts = dicts+          , inert_irreds = irreds+          , inert_given_eq_lvl = ge_lvl+          , inert_given_eqs = given_eqs+          , inert_qcis = insts })++    = braces $ vcat+      [ ppUnless (isEmptyDVarEnv eqs) $+        text "Equalities ="+          <+> pprBag (foldTyEqs consBag eqs emptyBag)+      , ppUnless (isEmptyTcAppMap funeqs) $+        text "Type-function equalities ="+          <+> pprBag (foldFunEqs consBag funeqs emptyBag)+      , ppUnless (isEmptyTcAppMap dicts) $+        text "Dictionaries =" <+> pprBag (dictsToBag dicts)+      , ppUnless (isEmptyBag irreds) $+        text "Irreds =" <+> pprBag irreds+      , ppUnless (null insts) $+        text "Given instances =" <+> vcat (map ppr insts)+      , text "Innermost given equalities =" <+> ppr ge_lvl+      , text "Given eqs at this level =" <+> ppr given_eqs+      ]+++{- *********************************************************************+*                                                                      *+                   Inert equalities+*                                                                      *+********************************************************************* -}++emptyTyEqs :: InertEqs+emptyTyEqs = emptyDVarEnv++addEqToCans :: TcLevel -> EqCt -> InertCans -> InertCans+addEqToCans tc_lvl eq_ct@(EqCt { eq_lhs = lhs })+            ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })+  = updGivenEqs tc_lvl (CEqCan eq_ct) $+    case lhs of+       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct }+       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv eq_ct }++addTyEq :: InertEqs -> TcTyVar -> EqCt -> InertEqs+addTyEq old_eqs tv ct+  = extendDVarEnv_C add_eq old_eqs tv [ct]+  where+    add_eq old_eqs _ = addToEqualCtList ct old_eqs++foldTyEqs :: (EqCt -> b -> b) -> InertEqs -> b -> b+foldTyEqs k eqs z+  = foldDVarEnv (\cts z -> foldr k z cts) z eqs++findTyEqs :: InertCans -> TyVar -> [EqCt]+findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv)++delEq :: EqCt -> InertCans -> InertCans+delEq (EqCt { eq_lhs = lhs, eq_rhs = rhs }) ic = case lhs of+    TyVarLHS tv+      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }+    TyFamLHS tf args+      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }+  where+    isThisOne :: EqCt -> Bool+    isThisOne (EqCt { eq_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1++    upd :: Maybe EqualCtList -> Maybe EqualCtList+    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list+    upd Nothing           = Nothing++findEq :: InertCans -> CanEqLHS -> [EqCt]+findEq icans (TyVarLHS tv) = findTyEqs icans tv+findEq icans (TyFamLHS fun_tc fun_args)+  = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args)++{-# INLINE partition_eqs_container #-}+partition_eqs_container+  :: forall container+   . container    -- empty container+  -> (forall b. (EqCt -> b -> b) ->  container -> b -> b) -- folder+  -> (EqCt -> container -> container)  -- extender+  -> (EqCt -> Bool)+  -> container+  -> ([EqCt], container)+partition_eqs_container empty_container fold_container extend_container pred orig_inerts+  = fold_container folder orig_inerts ([], empty_container)+  where+    folder :: EqCt -> ([EqCt], container) -> ([EqCt], container)+    folder eq_ct (acc_true, acc_false)+      | pred eq_ct = (eq_ct : acc_true, acc_false)+      | otherwise  = (acc_true,         extend_container eq_ct acc_false)++partitionInertEqs :: (EqCt -> Bool)   -- EqCt will always have a TyVarLHS+                  -> InertEqs+                  -> ([EqCt], InertEqs)+partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs addInertEqs++addInertEqs :: EqCt -> InertEqs -> InertEqs+-- Precondition: CanEqLHS is a TyVarLHS+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+addCanFunEq old_eqs fun_tc fun_args ct+  = alterTcApp old_eqs fun_tc fun_args upd+  where+    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list+    upd Nothing                  = Just [ct]++foldFunEqs :: (EqCt -> b -> b) -> FunEqMap EqualCtList -> b -> b+foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z++partitionFunEqs :: (EqCt -> Bool)    -- EqCt will have a TyFamLHS+                -> InertFunEqs+                -> ([EqCt], InertFunEqs)+partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs addFunEqs++addFunEqs :: EqCt -> InertFunEqs -> InertFunEqs+-- Precondition: EqCt is a TyFamLHS+addFunEqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args }) fun_eqs+  = 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++{- *********************************************************************+*                                                                      *+                   Inert Dicts+*                                                                      *+********************************************************************* -}++-- | 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) }++delDict :: DictCt -> DictMap a -> DictMap a+delDict (DictCt { di_cls = cls, di_tys = tys }) m+  = delTcApp m (classTyCon cls) tys++addDict :: DictCt -> DictMap DictCt -> DictMap DictCt+addDict item@(DictCt { di_cls = cls, di_tys = tys }) dm+  = insertTcApp dm (classTyCon cls) tys item++addSolvedDict :: DictCt -> DictMap DictCt -> DictMap DictCt+addSolvedDict item@(DictCt { di_cls = cls, di_tys = tys }) dm+  = insertTcApp dm (classTyCon cls) tys item++filterDicts :: (DictCt -> Bool) -> DictMap DictCt -> DictMap DictCt+filterDicts f m = filterTcAppMap f m++partitionDicts :: (DictCt -> Bool) -> DictMap DictCt -> (Bag DictCt, DictMap DictCt)+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap)+  where+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)+                       | otherwise = (yeses,              addDict ct noes)+++{- *********************************************************************+*                                                                      *+                   Inert Irreds+*                                                                      *+********************************************************************* -}++addIrredToCans :: TcLevel -> IrredCt -> InertCans -> InertCans+addIrredToCans tc_lvl irred ics+  = updGivenEqs tc_lvl (CIrredCan irred) $+    updIrreds (addIrred irred) ics++addIrreds :: [IrredCt] -> InertIrreds -> InertIrreds+addIrreds extras irreds+  | null extras = irreds+  | otherwise   = irreds `unionBags` listToBag extras++addIrred :: IrredCt -> InertIrreds -> InertIrreds+addIrred extra irreds = irreds `snocBag` extra++updIrreds :: (InertIrreds -> InertIrreds) -> InertCans -> InertCans+updIrreds upd ics = ics { inert_irreds = upd (inert_irreds ics) }++delIrred :: IrredCt -> InertCans -> InertCans+-- Remove a particular (Given) Irred, on the instructions of a plugin+-- For some reason this is done vis the evidence Id, not the type+-- Compare delEq.  I have not idea why+delIrred (IrredCt { ir_ev = ev }) ics+  = updIrreds (filterBag keep) ics+  where+    ev_id = ctEvEvId ev+    keep (IrredCt { ir_ev = ev' }) = ev_id /= ctEvEvId ev'++foldIrreds :: (IrredCt -> b -> b) -> InertIrreds -> b -> b+foldIrreds k irreds z = foldr k z irreds++findMatchingIrreds :: InertIrreds -> CtEvidence+                   -> (Bag (IrredCt, SwapFlag), InertIrreds)+findMatchingIrreds irreds ev+  | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred+    -- See Note [Solving irreducible equalities]+  = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds+  | otherwise+  = partitionBagWith match_non_eq irreds+  where+    pred = ctEvPred ev+    match_non_eq irred+      | irredCtPred irred `tcEqType` pred = Left (irred, NotSwapped)+      | otherwise                         = Right irred++    match_eq eq_rel1 lty1 rty1 irred+      | EqPred eq_rel2 lty2 rty2 <- classifyPredType (irredCtPred irred)+      , eq_rel1 == eq_rel2+      , Just swap <- match_eq_help lty1 rty1 lty2 rty2+      = Left (irred, swap)+      | otherwise+      = Right irred++    match_eq_help lty1 rty1 lty2 rty2+      | lty1 `tcEqType` lty2, rty1 `tcEqType` rty2+      = Just NotSwapped+      | lty1 `tcEqType` rty2, rty1 `tcEqType` lty2+      = Just IsSwapped+      | otherwise+      = Nothing++{- Note [Solving irreducible equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14333)+  [G] a b ~R# c d+  [W] c d ~R# a b+Clearly we should be able to solve this! Even though the constraints are+not decomposable. We solve this when looking up the work-item in the+irreducible constraints to look for an identical one.  When doing this+lookup, findMatchingIrreds spots the equality case, and matches either+way around. It has to return a swap-flag so we can generate evidence+that is the right way round too.+-}++{- *********************************************************************+*                                                                      *+                Adding to and removing from the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++updGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans+-- Set the inert_given_eq_level to the current level (tclvl)+-- if the constraint is a given equality that should prevent+-- filling in an outer unification variable.+-- See Note [Tracking Given equalities]+--+-- Precondition: Ct is either CEqCan or CIrredCan+updGivenEqs tclvl ct inerts+  | not (isGivenCt ct) = inerts++  -- See Note [Let-bound skolems]+  | isLetBoundSkolemCt tclvl ct = inerts { inert_given_eqs = True }++  -- At this point we are left with a constraint that either+  -- is an equality (F a ~ ty), or /might/ be, like (c a)+  | otherwise = inerts { inert_given_eq_lvl = tclvl+                       , inert_given_eqs    = True }++isLetBoundSkolemCt :: TcLevel -> Ct -> Bool+-- See Note [Let-bound skolems]+isLetBoundSkolemCt tclvl (CEqCan (EqCt { eq_lhs = lhs, eq_rhs = rhs }))+  = case lhs of+      TyVarLHS tv -> not (isOuterTyVar tclvl tv)+      TyFamLHS {} -> case getTyVar_maybe rhs of+                       Just tv -> not (isOuterTyVar tclvl tv)+                       Nothing -> False+isLetBoundSkolemCt _ _ = False++data KickOutSpec -- See Note [KickOutSpec]+  = KOAfterUnify  TcTyVarSet   -- We have unified these tyvars+  | KOAfterAdding CanEqLHS     -- We are adding to the inert set a canonical equality+                               -- constraint with this LHS++instance Outputable KickOutSpec where+  ppr (KOAfterUnify tvs)  = text "KOAfterUnify" <> ppr tvs+  ppr (KOAfterAdding lhs) = text "KOAfterAdding" <> parens (ppr lhs)++{- Note [KickOutSpec]+~~~~~~~~~~~~~~~~~~~~~~+KickOutSpec explains why we are kicking out.++Important property:+  KOAfterAdding (TyVarLHS tv) should behave exactly like+  KOAfterUnifying (unitVarSet tv)++The main reasons for treating the two separately are+* More efficient in the single-tyvar case+* The code is far more perspicuous+-}++data WhereToLook = LookEverywhere | LookOnlyUnderFamApps+                   deriving( Eq )++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_qcis    = old_insts })+  = (kicked_out, inert_cans_in)+  where+    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)+                  `extendCtsList` insts_out+                  `extendCtsList` map CEqCan tv_eqs_out+                  `extendCtsList` map CEqCan feqs_out++    (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs+    (feqs_out,   feqs_in)   = partitionFunEqs   kick_out_eq funeqmap+    (dicts_out,  dicts_in)  = partitionDicts    kick_out_dict dictmap+    (irs_out,    irs_in)    = partitionBag      kick_out_irred irreds+      -- Kick out even insolubles: See Note [Rewrite insolubles]+      -- Of course we must kick out irreducibles like (c a), in case+      -- we can rewrite 'c' to something more useful++    -- Kick-out for inert instances+    -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve+    insts_out :: [Ct]+    insts_in  :: [QCInst]+    (insts_out, insts_in)+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens+       = partitionWith kick_out_qci old_insts+       | otherwise+       = ([], old_insts)+    kick_out_qci qci+      | let ev = qci_ev qci+      , fr_can_rewrite_ty LookEverywhere NomEq (ctEvPred (qci_ev qci))+      = Left (mkNonCanonical ev)+      | otherwise+      = Right qci++    fr_tv_can_rewrite_ty :: WhereToLook -> (TyVar -> Bool) -> EqRel -> Type -> Bool+    fr_tv_can_rewrite_ty where_to_look check_tv role ty+      = anyRewritableTyVar role can_rewrite ty+      where+        can_rewrite :: UnderFam -> EqRel -> TyVar -> Bool+        can_rewrite is_under_famapp old_role tv+           = (where_to_look == LookEverywhere || is_under_famapp) &&+             new_role `eqCanRewrite` old_role && check_tv tv++    fr_tf_can_rewrite_ty :: WhereToLook -> TyCon -> [TcType] -> EqRel -> Type -> Bool+    fr_tf_can_rewrite_ty where_to_look new_tf new_tf_args role ty+      = anyRewritableTyFamApp role can_rewrite ty+      where+        can_rewrite :: UnderFam -> EqRel -> TyCon -> [TcType] -> Bool+        can_rewrite is_under_famapp old_role old_tf old_tf_args+          = (where_to_look == LookEverywhere || is_under_famapp) &&+            new_role `eqCanRewrite` old_role &&+            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args+              -- it's possible for old_tf_args to have too many. This is fine;+              -- we'll only check what we need to.+++    fr_can_rewrite_ty :: WhereToLook -> EqRel -> Type -> Bool+    -- UnderFam = True <=> look only under type-family applications+    fr_can_rewrite_ty uf = case ko_spec of  -- See Note [KickOutSpec]+      KOAfterUnify tvs                    -> fr_tv_can_rewrite_ty uf (`elemVarSet` tvs)+      KOAfterAdding (TyVarLHS tv)         -> fr_tv_can_rewrite_ty uf (== tv)+      KOAfterAdding (TyFamLHS tf tf_args) -> fr_tf_can_rewrite_ty uf tf tf_args++    fr_may_rewrite :: CtFlavourRole -> Bool+    fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs+        -- Can the new item rewrite the inert item?++    kick_out_dict :: DictCt -> Bool+    -- Kick it out if the new CEqCan can rewrite the inert one+    -- See Note [kickOutRewritable]+    kick_out_dict (DictCt { di_tys = tys, di_ev = ev })+      =  fr_may_rewrite (ctEvFlavour ev, NomEq)+      && any (fr_can_rewrite_ty LookEverywhere NomEq) tys++    kick_out_irred :: IrredCt -> Bool+    kick_out_irred (IrredCt { ir_ev = ev })+      =  fr_may_rewrite (ctEvFlavour ev, eq_rel)+      && fr_can_rewrite_ty LookEverywhere eq_rel pred+      where+       pred   = ctEvPred ev+       eq_rel = predTypeEqRel pred++    -- Implements criteria K1-K3 in Note [Extending the inert equalities]+    kick_out_eq :: EqCt -> Bool+    kick_out_eq (EqCt { eq_lhs = lhs, eq_rhs = rhs_ty+                      , eq_ev = ev, eq_eq_rel = eq_rel })++      -- (KK0) Keep it in the inert set if the new thing can't rewrite it+      | not (fr_may_rewrite fs)+      = False++      -- Below here (fr_may_rewrite fs) is True++      -- (KK1)+      | fr_can_rewrite_ty LookEverywhere eq_rel (canEqLHSType lhs)+      = True   -- (KK1)+         -- The above check redundantly checks the role & flavour,+         -- but it's very convenient++      -- (KK2)+      | let where_to_look | fs_can_rewrite_fr = LookOnlyUnderFamApps+                          | otherwise         = LookEverywhere+      , fr_can_rewrite_ty where_to_look eq_rel rhs_ty+      = True++      -- (KK3)+      | not fs_can_rewrite_fr                    -- (KK3a)+      , case eq_rel of+              NomEq  -> is_new_lhs      rhs_ty   -- (KK3b)+              ReprEq -> head_is_new_lhs rhs_ty   -- (KK3c)+      = True++      | otherwise = False++      where+        fs_can_rewrite_fr = fs `eqCanRewriteFR` new_fr+        fs = (ctEvFlavour ev, eq_rel)++    is_new_lhs :: Type -> Bool+    is_new_lhs = case ko_spec of   -- See Note [KickOutSpec]+          KOAfterUnify tvs  -> is_tyvar_ty_for tvs+          KOAfterAdding lhs -> (`eqType` canEqLHSType lhs)++    is_tyvar_ty_for :: TcTyVarSet -> Type -> Bool+    -- True if the type is equal to one of the tyvars+    is_tyvar_ty_for tvs ty+      = case getTyVar_maybe ty of+          Nothing -> False+          Just tv -> tv `elemVarSet` tvs++    head_is_new_lhs :: Type -> Bool+    head_is_new_lhs = case ko_spec of   -- See Note [KickOutSpec]+          KOAfterUnify tvs                    -> tv_at_head (`elemVarSet` tvs)+          KOAfterAdding (TyVarLHS tv)         -> tv_at_head (== tv)+          KOAfterAdding (TyFamLHS tf tf_args) -> fam_at_head tf tf_args++    tv_at_head :: (TyVar -> Bool) -> Type -> Bool+    tv_at_head is_tv = go+      where+        go (Rep.TyVarTy tv)    = is_tv tv+        go (Rep.AppTy fun _)   = go fun+        go (Rep.CastTy ty _)   = go ty+        go (Rep.TyConApp {})   = False+        go (Rep.LitTy {})      = False+        go (Rep.ForAllTy {})   = False+        go (Rep.FunTy {})      = False+        go (Rep.CoercionTy {}) = False++    fam_at_head :: TyCon -> [Type] -> Type -> Bool+    fam_at_head fun_tc fun_args = go+      where+        go (Rep.TyVarTy {})       = False+        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy+        go (Rep.CastTy ty _)      = go ty+        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args+        go (Rep.LitTy {})         = False+        go (Rep.ForAllTy {})      = False+        go (Rep.FunTy {})         = False+        go (Rep.CoercionTy {})    = False++{- Note [kickOutRewritable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [inert_eqs: the inert equalities].++When we add a new inert equality (lhs ~N ty) to the inert set,+we must kick out any inert items that could be rewritten by the+new equality, to maintain the inert-set invariants.++  - We want to kick out an existing inert constraint if+    a) the new constraint can rewrite the inert one+    b) 'lhs' is free in the inert constraint (so that it *will*)+       rewrite it if we kick it out.++    For (b) we use anyRewritableCanLHS, which examines the types /and+    kinds/ that are directly visible in the type. Hence+    we will have exposed all the rewriting we care about to make the+    most precise kinds visible for matching classes etc. No need to+    kick out constraints that mention type variables whose kinds+    contain this LHS!++  - We don't kick out constraints from inert_solved_dicts, and+    inert_solved_funeqs optimistically. But when we lookup we have to+    take the substitution into account++NB: we could in principle avoid kick-out:+  a) When unifying a meta-tyvar from an outer level, because+     then the entire implication will be iterated; see+     Note [The Unification Level Flag] in GHC.Tc.Solver.Monad.++  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType+     Note [TcLevel invariants], a Given can't include a meta-tyvar from+     its own level, so it falls under (a).  Of course, we must still+     kick out Givens when adding a new non-unification Given.++But kicking out more vigorously may lead to earlier unification and fewer+iterations, so we don't take advantage of these possibilities.++Note [Rewrite insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an insoluble alpha ~ [alpha], which is insoluble+because an occurs check.  And then we unify alpha := [Int].  Then we+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can+be decomposed.  Otherwise we end up with a "Can't match [Int] ~+[[Int]]" which is true, but a bit confusing because the outer type+constructors match.++Hence:+ * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,+   simpl_loop), we feed the insolubles in solveSimpleWanteds,+   so that they get rewritten (albeit not solved).++ * We kick insolubles out of the inert set, if they can be+   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)++ * We rewrite those insolubles in GHC.Tc.Solver.Equality+   See Note [Make sure that insolubles are fully rewritten]+   in GHC.Tc.Solver.Equality+-}++{- *********************************************************************+*                                                                      *+                 Queries+*                                                                      *+*                                                                      *+********************************************************************* -}++isOuterTyVar :: TcLevel -> TyCoVar -> Bool+-- True of a type variable that comes from a+-- shallower level than the ambient level (tclvl)+isOuterTyVar tclvl tv+  | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $+                 tclvl `strictlyDeeperThan` tcTyVarLevel tv+    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from+    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't+    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,+    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby+    -- becomes "outer" even though its level numbers says it isn't.+  | otherwise  = False  -- Coercion variables; doesn't much matter++noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool+-- 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+    might_help_irred (IrredCt { ir_ev = ev })+      | EqPred ReprEq t1 t2 <- classifyPredType (ctEvPred ev)+      = headed_by_tc t1 t2+      | otherwise+      = False++    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+      = False++    headed_by_tc t1 t2+      | Just (tc1,_) <- tcSplitTyConApp_maybe t1+      , tc == tc1+      , Just (tc2,_) <- tcSplitTyConApp_maybe t2+      , tc == tc2+      = True+      | otherwise+      = False++-- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@?+--+-- Necessary (but not sufficient) conditions for this function to return @True@:+--+--   - @ct1@ and @ct2@ both arise from superclass expansion,+--   - @ct1@ is a Given and @ct2@ is a Wanted.+--+-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2).+prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ...+                          -> CtLoc -- ^ ... to solve this one?+                          -> Bool  -- ^ True ==> don't solve it+prohibitedSuperClassSolve given_loc wanted_loc+  | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc+  , blocked+  , ScOrigin _ NakedSc <- ctLocOrigin wanted_loc+  = True    -- Prohibited if the Wanted is a superclass+            -- and the Given has come via a superclass selection from+            -- a predicate bigger than the head+  | otherwise+  = False+++{- *********************************************************************+*                                                                      *+    Cycle breakers+*                                                                      *+********************************************************************* -}++-- | Push a fresh environment onto the cycle-breaker var stack. Useful+-- when entering a nested implication.+pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack+pushCycleBreakerVarStack = (emptyBag <|)++-- | Add a new cycle-breaker binding to the top environment on the stack.+addCycleBreakerBindings :: Bag (TcTyVar, Type)   -- ^ (cbv,expansion) pairs+                        -> InertSet -> InertSet+addCycleBreakerBindings prs ics+  = assertPpr (all (isCycleBreakerTyVar . fst) prs) (ppr prs) $+    ics { inert_cycle_breakers = add_to (inert_cycle_breakers ics) }+  where+    add_to (top_env :| rest_envs) = (prs `unionBags` top_env) :| rest_envs++-- | Perform a monadic operation on all pairs in the top environment+-- in the stack.+forAllCycleBreakerBindings_ :: Monad m+                            => CycleBreakerVarStack+                            -> (TcTyVar -> TcType -> m ()) -> m ()+forAllCycleBreakerBindings_ (top_env :| _rest_envs) action+  = forM_ top_env (uncurry action)+{-# INLINABLE forAllCycleBreakerBindings_ #-}  -- to allow SPECIALISE later+++{- *********************************************************************+*                                                                      *+         Solving one from another+*                                                                      *+********************************************************************* -}++data InteractResult+   = KeepInert   -- Keep the inert item, and solve the work item from it+                 -- (if the latter is Wanted; just discard it if not)+   | KeepWork    -- Keep the work item, and solve the inert item from it++instance Outputable InteractResult where+  ppr KeepInert = text "keep inert"+  ppr KeepWork  = text "keep work-item"++solveOneFromTheOther :: Ct  -- Inert    (Dict or Irred)+                     -> Ct  -- WorkItem (same predicate as inert)+                     -> InteractResult+-- Precondition:+-- * inert and work item represent evidence for the /same/ predicate+-- * Both are CDictCan or CIrredCan+--+-- 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 {} <- ev_w+  , prohibitedSuperClassSolve loc_i loc_w+  -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+  = -- Inert must be Given+    KeepWork++  | 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 (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 ...+        | 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+        | Just res <- better (not is_wsc_orig_i) (not is_wsc_orig_w)+        -> res++        -- 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 {} <- ev_i+  , prohibitedSuperClassSolve loc_w loc_i+  = KeepInert   -- Just discard the un-usable Given+                -- This never actually happens because+                -- Givens get processed first++  | CtWanted {} <- ev_i+  = KeepWork++  -- From here on both are Given+  -- See Note [Replacement vs keeping]++  | lvl_i `sameDepthAs` lvl_w+  = same_level_strategy++  | 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++     pred  = ctEvPred ev_i++     loc_i  = ctEvLoc ev_i+     loc_w  = ctEvLoc ev_w+     orig_i = ctLocOrigin loc_i+     orig_w = ctLocOrigin loc_w+     lvl_i  = ctLocLevel loc_i+     lvl_w  = ctLocLevel loc_w++     is_psc_w = isPendingScDict ct_w+     is_psc_i = isPendingScDict ct_i++     is_wsc_orig_i = isWantedSuperclassOrigin orig_i+     is_wsc_orig_w = isWantedSuperclassOrigin orig_w++     different_level_strategy  -- Both Given+       | 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 couldBeIPLike case see Note [Shadowing of implicit parameters]+       --                               in GHC.Tc.Solver.Dict++     same_level_strategy -- Both Given+       = case (orig_i, orig_w) of++           (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w)+             | blocked_i, not blocked_w -> KeepWork  -- Case 2(a) from+             | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping]++             -- Both blocked or both not blocked++             | depth_w < depth_i -> KeepWork   -- Case 2(c) from+             | otherwise         -> KeepInert  -- Note [Replacement vs keeping]++           (GivenSCOrigin {}, _) -> KeepWork  -- Case 2(b) from Note [Replacement vs keeping]++           _ -> KeepInert  -- Case 2(d) from Note [Replacement vs keeping]++{-+Note [Replacement vs keeping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have two Given constraints both of type (C tys), say, which should+we keep?  More subtle than you might think! This is all implemented in+solveOneFromTheOther.++  1) Constraints come from different levels (different_level_strategy)++      - For implicit parameters we want to keep the innermost (deepest)+        one, so that it overrides the outer one.+        See Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict++      - For everything else, we want to keep the outermost one.  Reason: that+        makes it more likely that the inner one will turn out to be unused,+        and can be reported as redundant.  See Note [Tracking redundant constraints]+        in GHC.Tc.Solver.++        It transpires that using the outermost one is responsible for an+        8% performance improvement in nofib cryptarithm2, compared to+        just rolling the dice.  I didn't investigate why.++  2) Constraints coming from the same level (i.e. same implication)++       (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. 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+           redundant constraints. This is really a generalization of point (b),+           because the superclass depth of a non-superclass constraint is 0.++           (If the levels differ, we definitely won't have both with GivenSCOrigin.)++       (d) Finally, when there is still a choice, use KeepInert rather than+           KeepWork, for two reasons:+             - to avoid unnecessary munging of the inert set.+             - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Dict++Doing the level-check for implicit parameters, rather than making the work item+always override, is important.  Consider++    data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }++    f :: (?x::a) => T a -> Int+    f T1 = ?x+    f T2 = 3++We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add+two new givens in the work-list:  [G] (?x::Int)+                                  [G] (a ~ Int)+Now consider these steps+  - process a~Int, kicking out (?x::a)+  - process (?x::Int), the inner given, adding to inert set+  - process (?x::a), the outer given, overriding the inner given+Wrong!  The level-check ensures that the inner implicit parameter wins.+(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
@@ -4,29 +4,33 @@ -- | Utility types used within the constraint solver module GHC.Tc.Solver.Types (     -- Inert CDictCans-    DictMap, emptyDictMap, findDictsByClass, addDict,-    addDictsByClass, delDict, foldDicts, filterDicts, findDict,-    dictsToBag, partitionDicts,+    DictMap, emptyDictMap,+    findDictsByTyConKey, findDictsByClass,+    foldDicts, findDict,+    dictsToBag, -    FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq,+    FunEqMap, emptyFunEqs, findFunEq, insertFunEq,     findFunEqsByTyCon,      TcAppMap, emptyTcAppMap, isEmptyTcAppMap,     insertTcApp, alterTcApp, filterTcAppMap,-    tcAppMapToBag, foldTcAppMap,+    mapMaybeTcAppMap,+    tcAppMapToBag, foldTcAppMap, delTcApp,      EqualCtList, filterEqualCtList, addToEqualCtList+   ) where  import GHC.Prelude  import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType +import GHC.Types.Unique+import GHC.Types.Unique.DFM+ import GHC.Core.Class import GHC.Core.Map.Type-import GHC.Core.Predicate import GHC.Core.TyCon import GHC.Core.TyCon.Env @@ -36,7 +40,6 @@ import GHC.Utils.Constants import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  {- ********************************************************************* *                                                                      *@@ -109,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 @@ -126,47 +139,17 @@ emptyDictMap :: DictMap a emptyDictMap = emptyTcAppMap -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a-findDict m loc cls tys-  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]-  = Nothing--  | 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-findDictsByClass m cls-  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag-  | otherwise                                     = emptyBag--delDict :: DictMap a -> Class -> [Type] -> DictMap a-delDict m cls tys = delTcApp m (classTyCon cls) tys--addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a-addDict m cls tys item = insertTcApp m (classTyCon cls) tys item--addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct-addDictsByClass m cls items-  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)-  where-    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm-    add ct _ = pprPanic "addDictsByClass" (ppr ct)--filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct-filterDicts f m = filterTcAppMap f m+findDictsByClass m cls = findDictsByTyConKey m (getUnique $ classTyCon cls) -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)-partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap)-  where-    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)-                       | otherwise = (yeses,              add ct noes)-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m-      = addDict m cls tys ct-    add ct _ = pprPanic "partitionDicts" (ppr ct)+findDictsByTyConKey :: DictMap a -> Unique -> Bag a+findDictsByTyConKey m tc+  | Just tm <- lookupUDFM_Directly m tc = foldTM consBag tm emptyBag+  | otherwise                           = emptyBag  dictsToBag :: DictMap a -> Bag a dictsToBag = tcAppMapToBag@@ -174,50 +157,6 @@ foldDicts :: (a -> b -> b) -> DictMap a -> b -> b foldDicts = foldTcAppMap -{- Note [Tuples hiding implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f,g :: (?x::Int, C a) => a -> a-   f v = let ?x = 4 in g v--The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).-We must /not/ solve this from the Given (?x::Int, C a), because of-the intervening binding for (?x::Int).  #14218.--We deal with this by arranging that we always fail when looking up a-tuple constraint that hides an implicit parameter. Note that this applies-  * both to the inert_dicts (lookupInertDict)-  * and to the solved_dicts (looukpSolvedDict)-An alternative would be not to extend these sets with such tuple-constraints, but it seemed more direct to deal with the lookup.--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 cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, 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.--}- {- ********************************************************************* *                                                                      *                    FunEqMap@@ -241,12 +180,10 @@   | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []   | otherwise                       = [] -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b-foldFunEqs = foldTcAppMap- insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a insertFunEq m tc tys val = insertTcApp m tc tys val + {- ********************************************************************* *                                                                      *                    EqualCtList@@ -264,15 +201,15 @@ contains a Given representational equality and a Wanted nominal one. -} -type EqualCtList = [Ct]+type EqualCtList = [EqCt]   -- See Note [EqualCtList invariants] -addToEqualCtList :: Ct -> EqualCtList -> EqualCtList+addToEqualCtList :: EqCt -> EqualCtList -> EqualCtList -- See Note [EqualCtList invariants] addToEqualCtList ct old_eqs   | debugIsOn   = case ct of-      CEqCan { cc_lhs = TyVarLHS tv } ->+      EqCt { eq_lhs = TyVarLHS tv } ->         assert (all (shares_lhs tv) old_eqs) $         assertPpr (null bad_prs)                   (vcat [ text "bad_prs" <+> ppr bad_prs@@ -284,10 +221,11 @@   | otherwise   = ct : old_eqs   where-    shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv+    shares_lhs tv (EqCt { eq_lhs = TyVarLHS old_tv }) = tv == old_tv     shares_lhs _ _ = False     bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))-    is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2+    is_bad_pair :: (EqCt, EqCt) -> Bool+    is_bad_pair (ct1,ct2) = eqCtFlavourRole ct1 `eqCanRewriteFR` eqCtFlavourRole ct2  distinctPairs :: [a] -> [(a,a)] -- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...]@@ -298,7 +236,7 @@ distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs  -- returns Nothing when the new list is empty, to keep the environments smaller-filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList+filterEqualCtList :: (EqCt -> Bool) -> EqualCtList -> Maybe EqualCtList filterEqualCtList pred cts   | null new_list   = Nothing
compiler/GHC/Tc/Types.hs view
@@ -1,6 +1,7 @@  {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms            #-}@@ -29,7 +30,7 @@          -- The environment types         Env(..),-        TcGblEnv(..), TcLclEnv(..),+        TcGblEnv(..), TcLclEnv(..), modifyLclCtxt, TcLclCtxt(..),         setLclEnvTcLevel, getLclEnvTcLevel,         setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode,         IfGblEnv(..), IfLclEnv(..),@@ -40,9 +41,11 @@         FrontendResult(..),          -- Renamer types-        ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin,+        ErrCtxt,         ImportAvails(..), emptyImportAvails, plusImportAvails,-        WhereFrom(..), mkModDeps,+        ImportUserSpec(..),+        ImpUserList(..),+        mkModDeps,          -- Typechecker types         TcTypeEnv, TcBinderStack, TcBinder(..),@@ -56,9 +59,15 @@         CompleteMatch, CompleteMatches,          -- Template Haskell-        ThStage(..), SpliceType(..), PendingStuff(..),-        topStage, topAnnStage, topSpliceStage,-        ThLevel, impLevel, outerLevel, thLevel,+        ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),+        topLevel, topAnnLevel, topSpliceLevel,+        ThLevelIndex,+        topLevelIndex,+        spliceLevelIndex,+        quoteLevelIndex,++        thLevelIndex,+         ForeignSrcLang(..), THDocs, DocLoc(..),         ThBindEnv, @@ -66,12 +75,15 @@         ArrowCtxt(..),          -- TcSigInfo-        TcSigFun, TcSigInfo(..), TcIdSigInfo(..),-        TcIdSigInst(..), TcPatSynInfo(..),-        isPartialSig, hasCompleteSig,+        TcSigFun,+        TcSigInfo(..), TcIdSig(..),+        TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..),+        TcIdSigInst(..),+        isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc,+        completeSigPolyId_maybe,          -- Misc other types-        TcId, TcIdSet,+        TcId,         NameShape(..),         removeBindingShadowing,         getPlatform,@@ -85,7 +97,7 @@          -- Defaulting plugin         DefaultingPlugin(..), DefaultingProposal(..),-        FillDefaulting, DefaultingPluginResult,+        FillDefaulting,          -- Role annotations         RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,@@ -102,31 +114,37 @@ import GHC.Platform  import GHC.Driver.Env+import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Core.Lint-import GHC.Driver.Session+import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Hooks +import GHC.Linker.Types+ import GHC.Hs  import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin+import GHC.Tc.Types.CtLoc( CtLoc ) import GHC.Tc.Types.Evidence-import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )+import GHC.Tc.Types.TH+import GHC.Tc.Types.TcRef+import GHC.Tc.Types.LclEnv+import GHC.Tc.Types.BasicTypes+import GHC.Tc.Types.ErrCtxt+import {-# SOURCE #-} GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin ) import GHC.Tc.Errors.Types  import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Type-import GHC.Core.TyCon  ( TyCon, tyConKind )+import GHC.Core.TyCon  ( TyCon ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.Lint   ( lintAxioms )-import GHC.Core.UsageEnv import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Predicate -import GHC.Types.Id         ( idType, idName )-import GHC.Types.FieldLabel ( FieldLabel )+import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Annotations import GHC.Types.CompleteMatch@@ -136,16 +154,12 @@ import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var-import GHC.Types.Var.Env import GHC.Types.TypeEnv-import GHC.Types.TyThing import GHC.Types.SourceFile import GHC.Types.SrcLoc-import GHC.Types.Var.Set 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@@ -159,25 +173,51 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Fingerprint-import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Logger  import GHC.Builtin.Names ( isUnboundName ) +import GHCi.Message+import GHCi.RemoteTypes+ import Data.Set      ( Set ) import qualified Data.Set as S-import Data.Map ( Map )+import qualified Data.Map as M import Data.Dynamic  ( Dynamic )+import Data.Map ( Map ) import Data.Typeable ( TypeRep ) import Data.Maybe    ( mapMaybe )-import GHCi.Message-import GHCi.RemoteTypes -import qualified Language.Haskell.TH as TH-import GHC.Driver.Env.KnotVars-import GHC.Linker.Types+-- | The import specification as written by the user, including+-- the list of explicitly imported names. Used in 'ModIface' to+-- allow GHCi to reconstruct the top level environment on demand.+--+-- This is distinct from 'ImportSpec' because we don't want to store+-- the list of explicitly imported names along with each 'GRE'+--+-- We don't want to store the entire GlobalRdrEnv for modules that+-- are imported without explicit export lists, as these may grow+-- to be very large. However, GlobalRdrEnvs which are the result+-- of explicit import lists are typically quite small.+--+-- Why do we not store something like (Maybe (ImportListInterpretation, [IE GhcPs]) in such a case?+-- Because we don't want to store source syntax including annotations in+-- interface files.+data ImportUserSpec+  = ImpUserSpec { ius_decl :: !ImpDeclSpec+                , ius_imports :: !ImpUserList+                } +data ImpUserList+  = ImpUserAll -- ^ no user import list+  | 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 -- to refine the identities of a hole while we are renaming interfaces -- (see "GHC.Iface.Rename").  Specifically, a 'NameShape' for@@ -291,9 +331,8 @@        -- See Note [Rewriter CtLoc] in GHC.Tc.Solver.Rewrite.        , re_flavour :: !CtFlavour        , re_eq_rel  :: !EqRel-       -- ^ At what role are we rewriting?-       ---       -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite+          -- ^ At what role are we rewriting?+          -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite         , re_rewriters :: !(TcRef RewriterSet)  -- ^ See Note [Wanteds rewrite Wanteds]        }@@ -439,12 +478,10 @@           -- ^ What kind of module (regular Haskell, hs-boot, hsig)          tcg_rdr_env :: GlobalRdrEnv,   -- ^ Top level envt; used during renaming-        tcg_default :: Maybe [Type],-          -- ^ Types used for defaulting. @Nothing@ => no @default@ decl+        tcg_default         :: DefaultEnv,     -- ^ All class defaults in scope in the module+        tcg_default_exports :: DefaultEnv,     -- ^ All class defaults exported from the module -        tcg_fix_env   :: FixityEnv,     -- ^ Just for things in this module-        tcg_field_env :: RecFieldEnv,   -- ^ Just for things in this module-                                        -- See Note [The interactive package] in "GHC.Runtime.Context"+        tcg_fix_env :: FixityEnv,      -- ^ Just for things in this module          tcg_type_env :: TypeEnv,           -- ^ Global type env for the module we are compiling now.  All@@ -470,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.@@ -505,10 +545,18 @@           --      (mkIfaceTc, as well as in "GHC.Driver.Main")           --    - To create the Dependencies field in interface (mkDependencies) ++          -- This field tracks the user-written imports of a module, so they can be+          -- recorded in an interface file in order to reconstruct the top-level environment+          -- if necessary for GHCi.+        tcg_import_decls :: ![ImportUserSpec],+           -- These three fields track unused bindings and imports           -- See Note [Tracking unused binding and imports]         tcg_dus       :: DefUses,         tcg_used_gres :: TcRef [GlobalRdrElt],+          -- ^ INVARIANT: all these GREs were imported; that is,+          -- they all have a non-empty gre_imp field.         tcg_keep      :: TcRef NameSet,          tcg_th_used :: TcRef Bool,@@ -520,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]@@ -532,6 +575,10 @@         tcg_dfun_n  :: TcRef OccSet,           -- ^ Allows us to choose unique DFun names. +        tcg_zany_n :: TcRef Integer,+          -- ^ A source of unique identities for ZonkAny instances+          -- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)+         tcg_merged :: [(Module, Fingerprint)],           -- ^ The requirements we merged with; we always have to recompile           -- if any of these changed.@@ -603,10 +650,8 @@         tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports         tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms -        tcg_doc_hdr   :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs-        tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the-                                             --  prog uses hpc instrumentation.-           -- NB. BangPattern is to fix a leak, see #15111+        tcg_hdr_info   :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)),+        -- ^ Maybe Haddock header docs and Maybe located module name          tcg_self_boot :: SelfBootInfo,       -- ^ Whether this module has a                                              -- corresponding hi-boot file@@ -647,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]@@ -687,22 +733,10 @@ instance ContainsModule TcGblEnv where     extractModule env = tcg_semantic_mod env -type RecFieldEnv = NameEnv [FieldLabel]-        -- Maps a constructor name *in this module*-        -- to the fields for that constructor.-        -- This is used when dealing with ".." notation in record-        -- construction and pattern matching.-        -- The FieldEnv deals *only* with constructors defined in *this*-        -- module.  For imported modules, we get the same info from the-        -- TypeEnv- data SelfBootInfo   = NoSelfBoot    -- No corresponding hi-boot file   | SelfBoot-       { sb_mds :: ModDetails   -- There was a hi-boot file,-       , sb_tcs :: NameSet }    -- defining these TyCons,--- What is sb_tcs used for?  See Note [Extra dependencies from .hs-boot files]--- in GHC.Rename.Module+       { sb_mds :: ModDetails }  -- There was a hi-boot file  bootExports :: SelfBootInfo -> NameSet bootExports boot =@@ -785,118 +819,9 @@        * GHC.Rename.Names.reportUnusedNames.  Where newtype data constructors         like (d) are imported, we don't want to report them as unused.---************************************************************************-*                                                                      *-                The local typechecker environment-*                                                                      *-************************************************************************--Note [The Global-Env/Local-Env story]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During type checking, we keep in the tcg_type_env-        * All types and classes-        * All Ids derived from types and classes (constructors, selectors)--At the end of type checking, we zonk the local bindings,-and as we do so we add to the tcg_type_env-        * Locally defined top-level Ids--Why?  Because they are now Ids not TcIds.  This final GlobalEnv is-        a) fed back (via the knot) to typechecking the-           unfoldings of interface signatures-        b) used in the ModDetails of this module -} -data TcLclEnv           -- Changes as we move inside an expression-                        -- Discarded after typecheck/rename; not passed on to desugarer-  = TcLclEnv {-        tcl_loc        :: RealSrcSpan,     -- Source span-        tcl_ctxt       :: [ErrCtxt],       -- Error context, innermost on top-        tcl_in_gen_code :: Bool,           -- See Note [Rebindable syntax and HsExpansion]-        tcl_tclvl      :: TcLevel, -        tcl_th_ctxt    :: ThStage,         -- 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)-            -- We can't put this info in the TypeEnv because it's needed-            -- (and extended) in the renamer, for untyped splices--        tcl_arrow_ctxt :: ArrowCtxt,       -- Arrow-notation context--        tcl_rdr :: LocalRdrEnv,         -- Local name envt-                -- Maintained during renaming, of course, but also during-                -- type checking, solely so that when renaming a Template-Haskell-                -- splice we have the right environment for the renamer.-                ---                --   Does *not* include global name envt; may shadow it-                --   Includes both ordinary variables and type variables;-                --   they are kept distinct because tyvar have a different-                --   occurrence constructor (Name.TvOcc)-                -- We still need the unsullied global name env so that-                --   we can look up record field names--        tcl_env  :: TcTypeEnv,    -- The local type environment:-                                  -- Ids and TyVars defined in this module--        tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here.---        tcl_bndrs :: TcBinderStack,   -- Used for reporting relevant bindings,-                                      -- and for tidying types--        tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints-        tcl_errs :: TcRef (Messages TcRnMessage)     -- Place to accumulate diagnostics-    }--setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv-setLclEnvTcLevel env lvl = env { tcl_tclvl = lvl }--getLclEnvTcLevel :: TcLclEnv -> TcLevel-getLclEnvTcLevel = tcl_tclvl--setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv-setLclEnvLoc env loc = env { tcl_loc = loc }--getLclEnvLoc :: TcLclEnv -> RealSrcSpan-getLclEnvLoc = tcl_loc--lclEnvInGeneratedCode :: TcLclEnv -> Bool-lclEnvInGeneratedCode = tcl_in_gen_code--type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))-        -- 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---- These are here to avoid module loops: one might expect them--- in GHC.Tc.Types.Constraint, but they refer to ErrCtxt which refers to TcM.--- Easier to just keep these definitions here, alongside TcM.-pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc-pushErrCtxt o err loc@(CtLoc { ctl_env = lcl })-  = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }--pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc--- Just add information w/o updating the origin!-pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl })-  = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }--type TcTypeEnv = NameEnv TcTyThing--type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)-   -- 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-   -- cross-stage at arbitrary types if the Id is bound at top level.-   ---   -- 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- {- Note [Given Insts]    ~~~~~~~~~~~~~~~~~~ Because of GADTs, we have to pass inwards the Insts provided by type signatures@@ -911,54 +836,7 @@  -} --- | Type alias for 'IORef'; the convention is we'll use this for mutable--- bits of data in 'TcGblEnv' which are updated during typechecking and--- returned at the end.-type TcRef a     = IORef a--- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'?-type TcId        = Id-type TcIdSet     = IdSet ------------------------------- The TcBinderStack------------------------------type TcBinderStack = [TcBinder]-   -- This is a stack of locally-bound ids and tyvars,-   --   innermost on top-   -- Used only in error reporting (relevantBindings in TcError),-   --   and in tidying-   -- We can't use the tcl_env type environment, because it doesn't-   --   keep track of the nesting order--data TcBinder-  = TcIdBndr-       TcId-       TopLevelFlag    -- Tells whether the binding is syntactically top-level-                       -- (The monomorphic Ids for a recursive group count-                       --  as not-top-level for this purpose.)--  | TcIdBndr_ExpType  -- Variant that allows the type to be specified as-                      -- an ExpType-       Name-       ExpType-       TopLevelFlag--  | TcTvBndr          -- e.g.   case x of P (y::a) -> blah-       Name           -- We bind the lexical name "a" to the type of y,-       TyVar          -- which might be an utterly different (perhaps-                      -- existential) tyvar--instance Outputable TcBinder where-   ppr (TcIdBndr id top_lvl)           = ppr id <> brackets (ppr top_lvl)-   ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl)-   ppr (TcTvBndr name tv)              = ppr name <+> ppr tv--instance HasOccName TcBinder where-    occName (TcIdBndr id _)             = occName (idName id)-    occName (TcIdBndr_ExpType name _ _) = occName name-    occName (TcTvBndr name _)           = occName name- -- fixes #12177 -- Builds up a list of bindings whose OccName has not been seen before -- i.e., If    ys  = removeBindingShadowing xs@@ -981,104 +859,7 @@ getPlatform :: TcRnIf a b Platform getPlatform = targetPlatform <$> getDynFlags ------------------------------- Template Haskell stages and levels---------------------------- -data SpliceType = Typed | Untyped--data ThStage    -- 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--  | RunSplice (TcRef [ForeignRef (TH.Q ())])-      -- Set when running a splice, i.e. NOT when renaming or typechecking the-      -- Haskell code for the splice. See Note [RunSplice ThLevel].-      ---      -- Contains a list of mod finalizers collected while executing the splice.-      ---      -- 'addModFinalizer' inserts finalizers here, and from here they are taken-      -- to construct an @HsSpliced@ annotation for untyped splices. See Note-      -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.-      ---      -- For typed splices, the typechecker takes finalizers from here and-      -- inserts them in the list of finalizers in the global environment.-      ---      -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice".--  | Comp        -- Ordinary Haskell code-                -- Binding level = 1--  | Brack                       -- Inside brackets-      ThStage                   --   Enclosing stage-      PendingStuff--data PendingStuff-  = RnPendingUntyped              -- Renaming the inside of an *untyped* bracket-      (TcRef [PendingRnSplice])   -- Pending splices in here--  | RnPendingTyped                -- Renaming the inside of a *typed* bracket--  | TcPending                     -- Typechecking the inside of a typed bracket-      (TcRef [PendingTcSplice])   --   Accumulate pending splices here-      (TcRef WantedConstraints)   --     and type constraints here-      QuoteWrapper                -- A type variable and evidence variable-                                  -- for the overall monad of-                                  -- the bracket. Splices are checked-                                  -- against this monad. The evidence-                                  -- variable is used for desugaring-                                  -- `lift`.---topStage, topAnnStage, topSpliceStage :: ThStage-topStage       = Comp-topAnnStage    = Splice Untyped-topSpliceStage = Splice Untyped--instance Outputable ThStage where-   ppr (Splice _)    = text "Splice"-   ppr (RunSplice _) = text "RunSplice"-   ppr Comp          = text "Comp"-   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 _) = 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-splice. In particular it is not set when the splice is renamed or typechecked.--'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert-the finalizer (see Note [Delaying modFinalizers in untyped splices]), and-'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to-set 'RunSplice' when renaming or typechecking the splice, where 'Splice',-'Brack' or 'Comp' are used instead.---}- --------------------------- -- Arrow-notation context ---------------------------@@ -1116,237 +897,6 @@ from further out in the ArrowCtxt that we push inwards. -} -data ArrowCtxt   -- Note [Escaping the arrow scope]-  = NoArrowCtxt-  | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints)--------------------------------- TcTyThing-------------------------------- | A typecheckable thing available in a local context.  Could be--- 'AGlobal' 'TyThing', but also lexically scoped variables, etc.--- See "GHC.Tc.Utils.Env" for how to retrieve a 'TyThing' given a 'Name'.-data TcTyThing-  = AGlobal TyThing             -- Used only in the return type of a lookup--  | ATcId           -- Ids defined in this module; may not be fully zonked-      { tct_id   :: TcId-      , tct_info :: IdBindingInfo   -- See Note [Meaning of IdBindingInfo]-      }--  | ATyVar  Name TcTyVar   -- See Note [Type variables in the type environment]--  | ATcTyCon TyCon   -- Used temporarily, during kind checking, for the-                     -- tycons and classes in this recursive group-                     -- The TyCon is always a TcTyCon.  Its kind-                     -- can be a mono-kind or a poly-kind; in TcTyClsDcls see-                     -- Note [Type checking recursive type and class declarations]--  | APromotionErr PromotionErr---- | Matches on either a global 'TyCon' or a 'TcTyCon'.-tcTyThingTyCon_maybe :: TcTyThing -> Maybe TyCon-tcTyThingTyCon_maybe (AGlobal (ATyCon tc)) = Just tc-tcTyThingTyCon_maybe (ATcTyCon tc_tc)      = Just tc_tc-tcTyThingTyCon_maybe _                     = Nothing--instance Outputable TcTyThing where     -- Debugging only-   ppr (AGlobal g)      = ppr g-   ppr elt@(ATcId {})   = text "Identifier" <>-                          brackets (ppr (tct_id elt) <> dcolon-                                 <> ppr (varType (tct_id elt)) <> comma-                                 <+> ppr (tct_info elt))-   ppr (ATyVar n tv)    = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv-                            <+> dcolon <+> ppr (varType tv)-   ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)-   ppr (APromotionErr err) = text "APromotionErr" <+> ppr err---- | IdBindingInfo describes how an Id is bound.------ It is used for the following purposes:--- a) for static forms in 'GHC.Tc.Gen.Expr.checkClosedInStaticForm' and--- b) to figure out when a nested binding can be generalised,---    in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'.----data IdBindingInfo -- See Note [Meaning of IdBindingInfo]-    = NotLetBound-    | ClosedLet-    | NonClosedLet-         RhsNames        -- Used for (static e) checks only-         ClosedTypeId    -- Used for generalisation checks-                         -- and for (static e) checks---- | IsGroupClosed describes a group of mutually-recursive bindings-data IsGroupClosed-  = IsGroupClosed-      (NameEnv RhsNames)  -- Free var info for the RHS of each binding in the group-                          -- Used only for (static e) checks--      ClosedTypeId        -- True <=> all the free vars of the group are-                          --          imported or ClosedLet or-                          --          NonClosedLet with ClosedTypeId=True.-                          --          In particular, no tyvars, no NotLetBound--type RhsNames = NameSet   -- Names of variables, mentioned on the RHS of-                          -- a definition, that are not Global or ClosedLet--type ClosedTypeId = Bool-  -- See Note [Meaning of IdBindingInfo]--{- Note [Meaning of IdBindingInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NotLetBound means that-  the Id is not let-bound (e.g. it is bound in a-  lambda-abstraction or in a case pattern)--ClosedLet means that-   - The Id is let-bound,-   - Any free term variables are also Global or ClosedLet-   - Its type has no free variables (NB: a top-level binding subject-     to the MR might have free vars in its type)-   These ClosedLets can definitely be floated to top level; and we-   may need to do so for static forms.--   Property:   ClosedLet-             is equivalent to-               NonClosedLet emptyNameSet True--(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that-   - The Id is let-bound--   - The fvs::RhsNames contains the free names of the RHS,-     excluding Global and ClosedLet ones.--   - For the ClosedTypeId field see Note [Bindings with closed types: ClosedTypeId]--For (static e) to be valid, we need for every 'x' free in 'e',-that x's binding is floatable to the top level.  Specifically:-   * x's RhsNames must be empty-   * x's type has no free variables-See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm.-Actually knowing x's RhsNames (rather than just its emptiness-or otherwise) is just so we can produce better error messages--Note [Bindings with closed types: ClosedTypeId]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  f x = let g ys = map not ys-        in ...--Can we generalise 'g' under the OutsideIn algorithm?  Yes,-because all g's free variables are top-level; that is they themselves-have no free type variables, and it is the type variables in the-environment that makes things tricky for OutsideIn generalisation.--Here's the invariant:-   If an Id has ClosedTypeId=True (in its IdBindingInfo), then-   the Id's type is /definitely/ closed (has no free type variables).-   Specifically,-       a) The Id's actual type is closed (has no free tyvars)-       b) Either the Id has a (closed) user-supplied type signature-          or all its free variables are Global/ClosedLet-             or NonClosedLet with ClosedTypeId=True.-          In particular, none are NotLetBound.--Why is (b) needed?   Consider-    \x. (x :: Int, let y = x+1 in ...)-Initially x::alpha.  If we happen to typecheck the 'let' before the-(x::Int), y's type will have a free tyvar; but if the other way round-it won't.  So we treat any let-bound variable with a free-non-let-bound variable as not ClosedTypeId, regardless of what the-free vars of its type actually are.--But if it has a signature, all is well:-   \x. ...(let { y::Int; y = x+1 } in-           let { v = y+2 } in ...)...-Here the signature on 'v' makes 'y' a ClosedTypeId, so we can-generalise 'v'.--Note that:--  * A top-level binding may not have ClosedTypeId=True, if it suffers-    from the MR--  * A nested binding may be closed (eg 'g' in the example we started-    with). Indeed, that's the point; whether a function is defined at-    top level or nested is orthogonal to the question of whether or-    not it is closed.--  * A binding may be non-closed because it mentions a lexically scoped-    *type variable*  Eg-        f :: forall a. blah-        f x = let g y = ...(y::a)...--Under OutsideIn we are free to generalise an Id all of whose free-variables have ClosedTypeId=True (or imported).  This is an extension-compared to the JFP paper on OutsideIn, which used "top-level" as a-proxy for "closed".  (It's not a good proxy anyway -- the MR can make-a top-level binding with a free type variable.)--Note [Type variables in the type environment]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The type environment has a binding for each lexically-scoped-type variable that is in scope.  For example--  f :: forall a. a -> a-  f x = (x :: a)--  g1 :: [a] -> a-  g1 (ys :: [b]) = head ys :: b--  g2 :: [Int] -> Int-  g2 (ys :: [c]) = head ys :: c--* The forall'd variable 'a' in the signature scopes over f's RHS.--* The pattern-bound type variable 'b' in 'g1' scopes over g1's-  RHS; note that it is bound to a skolem 'a' which is not itself-  lexically in scope.--* The pattern-bound type variable 'c' in 'g2' is bound to-  Int; that is, pattern-bound type variables can stand for-  arbitrary types. (see-    GHC proposal #128 "Allow ScopedTypeVariables to refer to types"-    https://github.com/ghc-proposals/ghc-proposals/pull/128,-  and the paper-    "Type variables in patterns", Haskell Symposium 2018.---This is implemented by the constructor-   ATyVar Name TcTyVar-in the type environment.--* The Name is the name of the original, lexically scoped type-  variable--* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes-  a unification variable (like in 'g1', 'g2').  We never zonk the-  type environment so in the latter case it always stays as a-  unification variable, although that variable may be later-  unified with a type (such as Int in 'g2').--}--instance Outputable IdBindingInfo where-  ppr NotLetBound = text "NotLetBound"-  ppr ClosedLet = text "TopLevelLet"-  ppr (NonClosedLet fvs closed_type) =-    text "TopLevelLet" <+> ppr fvs <+> ppr closed_type-----------------pprTcTyThingCategory :: TcTyThing -> SDoc-pprTcTyThingCategory = text . capitalise . tcTyThingCategory--tcTyThingCategory :: TcTyThing -> String-tcTyThingCategory (AGlobal thing)    = tyThingCategory thing-tcTyThingCategory (ATyVar {})        = "type variable"-tcTyThingCategory (ATcId {})         = "local identifier"-tcTyThingCategory (ATcTyCon {})      = "local tycon"-tcTyThingCategory (APromotionErr pe) = peCategory pe- {- ************************************************************************ *                                                                      *@@ -1362,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@@ -1377,7 +941,7 @@       -- perf/compiler/MultiLayerModules  emptyImportAvails :: ImportAvails-emptyImportAvails = ImportAvails { imp_mods          = emptyModuleEnv,+emptyImportAvails = ImportAvails { imp_mods          = M.empty,                                    imp_direct_dep_mods = emptyInstalledModuleEnv,                                    imp_dep_direct_pkgs = S.empty,                                    imp_sig_mods      = [],@@ -1408,8 +972,8 @@                   imp_sig_mods = sig_mods2,                   imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,                   imp_orphs = orphs2, imp_finsts = finsts2 })-  = ImportAvails { imp_mods          = plusModuleEnv_C (++) mods1 mods2,-                   imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2,+  = ImportAvails { imp_mods          = M.unionWith (++) mods1 mods2,+                   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,@@ -1418,214 +982,7 @@                    imp_orphs         = unionListsOrd orphs1 orphs2,                    imp_finsts        = unionListsOrd finsts1 finsts2 } -{--************************************************************************-*                                                                      *-\subsection{Where from}-*                                                                      *-************************************************************************ -The @WhereFrom@ type controls where the renamer looks for an interface file--}--data WhereFrom-  = ImportByUser IsBootInterface        -- Ordinary user import (perhaps {-# SOURCE #-})-  | ImportBySystem                      -- Non user import.-  | ImportByPlugin                      -- Importing a plugin;-                                        -- See Note [Care with plugin imports] in GHC.Iface.Load--instance Outputable WhereFrom where-  ppr (ImportByUser IsBoot)                = text "{- SOURCE -}"-  ppr (ImportByUser NotBoot)               = empty-  ppr ImportBySystem                       = text "{- SYSTEM -}"-  ppr ImportByPlugin                       = text "{- PLUGIN -}"---{- *********************************************************************-*                                                                      *-                Type signatures-*                                                                      *-********************************************************************* -}---- These data types need to be here only because--- GHC.Tc.Solver uses them, and GHC.Tc.Solver is fairly--- low down in the module hierarchy--type TcSigFun  = Name -> Maybe TcSigInfo--data TcSigInfo = TcIdSig     TcIdSigInfo-               | TcPatSynSig TcPatSynInfo--data TcIdSigInfo   -- See Note [Complete and partial type signatures]-  = CompleteSig    -- A complete signature with no wildcards,-                   -- so the complete polymorphic type is known.-      { sig_bndr :: TcId          -- The polymorphic Id with that type--      , sig_ctxt :: UserTypeCtxt  -- In the case of type-class default methods,-                                  -- the Name in the FunSigCtxt is not the same-                                  -- as the TcId; the former is 'op', while the-                                  -- latter is '$dmop' or some such--      , sig_loc  :: SrcSpan       -- Location of the type signature-      }--  | PartialSig     -- A partial type signature (i.e. includes one or more-                   -- wildcards). In this case it doesn't make sense to give-                   -- the polymorphic Id, because we are going to /infer/ its-                   -- type, so we can't make the polymorphic Id ab-initio-      { psig_name  :: Name   -- Name of the function; used when report wildcards-      , psig_hs_ty :: LHsSigWcType GhcRn  -- The original partial signature in-                                          -- HsSyn form-      , sig_ctxt   :: UserTypeCtxt-      , sig_loc    :: SrcSpan            -- Location of the type signature-      }---{- Note [Complete and partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A type signature is partial when it contains one or more wildcards-(= type holes).  The wildcard can either be:-* A (type) wildcard occurring in sig_theta or sig_tau. These are-  stored in sig_wcs.-      f :: Bool -> _-      g :: Eq _a => _a -> _a -> Bool-* Or an extra-constraints wildcard, stored in sig_cts:-      h :: (Num a, _) => a -> a--A type signature is a complete type signature when there are no-wildcards in the type signature, i.e. iff sig_wcs is empty and-sig_extra_cts is Nothing.--}--data TcIdSigInst-  = TISI { sig_inst_sig :: TcIdSigInfo--         , sig_inst_skols :: [(Name, InvisTVBinder)]-               -- Instantiated type and kind variables, TyVarTvs-               -- The Name is the Name that the renamer chose;-               --   but the TcTyVar may come from instantiating-               --   the type and hence have a different unique.-               -- No need to keep track of whether they are truly lexically-               --   scoped because the renamer has named them uniquely-               -- See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig-               ---               -- NB: The order of sig_inst_skols is irrelevant-               --     for a CompleteSig, but for a PartialSig see-               --     Note [Quantified variables in partial type signatures]--         , sig_inst_theta  :: TcThetaType-               -- Instantiated theta.  In the case of a-               -- PartialSig, sig_theta does not include-               -- the extra-constraints wildcard--         , sig_inst_tau :: TcSigmaType   -- Instantiated tau-               -- See Note [sig_inst_tau may be polymorphic]--         -- Relevant for partial signature only-         , sig_inst_wcs   :: [(Name, TcTyVar)]-               -- Like sig_inst_skols, but for /named/ wildcards (_a etc).-               -- The named wildcards scope over the binding, and hence-               -- their Names may appear in type signatures in the binding--         , sig_inst_wcx   :: Maybe TcType-               -- Extra-constraints wildcard to fill in, if any-               -- If this exists, it is surely of the form (meta_tv |> co)-               -- (where the co might be reflexive). This is filled in-               -- only from the return value of GHC.Tc.Gen.HsType.tcAnonWildCardOcc-         }--{- Note [sig_inst_tau may be polymorphic]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note that "sig_inst_tau" might actually be a polymorphic type,-if the original function had a signature like-   forall a. Eq a => forall b. Ord b => ....-But that's ok: tcMatchesFun (called by tcRhs) can deal with that-It happens, too!  See Note [Polymorphic methods] in GHC.Tc.TyCl.Class.--Note [Quantified variables in partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f :: forall a b. _ -> a -> _ -> b-   f (x,y) p q = q--Then we expect f's final type to be-  f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b--Note that x,y are Inferred, and can't be use for visible type-application (VTA).  But a,b are Specified, and remain Specified-in the final type, so we can use VTA for them.  (Exception: if-it turns out that a's kind mentions b we need to reorder them-with scopedSort.)--The sig_inst_skols of the TISI from a partial signature records-that original order, and is used to get the variables of f's-final type in the correct order.---Note [Wildcards in partial signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wildcards in psig_wcs may stand for a type mentioning-the universally-quantified tyvars of psig_ty--E.g.  f :: forall a. _ -> a-      f x = x-We get sig_inst_skols = [a]-       sig_inst_tau   = _22 -> a-       sig_inst_wcs   = [_22]-and _22 in the end is unified with the type 'a'--Moreover the kind of a wildcard in sig_inst_wcs may mention-the universally-quantified tyvars sig_inst_skols-e.g.   f :: t a -> t _-Here we get-   sig_inst_skols = [k:*, (t::k ->*), (a::k)]-   sig_inst_tau   = t a -> t _22-   sig_inst_wcs   = [ _22::k ]--}--data TcPatSynInfo-  = TPSI {-        patsig_name           :: Name,-        patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and-                                                  -- implicitly-bound type vars (Specified)-          -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn-        patsig_univ_bndrs     :: [InvisTVBinder], -- Bound by explicit user forall-        patsig_req            :: TcThetaType,-        patsig_ex_bndrs       :: [InvisTVBinder], -- Bound by explicit user forall-        patsig_prov           :: TcThetaType,-        patsig_body_ty        :: TcSigmaType-    }--instance Outputable TcSigInfo where-  ppr (TcIdSig     idsi) = ppr idsi-  ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi--instance Outputable TcIdSigInfo where-    ppr (CompleteSig { sig_bndr = bndr })-        = ppr bndr <+> dcolon <+> ppr (idType bndr)-    ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty })-        = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty--instance Outputable TcIdSigInst where-    ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols-              , sig_inst_theta = theta, sig_inst_tau = tau })-        = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])--instance Outputable TcPatSynInfo where-    ppr (TPSI{ patsig_name = name}) = ppr name--isPartialSig :: TcIdSigInst -> Bool-isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True-isPartialSig _                                       = False---- | No signature or a partial signature-hasCompleteSig :: TcSigFun -> Name -> Bool-hasCompleteSig sig_fn name-  = case sig_fn name of-      Just (TcIdSig (CompleteSig {})) -> True-      _                               -> False-- {- Constraint Solver Plugins -------------------------@@ -1679,7 +1036,7 @@     -- and possibly emit additional constraints. These returned constraints     -- must be Givens in the first case, and Wanteds in the second.     ---    -- Use @ \\ _ _ _ _ _ -> pure $ TcPluginOK [] [] @ if your plugin+    -- Use @ \\ _ _ _ _ -> pure $ TcPluginOk [] [] @ if your plugin     -- does not provide this functionality.    , tcPluginRewrite :: s -> UniqFM TyCon TcPluginRewriter@@ -1756,24 +1113,20 @@     , tcRewriterNewWanteds :: [Ct]     } --- | A collection of candidate default types for a type variable.+-- | A collection of candidate default types for sets of type variables. data DefaultingProposal   = DefaultingProposal-    { deProposalTyVar :: TcTyVar-      -- ^ The type variable to default.-    , deProposalCandidates :: [Type]-      -- ^ Candidate types to default the type variable to.+    { deProposals :: [[(TcTyVar, Type)]]+      -- ^ The type variable assignments to try.     , deProposalCts :: [Ct]       -- ^ The constraints against which defaults are checked.     }  instance Outputable DefaultingProposal where   ppr p = text "DefaultingProposal"-          <+> ppr (deProposalTyVar p)-          <+> ppr (deProposalCandidates p)+          <+> ppr (deProposals p)           <+> ppr (deProposalCts p) -type DefaultingPluginResult = [DefaultingProposal] type FillDefaulting   = WantedConstraints       -- Zonked constraints containing the unfilled metavariables that
− compiler/GHC/Tc/Types.hs-boot 
@@ -1,24 +0,0 @@-module GHC.Tc.Types where--import GHC.Prelude-import GHC.Tc.Utils.TcType-import GHC.Types.SrcLoc-import GHC.Utils.Outputable--data TcLclEnv--data SelfBootInfo--data TcIdSigInfo-instance Outputable TcIdSigInfo--data TcTyThing-instance Outputable TcTyThing--setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv-getLclEnvTcLevel :: TcLclEnv -> TcLevel--setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv-getLclEnvLoc :: TcLclEnv -> RealSrcSpan--lclEnvInGeneratedCode :: TcLclEnv -> Bool
+ compiler/GHC/Tc/Types/BasicTypes.hs view
@@ -0,0 +1,524 @@+module GHC.Tc.Types.BasicTypes (+  -- * TcBinder+    TcBinderStack+  , TcId+  , TcBinder(..)++  -- * Signatures+  , TcSigFun, TcSigInfo(..), TcIdSig(..)+  , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..)+  , TcIdSigInst(..)+  , isPartialSig, hasCompleteSig+  , tcSigInfoName, tcIdSigLoc, completeSigPolyId_maybe++  -- * TcTyThing+  , TcTyThing(..)+  , IdBindingInfo(..)+  , IsGroupClosed(..)+  , RhsNames+  , ClosedTypeId+  , tcTyThingCategory+  , tcTyThingTyCon_maybe+  , pprTcTyThingCategory+  ) where++import GHC.Prelude++import GHC.Tc.Types.Origin( UserTypeCtxt )+import GHC.Tc.Utils.TcType++import GHC.Types.Id+import GHC.Types.Basic+import GHC.Types.Var+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.TyThing+import GHC.Types.Name.Env+import GHC.Types.Name.Set++import GHC.Hs.Extension ( GhcRn )++import Language.Haskell.Syntax.Type ( LHsSigWcType )++import GHC.Tc.Errors.Types.PromotionErr (PromotionErr, peCategory)++import GHC.Core.TyCon  ( TyCon, tyConKind )+import GHC.Utils.Outputable+import GHC.Utils.Misc+++---------------------------+-- The TcBinderStack+---------------------------++type TcBinderStack = [TcBinder]+type TcId = Id+   -- This is a stack of locally-bound ids and tyvars,+   --   innermost on top+   -- Used only in error reporting (relevantBindings in TcError),+   --   and in tidying+   -- We can't use the tcl_env type environment, because it doesn't+   --   keep track of the nesting order++data TcBinder+  = TcIdBndr+       TcId+       TopLevelFlag    -- Tells whether the binding is syntactically top-level+                       -- (The monomorphic Ids for a recursive group count+                       --  as not-top-level for this purpose.)++  | TcIdBndr_ExpType  -- Variant that allows the type to be specified as+                      -- an ExpType+       Name+       ExpType+       TopLevelFlag++  | TcTvBndr          -- e.g.   case x of P (y::a) -> blah+       Name           -- We bind the lexical name "a" to the type of y,+       TyVar          -- which might be an utterly different (perhaps+                      -- existential) tyvar++instance Outputable TcBinder where+   ppr (TcIdBndr id top_lvl)           = ppr id <> brackets (ppr top_lvl)+   ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl)+   ppr (TcTvBndr name tv)              = ppr name <+> ppr tv++instance HasOccName TcBinder where+    occName (TcIdBndr id _)             = occName (idName id)+    occName (TcIdBndr_ExpType name _ _) = occName name+    occName (TcTvBndr name _)           = occName name++{- *********************************************************************+*                                                                      *+                Type signatures+*                                                                      *+********************************************************************* -}++-- These data types need to be here only because+-- GHC.Tc.Solver uses them, and GHC.Tc.Solver is fairly+-- low down in the module hierarchy++type TcSigFun  = Name -> Maybe TcSigInfo++-- TcSigInfo is simply the range of TcSigFun+data TcSigInfo = TcIdSig     TcIdSig+               | TcPatSynSig TcPatSynSig    -- For a pattern synonym++-- See Note [Complete and partial type signatures]+data TcIdSig  -- For an Id+  = TcCompleteSig TcCompleteSig+  | TcPartialSig  TcPartialSig++data TcCompleteSig  -- A complete signature with no wildcards,+                    -- so the complete polymorphic type is known.+  = CSig { sig_bndr :: TcId          -- The polymorphic Id with that type++         , sig_ctxt :: UserTypeCtxt  -- In the case of type-class default methods,+                                     -- the Name in the FunSigCtxt is not the same+                                     -- as the TcId; the former is 'op', while the+                                     -- latter is '$dmop' or some such++         , sig_loc  :: SrcSpan       -- Location of the type signature+         }++data TcPartialSig  -- A partial type signature (i.e. includes one or more+                   -- wildcards). In this case it doesn't make sense to give+                   -- the polymorphic Id, because we are going to /infer/ its+                   -- type, so we can't make the polymorphic Id ab-initio+  = PSig { psig_name  :: Name   -- Name of the function; used when report wildcards+         , psig_hs_ty :: LHsSigWcType GhcRn  -- The original partial signature in+                                             -- HsSyn form+         , psig_ctxt  :: UserTypeCtxt+         , psig_loc   :: SrcSpan            -- Location of the type signature+         }++data TcPatSynSig+  = PatSig {+        patsig_name           :: Name,+        patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and+                                                  -- implicitly-bound type vars (Specified)+          -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn+        patsig_univ_bndrs     :: [InvisTVBinder], -- Bound by explicit user forall+        patsig_req            :: TcThetaType,+        patsig_ex_bndrs       :: [InvisTVBinder], -- Bound by explicit user forall+        patsig_prov           :: TcThetaType,+        patsig_body_ty        :: TcSigmaType+    }++{- Note [Complete and partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type signature is partial when it contains one or more wildcards+(= type holes).  The wildcard can either be:+* A (type) wildcard occurring in sig_theta or sig_tau. These are+  stored in sig_wcs.+      f :: Bool -> _+      g :: Eq _a => _a -> _a -> Bool+* Or an extra-constraints wildcard, stored in sig_cts:+      h :: (Num a, _) => a -> a++A type signature is a complete type signature when there are no+wildcards in the type signature, i.e. iff sig_wcs is empty and+sig_extra_cts is Nothing.+-}++data TcIdSigInst+  = TISI { sig_inst_sig :: TcIdSig++         , sig_inst_skols :: [(Name, InvisTVBinder)]+               -- Instantiated type and kind variables, TyVarTvs+               -- The Name is the Name that the renamer chose;+               --   but the TcTyVar may come from instantiating+               --   the type and hence have a different unique.+               -- No need to keep track of whether they are truly lexically+               --   scoped because the renamer has named them uniquely+               -- See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig+               --+               -- NB: The order of sig_inst_skols is irrelevant+               --     for a CompleteSig, but for a PartialSig see+               --     Note [Quantified variables in partial type signatures]++         , sig_inst_theta  :: TcThetaType+               -- Instantiated theta.  In the case of a+               -- PartialSig, sig_theta does not include+               -- the extra-constraints wildcard++         , sig_inst_tau :: TcSigmaType   -- Instantiated tau+               -- See Note [sig_inst_tau may be polymorphic]++         -- Relevant for partial signature only+         , sig_inst_wcs   :: [(Name, TcTyVar)]+               -- Like sig_inst_skols, but for /named/ wildcards (_a etc).+               -- The named wildcards scope over the binding, and hence+               -- their Names may appear in type signatures in the binding++         , sig_inst_wcx   :: Maybe TcType+               -- Extra-constraints wildcard to fill in, if any+               -- If this exists, it is surely of the form (meta_tv |> co)+               -- (where the co might be reflexive). This is filled in+               -- only from the return value of GHC.Tc.Gen.HsType.tcAnonWildCardOcc+         }++{- Note [sig_inst_tau may be polymorphic]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that "sig_inst_tau" might actually be a polymorphic type,+if the original function had a signature like+   forall a. Eq a => forall b. Ord b => ....+But that's ok: tcFunBindMatches (called by tcRhs) can deal with that+It happens, too!  See Note [Polymorphic methods] in GHC.Tc.TyCl.Class.++Note [Quantified variables in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: forall a b. _ -> a -> _ -> b+   f (x,y) p q = q++Then we expect f's final type to be+  f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b++Note that x,y are Inferred, and can't be use for visible type+application (VTA).  But a,b are Specified, and remain Specified+in the final type, so we can use VTA for them.  (Exception: if+it turns out that a's kind mentions b we need to reorder them+with scopedSort.)++The sig_inst_skols of the TISI from a partial signature records+that original order, and is used to get the variables of f's+final type in the correct order.+++Note [Wildcards in partial signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wildcards in psig_wcs may stand for a type mentioning+the universally-quantified tyvars of psig_ty++E.g.  f :: forall a. _ -> a+      f x = x+We get sig_inst_skols = [a]+       sig_inst_tau   = _22 -> a+       sig_inst_wcs   = [_22]+and _22 in the end is unified with the type 'a'++Moreover the kind of a wildcard in sig_inst_wcs may mention+the universally-quantified tyvars sig_inst_skols+e.g.   f :: t a -> t _+Here we get+   sig_inst_skols = [k:*, (t::k ->*), (a::k)]+   sig_inst_tau   = t a -> t _22+   sig_inst_wcs   = [ _22::k ]+-}++instance Outputable TcSigInfo where+  ppr (TcIdSig sig)     = ppr sig+  ppr (TcPatSynSig sig) = ppr sig++instance Outputable TcIdSig where+  ppr (TcCompleteSig sig) = ppr sig+  ppr (TcPartialSig sig)  = ppr sig++instance Outputable TcCompleteSig where+  ppr (CSig { sig_bndr = bndr })+      = ppr bndr <+> dcolon <+> ppr (idType bndr)++instance Outputable TcPartialSig where+  ppr (PSig { psig_name = name, psig_hs_ty = hs_ty })+      = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty++instance Outputable TcPatSynSig where+  ppr (PatSig { patsig_name = name}) = ppr name++instance Outputable TcIdSigInst where+  ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols+            , sig_inst_theta = theta, sig_inst_tau = tau })+      = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])++isPartialSig :: TcIdSigInst -> Bool+isPartialSig (TISI { sig_inst_sig = TcPartialSig {} }) = True+isPartialSig _                                         = False++-- | No signature or a partial signature+hasCompleteSig :: TcSigFun -> Name -> Bool+hasCompleteSig sig_fn name+  = case sig_fn name of+      Just (TcIdSig (TcCompleteSig {})) -> True+      _                                 -> False++tcSigInfoName :: TcSigInfo -> Name+tcSigInfoName (TcIdSig (TcCompleteSig sig)) = idName (sig_bndr sig)+tcSigInfoName (TcIdSig (TcPartialSig  sig)) = psig_name sig+tcSigInfoName (TcPatSynSig sig)             = patsig_name sig++tcIdSigLoc :: TcIdSig -> SrcSpan+tcIdSigLoc (TcCompleteSig sig) = sig_loc sig+tcIdSigLoc (TcPartialSig  sig) = psig_loc sig++completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId+completeSigPolyId_maybe (TcIdSig (TcCompleteSig sig)) = Just (sig_bndr sig)+completeSigPolyId_maybe _                             = Nothing++{- *********************************************************************+*                                                                      *+             TcTyThing+*                                                                      *+********************************************************************* -}++-- | A typecheckable thing available in a local context.  Could be+-- 'AGlobal' 'TyThing', but also lexically scoped variables, etc.+-- See "GHC.Tc.Utils.Env" for how to retrieve a 'TyThing' given a 'Name'.+data TcTyThing+  = AGlobal TyThing             -- Used only in the return type of a lookup++  | ATcId           -- Ids defined in this module; may not be fully zonked+      { tct_id   :: Id+      , tct_info :: IdBindingInfo   -- See Note [Meaning of IdBindingInfo]+      }++  | ATyVar  Name TcTyVar   -- See Note [Type variables in the type environment]++  | ATcTyCon TyCon   -- Used temporarily, during kind checking, for the+                     -- tycons and classes in this recursive group+                     -- The TyCon is always a TcTyCon.  Its kind+                     -- can be a mono-kind or a poly-kind; in TcTyClsDcls see+                     -- Note [Type checking recursive type and class declarations]++  | APromotionErr PromotionErr++-- | Matches on either a global 'TyCon' or a 'TcTyCon'.+tcTyThingTyCon_maybe :: TcTyThing -> Maybe TyCon+tcTyThingTyCon_maybe (AGlobal (ATyCon tc)) = Just tc+tcTyThingTyCon_maybe (ATcTyCon tc_tc)      = Just tc_tc+tcTyThingTyCon_maybe _                     = Nothing++instance Outputable TcTyThing where     -- Debugging only+   ppr (AGlobal g)      = ppr g+   ppr elt@(ATcId {})   = text "Identifier" <>+                          brackets (ppr (tct_id elt) <> dcolon+                                 <> ppr (varType (tct_id elt)) <> comma+                                 <+> ppr (tct_info elt))+   ppr (ATyVar n tv)    = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv+                            <+> dcolon <+> ppr (varType tv)+   ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)+   ppr (APromotionErr err) = text "APromotionErr" <+> ppr err++-- | IdBindingInfo describes how an Id is bound.+--+-- It is used for the following purposes:+-- a) for static forms in 'GHC.Tc.Gen.Expr.checkClosedInStaticForm' and+-- b) to figure out when a nested binding can be generalised,+--    in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'.+--+data IdBindingInfo -- See Note [Meaning of IdBindingInfo]+    = NotLetBound+    | ClosedLet+    | NonClosedLet+         RhsNames        -- Used for (static e) checks only+         ClosedTypeId    -- Used for generalisation checks+                         -- and for (static e) checks++-- | IsGroupClosed describes a group of mutually-recursive bindings+data IsGroupClosed+  = IsGroupClosed+      (NameEnv RhsNames)  -- Free var info for the RHS of each binding in the group+                          -- Used only for (static e) checks++      ClosedTypeId        -- True <=> all the free vars of the group are+                          --          imported or ClosedLet or+                          --          NonClosedLet with ClosedTypeId=True.+                          --          In particular, no tyvars, no NotLetBound++type RhsNames = NameSet   -- Names of variables, mentioned on the RHS of+                          -- a definition, that are not Global or ClosedLet++type ClosedTypeId = Bool+  -- See Note [Meaning of IdBindingInfo]++{- Note [Meaning of IdBindingInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NotLetBound means that+  the Id is not let-bound (e.g. it is bound in a+  lambda-abstraction or in a case pattern)++ClosedLet means that+   - The Id is let-bound,+   - Any free term variables are also Global or ClosedLet+   - Its type has no free variables (NB: a top-level binding subject+     to the MR might have free vars in its type)+   These ClosedLets can definitely be floated to top level; and we+   may need to do so for static forms.++   Property:   ClosedLet+             is equivalent to+               NonClosedLet emptyNameSet True++(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that+   - The Id is let-bound++   - The fvs::RhsNames contains the free names of the RHS,+     excluding Global and ClosedLet ones.++   - For the ClosedTypeId field see Note [Bindings with closed types: ClosedTypeId]++For (static e) to be valid, we need for every 'x' free in 'e',+that x's binding is floatable to the top level.  Specifically:+   * x's RhsNames must be empty+   * x's type has no free variables+See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm.+Actually knowing x's RhsNames (rather than just its emptiness+or otherwise) is just so we can produce better error messages++Note [Bindings with closed types: ClosedTypeId]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  f x = let g ys = map not ys+        in ...++Can we generalise 'g' under the OutsideIn algorithm?  Yes,+because all g's free variables are top-level; that is they themselves+have no free type variables, and it is the type variables in the+environment that makes things tricky for OutsideIn generalisation.++Here's the invariant:+   If an Id has ClosedTypeId=True (in its IdBindingInfo), then+   the Id's type is /definitely/ closed (has no free type variables).+   Specifically,+       a) The Id's actual type is closed (has no free tyvars)+       b) Either the Id has a (closed) user-supplied type signature+          or all its free variables are Global/ClosedLet+             or NonClosedLet with ClosedTypeId=True.+          In particular, none are NotLetBound.++Why is (b) needed?   Consider+    \x. (x :: Int, let y = x+1 in ...)+Initially x::alpha.  If we happen to typecheck the 'let' before the+(x::Int), y's type will have a free tyvar; but if the other way round+it won't.  So we treat any let-bound variable with a free+non-let-bound variable as not ClosedTypeId, regardless of what the+free vars of its type actually are.++But if it has a signature, all is well:+   \x. ...(let { y::Int; y = x+1 } in+           let { v = y+2 } in ...)...+Here the signature on 'v' makes 'y' a ClosedTypeId, so we can+generalise 'v'.++Note that:++  * A top-level binding may not have ClosedTypeId=True, if it suffers+    from the MR++  * A nested binding may be closed (eg 'g' in the example we started+    with). Indeed, that's the point; whether a function is defined at+    top level or nested is orthogonal to the question of whether or+    not it is closed.++  * A binding may be non-closed because it mentions a lexically scoped+    *type variable*  Eg+        f :: forall a. blah+        f x = let g y = ...(y::a)...++Under OutsideIn we are free to generalise an Id all of whose free+variables have ClosedTypeId=True (or imported).  This is an extension+compared to the JFP paper on OutsideIn, which used "top-level" as a+proxy for "closed".  (It's not a good proxy anyway -- the MR can make+a top-level binding with a free type variable.)++Note [Type variables in the type environment]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type environment has a binding for each lexically-scoped+type variable that is in scope.  For example++  f :: forall a. a -> a+  f x = (x :: a)++  g1 :: [a] -> a+  g1 (ys :: [b]) = head ys :: b++  g2 :: [Int] -> Int+  g2 (ys :: [c]) = head ys :: c++* The forall'd variable 'a' in the signature scopes over f's RHS.++* The pattern-bound type variable 'b' in 'g1' scopes over g1's+  RHS; note that it is bound to a skolem 'a' which is not itself+  lexically in scope.++* The pattern-bound type variable 'c' in 'g2' is bound to+  Int; that is, pattern-bound type variables can stand for+  arbitrary types. (see+    GHC proposal #128 "Allow ScopedTypeVariables to refer to types"+    https://github.com/ghc-proposals/ghc-proposals/pull/128,+  and the paper+    "Type variables in patterns", Haskell Symposium 2018.+++This is implemented by the constructor+   ATyVar Name TcTyVar+in the type environment.++* The Name is the name of the original, lexically scoped type+  variable++* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes+  a unification variable (like in 'g1', 'g2').  We never zonk the+  type environment so in the latter case it always stays as a+  unification variable, although that variable may be later+  unified with a type (such as Int in 'g2').+-}++instance Outputable IdBindingInfo where+  ppr NotLetBound = text "NotLetBound"+  ppr ClosedLet = text "TopLevelLet"+  ppr (NonClosedLet fvs closed_type) =+    text "TopLevelLet" <+> ppr fvs <+> ppr closed_type++--------------+pprTcTyThingCategory :: TcTyThing -> SDoc+pprTcTyThingCategory = text . capitalise . tcTyThingCategory++tcTyThingCategory :: TcTyThing -> String+tcTyThingCategory (AGlobal thing)    = tyThingCategory thing+tcTyThingCategory (ATyVar {})        = "type variable"+tcTyThingCategory (ATcId {})         = "local identifier"+tcTyThingCategory (ATcTyCon {})      = "local tycon"+tcTyThingCategory (APromotionErr pe) = peCategory pe
compiler/GHC/Tc/Types/Constraint.hs view
@@ -1,2450 +1,2739 @@--{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeApplications #-}---- | This module defines types and simple operations over constraints, as used--- in the type-checker and constraint solver.-module GHC.Tc.Types.Constraint (-        -- QCInst-        QCInst(..), pendingScInst_maybe,--        -- Canonical constraints-        Xi, Ct(..), Cts,-        emptyCts, andCts, andManyCts, pprCts,-        singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,-        isEmptyCts,-        isPendingScDict, pendingScDict_maybe,-        superClassesMightHelp, getPendingWantedScs,-        isWantedCt, isGivenCt,-        isUserTypeError, getUserTypeErrorMsg,-        ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,-        ctRewriters,-        ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv,-        mkNonCanonical, mkNonCanonicalCt, mkGivens,-        mkIrredCt,-        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,-        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,-        ctEvRewriters,-        tyCoVarsOfCt, tyCoVarsOfCts,-        tyCoVarsOfCtList, tyCoVarsOfCtsList,--        CtIrredReason(..), isInsolubleReason,--        CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,-        cteOK, cteImpredicative, cteTypeFamily,-        cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,--        cterHasNoProblem, cterHasProblem, cterHasOnlyProblem,-        cterRemoveProblem, cterHasOccursCheck, cterFromKind,--        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,-        eqCanEqLHS,--        Hole(..), HoleSort(..), isOutOfScopeHole,-        DelayedError(..), NotConcreteError(..),-        NotConcreteReason(..),--        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,-        isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,-        addInsols, dropMisleading, addSimples, addImplics, addHoles,-        addNotConcreteError, addDelayedErrors,-        tyCoVarsOfWC,-        tyCoVarsOfWCList, insolubleWantedCt, insolubleEqCt, insolubleCt,-        insolubleImplic, nonDefaultableTyVarsOfWC,--        Implication(..), implicationPrototype, checkTelescopeSkol,-        ImplicStatus(..), isInsolubleStatus, isSolvedStatus,-        UserGiven, getUserGivensFromImplics,-        HasGivenEqs(..), checkImplicationInvariants,-        SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,-        bumpSubGoalDepth, subGoalDepthExceeded,-        CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,-        ctLocTypeOrKind_maybe,-        ctLocDepth, bumpCtLocDepth, isGivenLoc,-        setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,-        pprCtLoc,--        -- CtEvidence-        CtEvidence(..), TcEvDest(..),-        mkKindLoc, toKindLoc, mkGivenLoc,-        isWanted, isGiven,-        ctEvRole, setCtEvPredType, setCtEvLoc,-        tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,-        ctEvUnique, tcEvDestUnique,--        RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet,-           -- exported concretely only for anyUnfilledCoercionHoles-        rewriterSetFromType, rewriterSetFromTypes, rewriterSetFromCo,-        addRewriterSet,--        wrapType,--        CtFlavour(..), ctEvFlavour,-        CtFlavourRole, ctEvFlavourRole, ctFlavourRole,-        eqCanRewrite, eqCanRewriteFR,--        -- Pretty printing-        pprEvVarTheta,-        pprEvVars, pprEvVarWithType,--  )-  where--import GHC.Prelude--import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel-                                   , setLclEnvLoc, getLclEnvLoc )--import GHC.Core.Predicate-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Types.Name-import GHC.Types.Var--import GHC.Tc.Utils.TcType-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.Origin--import GHC.Core--import GHC.Core.TyCo.Ppr-import GHC.Utils.FV-import GHC.Types.Var.Set-import GHC.Driver.Session-import GHC.Types.Basic-import GHC.Types.Unique-import GHC.Types.Unique.Set--import GHC.Utils.Outputable-import GHC.Types.SrcLoc-import GHC.Data.Bag-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Types.Name.Reader--import Data.Coerce-import Data.Monoid ( Endo(..) )-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 )-import Data.List  ( intersperse )-----{--************************************************************************-*                                                                      *-*                       Canonical constraints                          *-*                                                                      *-*   These are the constraints the low-level simplifier works with      *-*                                                                      *-************************************************************************--Note [CEqCan occurs check]-~~~~~~~~~~~~~~~~~~~~~~~~~~-A CEqCan relates a CanEqLHS (a type variable or type family applications) on-its left to an arbitrary type on its right. It is used for rewriting.-Because it is used for rewriting, it would be disastrous if the RHS-were to mention the LHS: this would cause a loop in rewriting.--We thus perform an occurs-check. There is, of course, some subtlety:--* For type variables, the occurs-check looks deeply. This is because-  a CEqCan over a meta-variable is also used to inform unification,-  in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears-  anywhere, at all, in the RHS, 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-  look in kinds or coercions.) An occurrence of the LHS in, say, an-  RHS coercion is OK, as we do not rewrite in coercions. No loop to-  be found.--  You might also worry about the possibility that a type family-  application LHS doesn't exactly appear in the RHS, but something-  that reduces to the LHS does. Yet that can't happen: the RHS is-  already inert, with all type family redexes reduced. So a simple-  syntactic check is just fine.--The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq-and forms condition T3 in Note [Extending the inert equalities]-in GHC.Tc.Solver.InertSet.---}---- | A 'Xi'-type is one that has been fully rewritten with respect--- to the inert set; that is, it has been rewritten by the algorithm--- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years,--- meant that a type was type-family-free. It does *not* mean this--- any more.)-type Xi = TcType--type Cts = Bag Ct--data Ct-  -- Atomic canonical constraints-  = CDictCan {  -- e.g.  Num ty-      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]--      cc_class  :: Class,-      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi--      cc_pend_sc :: Bool-          -- See Note [The superclass story] in GHC.Tc.Solver.Canonical-          -- True <=> (a) cc_class has superclasses-          --          (b) we have not (yet) added those-          --              superclasses as Givens-    }--  | CIrredCan {  -- These stand for yet-unusable predicates-      cc_ev     :: CtEvidence,   -- See Note [Ct/evidence invariant]-      cc_reason :: CtIrredReason--        -- For the might-be-soluble case, the ctev_pred of the evidence is-        -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head-        --      or   (lhs1 ~ ty2)  where the CEqCan    kind invariant (TyEq:K) fails-        -- See Note [CIrredCan constraints]--        -- The definitely-insoluble case is for things like-        --    Int ~ Bool      tycons don't match-        --    a ~ [a]         occurs check-    }--  | CEqCan {  -- CanEqLHS ~ rhs-       -- Invariants:-       --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet-       --   * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify-       --   * (TyEq:OC) lhs does not occur in rhs (occurs check)-       --               Note [CEqCan 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 Note [No top-level newtypes on RHS of representational equalities]-       --     in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is-       --     in scope.)-       --   * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented-       --     to give best chance of-       --     unification happening; eg if rhs is touchable then lhs is too-       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify-      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]-      cc_lhs    :: CanEqLHS,-      cc_rhs    :: Xi,         -- See invariants above--      cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev-    }--  | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad-      cc_ev  :: CtEvidence-    }--  | CQuantCan QCInst       -- A quantified constraint-      -- NB: I expect to make more of the cases in Ct-      --     look like this, with the payload in an-      --     auxiliary type----------------- | 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  -- ^ of the family-             [Xi]   -- ^ 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)---------------data QCInst  -- A much simplified version of ClsInst-             -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-  = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty-                                 -- Always Given-        , qci_tvs  :: [TcTyVar]  -- The tvs-        , qci_pred :: TcPredType -- The ty-        , qci_pend_sc :: Bool    -- Same as cc_pend_sc flag in CDictCan-                                 -- Invariant: True => qci_pred is a ClassPred-    }--instance Outputable QCInst where-  ppr (QCI { qci_ev = ev }) = ppr ev-------------------------------------------------------------------------------------- Holes and other delayed errors-------------------------------------------------------------------------------------- | A delayed error, to be reported after constraint solving, in order to benefit--- from deferred unifications.-data DelayedError-  = DE_Hole Hole-    -- ^ A hole (in a type or in a term).-    ---    -- See Note [Holes].-  | DE_NotConcrete NotConcreteError-    -- ^ A type could not be ensured to be concrete.-    ---    -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.--instance Outputable DelayedError where-  ppr (DE_Hole hole) = ppr hole-  ppr (DE_NotConcrete err) = ppr err---- | 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].-data Hole-  = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this?-         , hole_occ  :: RdrName  -- ^ The name of this hole-         , hole_ty   :: TcType   -- ^ Type to be printed to the user-                                 -- For expression holes: type of expr-                                 -- For type holes: the missing type-         , hole_loc  :: CtLoc    -- ^ Where hole was written-         }-           -- For the hole_loc, we usually only want the TcLclEnv stored within.-           -- Except when we rewrite, where we need a whole location. And this-           -- might get reported to the user if reducing type families in a-           -- hole type loops.----- | Used to indicate which sort of hole we have.-data HoleSort = ExprHole HoleExprRef-                 -- ^ Either an out-of-scope variable or a "true" hole in an-                 -- expression (TypedHoles).-                 -- The HoleExprRef says where to write the-                 -- the erroring expression for -fdefer-type-errors.-              | TypeHole-                 -- ^ A hole in a type (PartialTypeSignatures)-              | ConstraintHole-                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...-                 -- Differentiated from TypeHole because a ConstraintHole-                 -- is simplified differently. See-                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.--instance Outputable Hole where-  ppr (Hole { hole_sort = ExprHole ref-            , hole_occ  = occ-            , hole_ty   = ty })-    = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty-  ppr (Hole { hole_sort = _other-            , hole_occ  = occ-            , hole_ty   = ty })-    = braces $ ppr occ <> colon <> ppr ty--instance Outputable HoleSort where-  ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref-  ppr TypeHole       = text "TypeHole"-  ppr ConstraintHole = text "ConstraintHole"---- | Why did we require that a certain type be concrete?-data NotConcreteError-  -- | Concreteness was required by a representation-polymorphism-  -- check.-  ---  -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.-  = NCE_FRR-    { nce_loc        :: CtLoc-      -- ^ 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))----------------- | Used to indicate extra information about why a CIrredCan is irreducible-data CtIrredReason-  = IrredShapeReason-      -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@)--  | NonCanonicalReason CheckTyEqResult-   -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;-   -- the 'CheckTyEqResult' states exactly why--  | ReprEqReason-    -- ^ an equality that cannot be decomposed because it is representational.-    -- Example: @a b ~R# Int@.-    -- These might still be solved later.-    -- INVARIANT: The constraint is a representational equality constraint--  | ShapeMismatchReason-    -- ^ a nominal equality that relates two wholly different types,-    -- like @Int ~# Bool@ or @a b ~# 3@.-    -- INVARIANT: The constraint is a nominal equality constraint--  | AbstractTyConReason-    -- ^ an equality like @T a b c ~ Q d e@ where either @T@ or @Q@-    -- is an abstract type constructor. See Note [Skolem abstract data]-    -- in GHC.Core.TyCon.-    -- INVARIANT: The constraint is an equality constraint between two TyConApps--instance Outputable CtIrredReason where-  ppr IrredShapeReason          = text "(irred)"-  ppr (NonCanonicalReason cter) = ppr cter-  ppr ReprEqReason              = text "(repr)"-  ppr ShapeMismatchReason       = text "(shape)"-  ppr AbstractTyConReason       = text "(abstc)"---- | Are we sure that more solving will never solve this constraint?-isInsolubleReason :: CtIrredReason -> Bool-isInsolubleReason IrredShapeReason          = False-isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter-isInsolubleReason ReprEqReason              = False-isInsolubleReason ShapeMismatchReason       = True-isInsolubleReason AbstractTyConReason       = True-------------------------------------------------------------------------------------- CheckTyEqResult, defined here because it is stored in a CtIrredReason-------------------------------------------------------------------------------------- | A set of problems in checking the validity of a type equality.--- See 'checkTypeEq'.-newtype CheckTyEqResult = CTER Word8---- | No problems in checking the validity of a type equality.-cteOK :: CheckTyEqResult-cteOK = CTER zeroBits---- | Check whether a 'CheckTyEqResult' is marked successful.-cterHasNoProblem :: CheckTyEqResult -> Bool-cterHasNoProblem (CTER 0) = True-cterHasNoProblem _        = False---- | An individual problem that might be logged in a 'CheckTyEqResult'-newtype CheckTyEqProblem = CTEP Word8--cteImpredicative, cteTypeFamily, cteInsolubleOccurs, cteSolubleOccurs :: CheckTyEqProblem-cteImpredicative   = CTEP (bit 0)   -- forall or (=>) encountered-cteTypeFamily      = CTEP (bit 1)   -- type family encountered-cteInsolubleOccurs = CTEP (bit 2)   -- occurs-check-cteSolubleOccurs   = CTEP (bit 3)   -- occurs-check under a type function or in a coercion-                                    -- must be one bit to the left of cteInsolubleOccurs--- See also Note [Insoluble occurs check] in GHC.Tc.Errors--cteProblem :: CheckTyEqProblem -> CheckTyEqResult-cteProblem (CTEP mask) = CTER mask--occurs_mask :: Word8-occurs_mask = insoluble_mask .|. soluble_mask-  where-    CTEP insoluble_mask = cteInsolubleOccurs-    CTEP soluble_mask   = cteSolubleOccurs---- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem'-cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool-CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0---- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other-cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool-CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask--cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult-cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask)--cterHasOccursCheck :: CheckTyEqResult -> Bool-cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0--cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult-cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask)---- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs--- check under a type family or in a representation equality is soluble.-cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult-cterSetOccursCheckSoluble (CTER bits)-  = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask)-  where-    CTEP insoluble_mask = cteInsolubleOccurs---- | Retain only information about occurs-check failures, because only that--- matters after recurring into a kind.-cterFromKind :: CheckTyEqResult -> CheckTyEqResult-cterFromKind (CTER bits)-  = CTER (bits .&. occurs_mask)--cterIsInsoluble :: CheckTyEqResult -> Bool-cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0-  where-    mask = impredicative_mask .|. insoluble_occurs_mask--    CTEP impredicative_mask    = cteImpredicative-    CTEP insoluble_occurs_mask = cteInsolubleOccurs--instance Semigroup CheckTyEqResult where-  CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2)-instance Monoid CheckTyEqResult where-  mempty = cteOK--instance Outputable CheckTyEqResult where-  ppr cter | cterHasNoProblem cter = text "cteOK"-           | otherwise-           = parens $ fcat $ intersperse vbar $ set_bits-    where-      all_bits = [ (cteImpredicative,   "cteImpredicative")-                 , (cteTypeFamily,      "cteTypeFamily")-                 , (cteInsolubleOccurs, "cteInsolubleOccurs")-                 , (cteSolubleOccurs,   "cteSolubleOccurs") ]-      set_bits = [ text str-                 | (bitmask, str) <- all_bits-                 , cter `cterHasProblem` bitmask ]--{- Note [CIrredCan constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-CIrredCan constraints are used for constraints that are "stuck"-   - we can't solve them (yet)-   - we can't use them to solve other constraints-   - but they may become soluble if we substitute for some-     of the type variables in the constraint--Example 1:  (c Int), where c :: * -> Constraint.  We can't do anything-            with this yet, but if later c := Num, *then* we can solve it--Example 2:  a ~ b, where a :: *, b :: k, where k is a kind variable-            We don't want to use this to substitute 'b' for 'a', in case-            'k' is subsequently unified with (say) *->*, because then-            we'd have ill-kinded types floating about.  Rather we want-            to defer using the equality altogether until 'k' get resolved.--Note [Ct/evidence invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If  ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field-of (cc_ev ct), and is fully rewritten wrt the substitution.   Eg for CDictCan,-   ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct)-This holds by construction; look at the unique place where CDictCan is-built (in GHC.Tc.Solver.Canonical).--Note [Ct kind invariant]-~~~~~~~~~~~~~~~~~~~~~~~~-CEqCan requires that the kind of the lhs matches the kind-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-mkNonCanonical ev = CNonCanonical { cc_ev = ev }--mkNonCanonicalCt :: Ct -> Ct-mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }--mkIrredCt :: CtIrredReason -> CtEvidence -> Ct-mkIrredCt reason ev = CIrredCan { cc_ev = ev, cc_reason = reason }--mkGivens :: CtLoc -> [EvId] -> [Ct]-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 })--ctEvidence :: Ct -> CtEvidence-ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev-ctEvidence ct = cc_ev ct--ctLoc :: Ct -> CtLoc-ctLoc = ctEvLoc . ctEvidence--ctOrigin :: Ct -> CtOrigin-ctOrigin = ctLocOrigin . ctLoc--ctPred :: Ct -> PredType--- See Note [Ct/evidence invariant]-ctPred ct = ctEvPred (ctEvidence ct)--ctRewriters :: Ct -> RewriterSet-ctRewriters = ctEvRewriters . ctEvidence--ctEvId :: HasDebugCallStack => Ct -> EvVar--- The evidence Id for this Ct-ctEvId ct = ctEvEvId (ctEvidence ct)---- | Returns the evidence 'Id' for the argument 'Ct'--- when this 'Ct' is a 'Wanted'.------ Returns 'Nothing' otherwise.-wantedEvId_maybe :: Ct -> Maybe EvVar-wantedEvId_maybe ct-  = case ctEvidence ct of-    ctev@(CtWanted {})-      | otherwise-      -> Just $ ctEvEvId ctev-    CtGiven {}-      -> Nothing---- | Makes a new equality predicate with the same role as the given--- evidence.-mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType-mkTcEqPredLikeEv ev-  = case predTypeEqRel pred of-      NomEq  -> mkPrimEqPred-      ReprEq -> mkReprPrimEqPred-  where-    pred = ctEvPred ev---- | Get the flavour of the given 'Ct'-ctFlavour :: Ct -> CtFlavour-ctFlavour = ctEvFlavour . ctEvidence---- | Get the equality relation for the given 'Ct'-ctEqRel :: Ct -> EqRel-ctEqRel = ctEvEqRel . ctEvidence--instance Outputable Ct where-  ppr ct = ppr (ctEvidence ct) <+> parens pp_sort-    where-      pp_sort = case ct of-         CEqCan {}        -> text "CEqCan"-         CNonCanonical {} -> text "CNonCanonical"-         CDictCan { cc_pend_sc = psc }-            | psc          -> text "CDictCan(psc)"-            | otherwise    -> text "CDictCan"-         CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason-         CQuantCan (QCI { qci_pend_sc = pend_sc })-            | pend_sc   -> text "CQuantCan(psc)"-            | otherwise -> text "CQuantCan"---------------------------------------- | 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--  | 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--{--************************************************************************-*                                                                      *-        Simple functions over evidence variables-*                                                                      *-************************************************************************--}------------------ Getting free tyvars ----------------------------- | Returns free variables of constraints as a non-deterministic set-tyCoVarsOfCt :: Ct -> TcTyCoVarSet-tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt---- | Returns free variables of constraints as a non-deterministic set-tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet-tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv---- | Returns free variables of constraints as a deterministically ordered--- list. See Note [Deterministic FV] in GHC.Utils.FV.-tyCoVarsOfCtList :: Ct -> [TcTyCoVar]-tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt---- | Returns free variables of constraints as a deterministically ordered--- list. See Note [Deterministic FV] in GHC.Utils.FV.-tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar]-tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred---- | Returns free variables of constraints as a composable FV computation.--- See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfCt :: Ct -> FV-tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)-  -- This must consult only the ctPred, so that it gets *tidied* fvs if the-  -- constraint has been tidied. Tidying a constraint does not tidy the-  -- fields of the Ct, only the predicate in the CtEvidence.---- | Returns free variables of constraints as a composable FV computation.--- See Note [Deterministic FV] in GHC.Utils.FV.-tyCoFVsOfCtEv :: CtEvidence -> FV-tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct)---- | Returns free variables of a bag of constraints as a non-deterministic--- set. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfCts :: Cts -> TcTyCoVarSet-tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts---- | Returns free variables of a bag of constraints as a deterministically--- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfCtsList :: Cts -> [TcTyCoVar]-tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts---- | Returns free variables of a bag of constraints as a deterministically--- ordered list. See Note [Deterministic FV] in GHC.Utils.FV.-tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar]-tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs---- | Returns free variables of a bag of constraints as a composable FV--- computation. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfCts :: Cts -> FV-tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV---- | Returns free variables of a bag of constraints as a composable FV--- computation. See Note [Deterministic FV] in GHC.Utils.FV.-tyCoFVsOfCtEvs :: [CtEvidence] -> FV-tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV---- | Returns free variables of WantedConstraints as a non-deterministic--- set. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet--- Only called on *zonked* things-tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC---- | Returns free variables of WantedConstraints as a deterministically--- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]--- Only called on *zonked* things-tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC---- | Returns free variables of WantedConstraints as a composable FV--- computation. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfWC :: WantedConstraints -> FV--- Only called on *zonked* things-tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_errors = errors })-  = tyCoFVsOfCts simple `unionFV`-    tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`-    tyCoFVsOfBag tyCoFVsOfDelayedError errors---- | Returns free variables of Implication as a composable FV computation.--- See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfImplic :: Implication -> FV--- Only called on *zonked* things-tyCoFVsOfImplic (Implic { ic_skols = skols-                        , ic_given = givens-                        , ic_wanted = wanted })-  | isEmptyWC wanted-  = emptyFV-  | otherwise-  = tyCoFVsVarBndrs skols  $-    tyCoFVsVarBndrs givens $-    tyCoFVsOfWC wanted--tyCoFVsOfDelayedError :: DelayedError -> FV-tyCoFVsOfDelayedError (DE_Hole hole) = tyCoFVsOfHole hole-tyCoFVsOfDelayedError (DE_NotConcrete {}) = emptyFV--tyCoFVsOfHole :: Hole -> FV-tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty--tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV-tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV--isGivenLoc :: CtLoc -> Bool-isGivenLoc loc = isGivenOrigin (ctLocOrigin loc)--{--************************************************************************-*                                                                      *-                    CtEvidence-         The "flavor" of a canonical constraint-*                                                                      *-************************************************************************--}--isWantedCt :: Ct -> Bool-isWantedCt = isWanted . ctEvidence--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 Type-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--isUserTypeError :: PredType -> Bool-isUserTypeError pred = case getUserTypeErrorMsg pred of-                             Just _ -> True-                             _      -> False--isPendingScDict :: Ct -> Bool-isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc--- Says whether this is a CDictCan with cc_pend_sc is True;--- i.e. pending un-expanded superclasses-isPendingScDict _ = False--pendingScDict_maybe :: Ct -> Maybe Ct--- Says whether this is a CDictCan with cc_pend_sc is True,--- AND if so flips the flag-pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True })-                      = Just (ct { cc_pend_sc = False })-pendingScDict_maybe _ = Nothing--pendingScInst_maybe :: QCInst -> Maybe QCInst--- Same as isPendingScDict, but for QCInsts-pendingScInst_maybe qci@(QCI { qci_pend_sc = True })-                      = Just (qci { qci_pend_sc = False })-pendingScInst_maybe _ = Nothing--superClassesMightHelp :: WantedConstraints -> Bool--- ^ True if taking superclasses of givens, or of wanteds (to perhaps--- expose more equalities or functional dependencies) might help to--- solve this constraint.  See Note [When superclasses help]-superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })-  = anyBag might_help_ct simples || anyBag might_help_implic implics-  where-    might_help_implic ic-       | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic)-       | otherwise                   = False--    might_help_ct ct = not (is_ip ct)--    is_ip (CDictCan { cc_class = cls }) = isIPClass cls-    is_ip _                             = False--getPendingWantedScs :: Cts -> ([Ct], Cts)-getPendingWantedScs simples-  = mapAccumBagL get [] simples-  where-    get acc ct | Just ct' <- pendingScDict_maybe ct-               = (ct':acc, ct')-               | otherwise-               = (acc,     ct)--{- Note [When superclasses help]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-First read Note [The superclass story] in GHC.Tc.Solver.Canonical.--We expand superclasses and iterate only if there is at unsolved wanted-for which expansion of superclasses (e.g. from given constraints)-might actually help. The function superClassesMightHelp tells if-doing this superclass expansion might help solve this constraint.-Note that--  * We look inside implications; maybe it'll help to expand the Givens-    at level 2 to help solve an unsolved Wanted buried inside an-    implication.  E.g.-        forall a. Ord a => forall b. [W] Eq a--  * We say "no" for implicit parameters.-    we have [W] ?x::ty, expanding superclasses won't help:-      - Superclasses can't be implicit parameters-      - If we have a [G] ?x:ty2, then we'll have another unsolved-        [W] ty ~ ty2 (from the functional dependency)-        which will trigger superclass expansion.--    It's a bit of a special case, but it's easy to do.  The runtime cost-    is low because the unsolved set is usually empty anyway (errors-    aside), and the first non-implicit-parameter will terminate the search.--    The special case is worth it (#11480, comment:2) because it-    applies to CallStack constraints, which aren't type errors. If we have-       f :: (C a) => blah-       f x = ...undefined...-    we'll get a CallStack constraint.  If that's the only unsolved-    constraint it'll eventually be solved by defaulting.  So we don't-    want to emit warnings about hitting the simplifier's iteration-    limit.  A CallStack constraint really isn't an unsolved-    constraint; it can always be solved by defaulting.--}--singleCt :: Ct -> Cts-singleCt = unitBag--andCts :: Cts -> Cts -> Cts-andCts = unionBags--listToCts :: [Ct] -> Cts-listToCts = listToBag--ctsElts :: Cts -> [Ct]-ctsElts = bagToList--consCts :: Ct -> Cts -> Cts-consCts = consBag--snocCts :: Cts -> Ct -> Cts-snocCts = snocBag--extendCtsList :: Cts -> [Ct] -> Cts-extendCtsList cts xs | null xs   = cts-                     | otherwise = cts `unionBags` listToBag xs--andManyCts :: [Cts] -> Cts-andManyCts = unionManyBags--emptyCts :: Cts-emptyCts = emptyBag--isEmptyCts :: Cts -> Bool-isEmptyCts = isEmptyBag--pprCts :: Cts -> SDoc-pprCts cts = vcat (map ppr (bagToList cts))--{--************************************************************************-*                                                                      *-                Wanted constraints-*                                                                      *-************************************************************************--}--data WantedConstraints-  = WC { wc_simple :: Cts              -- Unsolved constraints, all wanted-       , wc_impl   :: Bag Implication-       , wc_errors :: Bag DelayedError-    }--emptyWC :: WantedConstraints-emptyWC = WC { wc_simple = emptyBag-             , wc_impl   = emptyBag-             , wc_errors = emptyBag }--mkSimpleWC :: [CtEvidence] -> WantedConstraints-mkSimpleWC cts-  = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) }--mkImplicWC :: Bag Implication -> WantedConstraints-mkImplicWC implic-  = emptyWC { wc_impl = implic }--isEmptyWC :: WantedConstraints -> Bool-isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors })-  = isEmptyBag f && isEmptyBag i && isEmptyBag errors---- | Checks whether a the given wanted constraints are solved, i.e.--- that there are no simple constraints left and all the implications--- are solved.-isSolvedWC :: WantedConstraints -> Bool-isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_errors = errors} =-  isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag errors--andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints-andWC (WC { wc_simple = f1, wc_impl = i1, wc_errors = e1 })-      (WC { wc_simple = f2, wc_impl = i2, wc_errors = e2 })-  = WC { wc_simple = f1 `unionBags` f2-       , wc_impl   = i1 `unionBags` i2-       , wc_errors = e1 `unionBags` e2 }--unionsWC :: [WantedConstraints] -> WantedConstraints-unionsWC = foldr andWC emptyWC--addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints-addSimples wc cts-  = wc { wc_simple = wc_simple wc `unionBags` cts }-    -- Consider: Put the new constraints at the front, so they get solved first--addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints-addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }--addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints-addInsols wc cts-  = wc { wc_simple = wc_simple wc `unionBags` cts }--addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints-addHoles wc holes-  = wc { wc_errors = mapBag DE_Hole holes `unionBags` wc_errors wc }--addNotConcreteError :: WantedConstraints -> NotConcreteError -> WantedConstraints-addNotConcreteError wc err-  = wc { wc_errors = unitBag (DE_NotConcrete err) `unionBags` wc_errors wc }--addDelayedErrors :: WantedConstraints -> Bag DelayedError -> WantedConstraints-addDelayedErrors wc errs-  = wc { wc_errors = errs `unionBags` wc_errors wc }--dropMisleading :: WantedConstraints -> WantedConstraints--- Drop misleading constraints; really just class constraints--- See Note [Constraints and errors] in GHC.Tc.Utils.Monad---   for why this function is so strange, treating the 'simples'---   and the implications differently.  Sigh.-dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors })-  = WC { wc_simple = filterBag insolubleWantedCt simples-       , wc_impl   = mapBag drop_implic implics-       , wc_errors = filterBag keep_delayed_error errors }-  where-    drop_implic implic-      = implic { ic_wanted = drop_wanted (ic_wanted implic) }-    drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors })-      = WC { wc_simple = filterBag keep_ct simples-           , 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_delayed_error (DE_Hole hole) = isOutOfScopeHole hole-    keep_delayed_error (DE_NotConcrete {}) = True--isSolvedStatus :: ImplicStatus -> Bool-isSolvedStatus (IC_Solved {}) = True-isSolvedStatus _              = False--isInsolubleStatus :: ImplicStatus -> Bool-isInsolubleStatus IC_Insoluble    = True-isInsolubleStatus IC_BadTelescope = True-isInsolubleStatus _               = False--insolubleImplic :: Implication -> Bool-insolubleImplic ic = isInsolubleStatus (ic_status ic)---- | Gather all the type variables from 'WantedConstraints'--- that it would be unhelpful to default. For the moment,--- these are only 'ConcreteTv' metavariables participating--- in a nominal equality whose other side is not concrete;--- it's usually better to report those as errors instead of--- defaulting.-nonDefaultableTyVarsOfWC :: WantedConstraints -> TyCoVarSet--- Currently used in simplifyTop and in tcRule.--- TODO: should we also use this in decideQuantifiedTyVars, kindGeneralize{All,Some}?-nonDefaultableTyVarsOfWC (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })-  =             concatMapBag non_defaultable_tvs_of_ct simples-  `unionVarSet` concatMapBag (nonDefaultableTyVarsOfWC . ic_wanted) implics-  `unionVarSet` concatMapBag non_defaultable_tvs_of_err errs-    where--      concatMapBag :: (a -> TyVarSet) -> Bag a -> TyCoVarSet-      concatMapBag f = foldr (\ r acc -> f r `unionVarSet` acc) emptyVarSet--      -- Don't default ConcreteTv metavariables involved-      -- in an equality with something non-concrete: it's usually-      -- better to report the unsolved Wanted.-      ---      -- Example: alpha[conc] ~# rr[sk].-      non_defaultable_tvs_of_ct :: Ct -> TyCoVarSet-      non_defaultable_tvs_of_ct ct =-        -- NB: using classifyPredType instead of inspecting the Ct-        -- so that we deal uniformly with CNonCanonical (which come up in tcRule),-        -- CEqCan (unsolved but potentially soluble, e.g. @alpha[conc] ~# RR@)-        -- and CIrredCan.-        case classifyPredType $ ctPred ct of-          EqPred NomEq lhs rhs-            | Just tv <- getTyVar_maybe lhs-            , isConcreteTyVar tv-            , not (isConcrete rhs)-            -> unitVarSet tv-            | Just tv <- getTyVar_maybe rhs-            , isConcreteTyVar tv-            , not (isConcrete lhs)-            -> unitVarSet tv-          _ -> emptyVarSet--      -- Make sure to apply the same logic as above to delayed errors.-      non_defaultable_tvs_of_err (DE_NotConcrete err)-        = case err of-            NCE_FRR { nce_frr_origin = frr } -> tyCoVarsOfType (frr_type frr)-      non_defaultable_tvs_of_err (DE_Hole {}) = emptyVarSet--insolubleWC :: WantedConstraints -> Bool-insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors })-  =  anyBag insolubleWantedCt simples-       -- insolubleWantedCt: wanteds only: see Note [Given insolubles]-  || anyBag insolubleImplic implics-  || anyBag is_insoluble errors-  where-      is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes]-      is_insoluble (DE_NotConcrete {}) = True--insolubleWantedCt :: Ct -> Bool--- Definitely insoluble, in particular /excluding/ type-hole constraints--- Namely:---   a) an insoluble constraint as per 'insolubleirredCt', i.e. either---        - an insoluble equality constraint (e.g. Int ~ Bool), or---        - a custom type error constraint, TypeError msg :: Constraint---   b) that does not arise from a Given or a Wanted/Wanted fundep interaction--- See Note [Insoluble Wanteds]-insolubleWantedCt ct-  | CIrredCan ir_ev ir_reason <- ct-      -- CIrredCan: see (IW1) in Note [Insoluble Wanteds]-  , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ir_ev-      -- It's a Wanted-  , insolubleIrredCt ir_ev ir_reason-      -- It's insoluble-  , isEmptyRewriterSet rewriters-      -- rewriters; see (IW2) in Note [Insoluble Wanteds]-  , not (isGivenLoc loc)-      -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds]-  , not (isWantedWantedFunDepOrigin (ctLocOrigin loc))-      -- origin check: see (IW4) in Note [Insoluble Wanteds]-  = True--  | otherwise-  = False---- | Returns True of constraints that are definitely insoluble,---   as well as TypeError constraints.--- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.------ The function is tuned for application /after/ constraint solving---       i.e. assuming canonicalisation has been done--- That's why it looks only for IrredCt; all insoluble constraints--- are put into CIrredCan-insolubleCt :: Ct -> Bool-insolubleCt (CIrredCan ir_ev ir_reason) = insolubleIrredCt ir_ev ir_reason-insolubleCt _                           = False--insolubleIrredCt :: CtEvidence -> CtIrredReason -> Bool--- Returns True of Irred constraints that are /definitely/ insoluble------ This function is critical for accurate pattern-match overlap warnings.--- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver------ Note that this does not traverse through the constraint to find--- nested custom type errors: it only detects @TypeError msg :: Constraint@,--- and not e.g. @Eq (TypeError msg)@.-insolubleIrredCt ev reason-  =  isInsolubleReason reason-  || isJust (userTypeError_maybe (ctEvPred ev))--{--insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason })-  =  isInsolubleReason reason-  || isTopLevelUserTypeError (ctEvPred ev)---- | 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)-----}--insolubleEqCt :: Ct -> Bool--- Returns True of /equality/ constraints--- that are /definitely/ insoluble--- It won't detect some definite errors like---       F a ~ T (F a)--- where F is a type family, which actually has an occurs check------ The function is tuned for application /after/ constraint solving---       i.e. assuming canonicalisation has been done--- E.g.  It'll reply True  for     a ~ [a]---               but False for   [a] ~ a--- and---                   True for  Int ~ F a Int---               but False for  Maybe Int ~ F a Int Int---               (where F is an arity-1 type function)-insolubleEqCt (CIrredCan { cc_reason = reason }) = isInsolubleReason reason-insolubleEqCt _                                  = False---- | Returns True of equality constraints that are definitely insoluble,--- as well as TypeError constraints.--- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.------ This function is critical for accurate pattern-match overlap warnings.--- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver------ Note that this does not traverse through the constraint to find--- nested custom type errors: it only detects @TypeError msg :: Constraint@,--- and not e.g. @Eq (TypeError msg)@.--  -- Don't use 'isUserTypeErrorCt' here, as that function is too eager:-  -- the TypeError might appear inside a type family application-  -- which might later reduce, but we only want to return 'True'-  -- for constraints that are definitely insoluble.-  ---  -- Test case: T11503, with the 'Assert' type family:-  ---  -- > type Assert :: Bool -> Constraint -> Constraint-  -- > type family Assert check errMsg where-  -- >   Assert 'True  _errMsg = ()-  -- >   Assert _check errMsg  = errMsg---- | Does this hole represent an "out of scope" error?--- See Note [Insoluble holes]-isOutOfScopeHole :: Hole -> Bool-isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ))--instance Outputable WantedConstraints where-  ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e})-   = text "WC" <+> braces (vcat-        [ ppr_bag (text "wc_simple") s-        , ppr_bag (text "wc_impl") i-        , ppr_bag (text "wc_errors") e ])--ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc-ppr_bag doc bag- | isEmptyBag bag = empty- | otherwise      = hang (doc <+> equals)-                       2 (foldr (($$) . ppr) empty bag)--{- Note [Given insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#14325, comment:)-    class (a~b) => C a b--    foo :: C a c => a -> c-    foo x = x--    hm3 :: C (f b) b => b -> f b-    hm3 x = foo x--In the RHS of hm3, from the [G] C (f b) b we get the insoluble-[G] f b ~# b.  Then we also get an unsolved [W] C b (f b).-Residual implication looks like-    forall b. C (f b) b => [G] f b ~# b-                           [W] C f (f b)--We do /not/ want to set the implication status to IC_Insoluble,-because that'll suppress reports of [W] C b (f b).  But we-may not report the insoluble [G] f b ~# b either (see Note [Given errors]-in GHC.Tc.Errors), so we may fail to report anything at all!  Yikes.--Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus)-             should ignore givens even if they are insoluble.--Note [Insoluble Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~-insolubleWantedCt returns True of a Wanted constraint that definitely-can't be solved.  But not quite all such constraints; see wrinkles.--(IW1) insolubleWantedCt is tuned for application /after/ constraint-   solving i.e. assuming canonicalisation has been done.  That's why-   it looks only for IrredCt; all insoluble constraints oare put into-   CIrredCan--(IW2) We only treat it as insoluble if it has an empty rewriter set.-   Otherwise #25325 happens: a Wanted constraint A that is /not/ insoluble-   rewrites some other Wanted constraint B, so B has A in its rewriter-   set.  Now B looks insoluble.  The danger is that we'll suppress reporting-   B becuase of its empty rewriter set; and suppress reporting A because-   there is an insoluble B lying around.  (This suppression happens in-   GHC.Tc.Errors.)  Solution: don't treat B as insoluble.--(IW3) If the Wanted arises from a Given (how can that happen?), don't-   treat it as a Wanted insoluble (obviously).--(IW4) If the Wanted came from a  Wanted/Wanted fundep interaction, don't-   treat the constraint as insoluble. See Note [Suppressing confusing errors]-   in GHC.Tc.Errors--Note [Insoluble holes]-~~~~~~~~~~~~~~~~~~~~~~-Hole constraints that ARE NOT treated as truly insoluble:-  a) type holes, arising from PartialTypeSignatures,-  b) "true" expression holes arising from TypedHoles--An "expression hole" or "type hole" isn't really an error-at all; it's a report saying "_ :: Int" here.  But an out-of-scope-variable masquerading as expression holes IS treated as truly-insoluble, so that it trumps other errors during error reporting.-Yuk!--************************************************************************-*                                                                      *-                Implication constraints-*                                                                      *-************************************************************************--}--data Implication-  = Implic {   -- Invariants for a tree of implications:-               -- see TcType Note [TcLevel invariants]--      ic_tclvl :: TcLevel,       -- TcLevel of unification variables-                                 -- allocated /inside/ this implication--      ic_info  :: SkolemInfoAnon,    -- See Note [Skolems in an implication]-                                     -- See Note [Shadowing in a constraint]--      ic_skols :: [TcTyVar],     -- Introduced skolems; always skolem TcTyVars-                                 -- Their level numbers should be precisely ic_tclvl-                                 -- Their SkolemInfo should be precisely ic_info (almost)-                                 --       See Note [Implication invariants]--      ic_given  :: [EvVar],      -- Given evidence variables-                                 --   (order does not matter)-                                 -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType--      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?--      ic_warn_inaccessible :: Bool,-                                 -- True  <=> -Winaccessible-code is enabled-                                 -- at construction. See-                                 -- Note [Avoid -Winaccessible-code when deriving]-                                 -- in GHC.Tc.TyCl.Instance--      ic_env   :: TcLclEnv,-                                 -- Records the TcLClEnv at the time of creation.-                                 ---                                 -- The TcLclEnv gives the source location-                                 -- and error context for the implication, and-                                 -- hence for all the given evidence variables.--      ic_wanted :: WantedConstraints,  -- The wanteds-                                       -- See Invariant (WantedInf) in GHC.Tc.Utils.TcType--      ic_binds  :: EvBindsVar,    -- Points to the place to fill in the-                                  -- abstraction and bindings.--      -- 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--      ic_status   :: ImplicStatus-    }--implicationPrototype :: Implication-implicationPrototype-   = Implic { -- These fields must be initialised-              ic_tclvl      = panic "newImplic:tclvl"-            , ic_binds      = panic "newImplic:binds"-            , ic_info       = panic "newImplic:info"-            , ic_env        = panic "newImplic:env"-            , ic_warn_inaccessible = panic "newImplic:warn_inaccessible"--              -- 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 }--data ImplicStatus-  = IC_Solved     -- All wanteds in the tree are solved, all the way down-       { ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed-         -- See Note [Tracking redundant constraints] in GHC.Tc.Solver--  | IC_Insoluble  -- At least one insoluble constraint in the tree--  | IC_BadTelescope  -- Solved, but the skolems in the telescope are out of-                     -- dependency order. See Note [Checking telescopes]--  | IC_Unsolved   -- Neither of the above; might go either way--data HasGivenEqs -- See Note [HasGivenEqs]-  = NoGivenEqs      -- Definitely no given equalities,-                    --   except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet-  | LocalGivenEqs   -- Might have Given equalities, but only ones that affect only-                    --   local skolems e.g. forall a b. (a ~ F b) => ...-  | MaybeGivenEqs   -- Might have any kind of Given equalities; no floating out-                    --   is possible.-  deriving Eq--type UserGiven = Implication--getUserGivensFromImplics :: [Implication] -> [UserGiven]-getUserGivensFromImplics implics-  = reverse (filterOut (null . ic_given) implics)--{- Note [HasGivenEqs]-~~~~~~~~~~~~~~~~~~~~~-The GivenEqs data type describes the Given constraints of an implication constraint:--* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems-  which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet-  Examples: forall a. Eq a => ...-            forall a. (Show a, Num a) => ...-            forall a. a ~ Either Int Bool => ...  -- Let-bound skolem--* LocalGivenEqs: definitely no Given equalities that would affect principal-  types.  But may have equalities that affect only skolems of this implication-  (and hence do not affect principal types)-  Examples: forall a. F a ~ Int => ...-            forall a b. F a ~ G b => ...--* MaybeGivenEqs: may have Given equalities that would affect principal-  types-  Examples: forall. (a ~ b) => ...-            forall a. F a ~ b => ...-            forall a. c a => ...       -- The 'c' might be instantiated to (b ~)-            forall a. C a b => ....-               where class x~y => C a b-               so there is an equality in the superclass of a Given--The HasGivenEqs classifications affect two things:--* Suppressing redundant givens during error reporting; see GHC.Tc.Errors-  Note [Suppress redundant givens during error reporting]--* Floating in approximateWC.--Specifically, here's how it goes:--                 Stops floating    |   Suppresses Givens in errors-                 in approximateWC  |-                 ------------------------------------------------ NoGivenEqs         NO             |         YES- LocalGivenEqs      NO             |         NO- MaybeGivenEqs      YES            |         NO--}--instance Outputable Implication where-  ppr (Implic { ic_tclvl = tclvl, ic_skols = skols-              , 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_info = info })-   = hang (text "Implic" <+> lbrace)-        2 (sep [ text "TcLevel =" <+> ppr tclvl-               , text "Skolems =" <+> pprTyVars skols-               , text "Given-eqs =" <+> ppr given_eqs-               , text "Status =" <+> ppr status-               , 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)-               , pprSkolInfo info ] <+> rbrace)--instance Outputable ImplicStatus where-  ppr IC_Insoluble    = text "Insoluble"-  ppr IC_BadTelescope = text "Bad telescope"-  ppr IC_Unsolved     = text "Unsolved"-  ppr (IC_Solved { ics_dead = dead })-    = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead))--checkTelescopeSkol :: SkolemInfoAnon -> Bool--- See Note [Checking telescopes]-checkTelescopeSkol (ForAllSkol {}) = True-checkTelescopeSkol _               = False--instance Outputable HasGivenEqs where-  ppr NoGivenEqs    = text "NoGivenEqs"-  ppr LocalGivenEqs = text "LocalGivenEqs"-  ppr MaybeGivenEqs = text "MaybeGivenEqs"---- Used in GHC.Tc.Solver.Monad.getHasGivenEqs-instance Semigroup HasGivenEqs where-  NoGivenEqs <> other = other-  other <> NoGivenEqs = other--  MaybeGivenEqs <> _other = MaybeGivenEqs-  _other <> MaybeGivenEqs = MaybeGivenEqs--  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs---- Used in GHC.Tc.Solver.Monad.getHasGivenEqs-instance Monoid HasGivenEqs where-  mempty = NoGivenEqs--{- Note [Checking telescopes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When kind-checking a /user-written/ type, we might have a "bad telescope"-like this one:-  data SameKind :: forall k. k -> k -> Type-  type Foo :: forall a k (b :: k). SameKind a b -> Type--The kind of 'a' mentions 'k' which is bound after 'a'.  Oops.--One approach to doing this would be to bring each of a, k, and b into-scope, one at a time, creating a separate implication constraint for-each one, and bumping the TcLevel. This would work, because the kind-of, say, a would be untouchable when k is in scope (and the constraint-couldn't float out because k blocks it). However, it leads to terrible-error messages, complaining about skolem escape. While it is indeed a-problem of skolem escape, we can do better.--Instead, our approach is to bring the block of variables into scope-all at once, creating one implication constraint for the lot:--* We make a single implication constraint when kind-checking-  the 'forall' in Foo's kind, something like-      forall a k (b::k). { wanted constraints }--* Having solved {wanted}, before discarding the now-solved implication,-  the constraint solver checks the dependency order of the skolem-  variables (ic_skols).  This is done in setImplicationStatus.--* This check is only necessary if the implication was born from a-  'forall' in a user-written signature (the HsForAllTy case in-  GHC.Tc.Gen.HsType.  If, say, it comes from checking a pattern match-  that binds existentials, where the type of the data constructor is-  known to be valid (it in tcConPat), no need for the check.--  So the check is done /if and only if/ ic_info is ForAllSkol.--* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the-  original, user-written type variables.--* Be careful /NOT/ to discard an implication with a ForAllSkol-  ic_info, even if ic_wanted is empty.  We must give the-  constraint solver a chance to make that bad-telescope test!  Hence-  the extra guard in emitResidualTvConstraint; see #16247--* Don't mix up inferred and explicit variables in the same implication-  constraint.  E.g.-      foo :: forall a kx (b :: kx). SameKind a b-  We want an implication-      Implic { ic_skol = [(a::kx), kx, (b::kx)], ... }-  but GHC will attempt to quantify over kx, since it is free in (a::kx),-  and it's hopelessly confusing to report an error about quantified-  variables   kx (a::kx) kx (b::kx).-  Instead, the outer quantification over kx should be in a separate-  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- * The unification variables are all implicitly quantified at top-   level, and are all unique- * The skolem variables bound in ic_skols are all fresh when the-   implication is created.-So we can safely substitute. For example, if we have-   forall a.  a~Int => ...(forall b. ...a...)...-we can push the (a~Int) constraint inwards in the "givens" without-worrying that 'b' might clash.--Note [Skolems in an implication]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The skolems in an implication are used:--* When considering floating a constraint outside the implication in-  GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications-  For this, we can treat ic_skols as a set.--* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs)-  has its variables in the correct order; see Note [Checking telescopes].-  Only for these implications does ic_skols need to be a list.--Nota bene: Although ic_skols is a list, it is not necessarily-in dependency order:-- In the ic_info=ForAllSkol case, the user might have written them-  in the wrong order-- In the case of a type signature like-      f :: [a] -> [b]-  the renamer gathers the implicit "outer" forall'd variables {a,b}, but-  does not know what order to put them in.  The type checker can sort them-  into dependency order, but only after solving all the kind constraints;-  and to do that it's convenient to create the Implication!--So we accept that ic_skols may be out of order.  Think of it as a set or-(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly-wrong, order.--Note [Insoluble constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some of the errors that we get during canonicalization are best-reported when all constraints have been simplified as much as-possible. For instance, assume that during simplification the-following constraints arise:-- [Wanted]   F alpha ~  uf1- [Wanted]   beta ~ uf1 beta--When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail-we will simply see a message:-    'Can't construct the infinite type  beta ~ uf1 beta'-and the user has no idea what the uf1 variable is.--Instead our plan is that we will NOT fail immediately, but:-    (1) Record the "frozen" error in the ic_insols field-    (2) Isolate the offending constraint from the rest of the inerts-    (3) Keep on simplifying/canonicalizing--At the end, we will hopefully have substituted uf1 := F alpha, and we-will be able to report a more informative error:-    'Can't construct the infinite type beta ~ F alpha beta'--************************************************************************-*                                                                      *-            Invariant checking (debug only)-*                                                                      *-************************************************************************--Note [Implication invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The skolems of an implication have the following invariants, which are checked-by checkImplicationInvariants:--a) They are all SkolemTv TcTyVars; no TyVars, no unification variables-b) Their TcLevel matches the ic_lvl for the implication-c) Their SkolemInfo matches the implication.--Actually (c) is not quite true.  Consider-   data T a = forall b. MkT a b--In tcConDecl for MkT we'll create an implication with ic_info of-DataConSkol; but the type variable 'a' will have a SkolemInfo of-TyConSkol.  So we allow the tyvar to have a SkolemInfo of TyConFlav if-the implication SkolemInfo is DataConSkol.--}--checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m ()-{-# INLINE checkImplicationInvariants #-}--- Nothing => OK, Just doc => doc gives info-checkImplicationInvariants implic = when debugIsOn (check_implic implic)--check_implic implic@(Implic { ic_tclvl = lvl-                            , ic_info = skol_info-                            , ic_skols = skols })-  | null bads = pure ()-  | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure"-                                       , nest 2 (vcat bads)-                                       , ppr implic ])-  where-    bads = mapMaybe check skols--    check :: TcTyVar -> Maybe SDoc-    check tv | not (isTcTyVar tv)-             = Just (ppr tv <+> text "is not a TcTyVar")-             | otherwise-             = check_details tv (tcTyVarDetails tv)--    check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc-    check_details tv (SkolemTv tv_skol_info tv_lvl _)-      | not (tv_lvl == lvl)-      = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl-                   , text "ic_lvl" <+> ppr lvl ])-      | not (skol_info `checkSkolInfoAnon` skol_info_anon)-      = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon-                   , text "ic_info" <+> ppr skol_info ])-      | otherwise-      = Nothing-      where-        skol_info_anon = getSkolemInfo tv_skol_info-    check_details tv details-      = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details)--checkSkolInfoAnon :: SkolemInfoAnon   -- From the implication-                  -> SkolemInfoAnon   -- From the type variable-                  -> Bool             -- True <=> ok--- Used only for debug-checking; checkImplicationInvariants--- So it doesn't matter much if its's incomplete-checkSkolInfoAnon sk1 sk2 = go sk1 sk2-  where-    go (SigSkol c1 t1 s1)   (SigSkol c2 t2 s2)   = c1==c2 && t1 `tcEqType` t2 && s1==s2-    go (SigTypeSkol cx1)    (SigTypeSkol cx2)    = cx1==cx2--    go (ForAllSkol _)       (ForAllSkol _)       = True--    go (IPSkol ips1)        (IPSkol ips2)        = ips1 == ips2-    go (DerivSkol pred1)    (DerivSkol pred2)    = pred1 `tcEqType` pred2-    go (TyConSkol f1 n1)    (TyConSkol f2 n2)    = f1==f2 && n1==n2-    go (DataConSkol n1)     (DataConSkol n2)     = n1==n2-    go (InstSkol {})        (InstSkol {})        = True-    go FamInstSkol          FamInstSkol          = True-    go BracketSkol          BracketSkol          = True-    go (RuleSkol n1)        (RuleSkol 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 &&-                                                   and (zipWith eq_pr ids1 ids2)-    go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2-    go ReifySkol            ReifySkol            = True-    go RuntimeUnkSkol       RuntimeUnkSkol       = True-    go ArrowReboundIfSkol   ArrowReboundIfSkol   = True-    go (UnkSkol _)          (UnkSkol _)          = True--    -------- Three slightly strange special cases ---------    go (DataConSkol _)      (TyConSkol f _)      = h98_data_decl f-    -- In the H98 declaration  data T a = forall b. MkT a b-    -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of-    -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol--    go (DataConSkol _)      FamInstSkol          = True-    -- In  data/newtype instance T a = MkT (a -> a),-    -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of-    -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol--    go FamInstSkol          (InstSkol {})         = True-    -- In instance C (T a) where { type F (T a) b = ... }-    -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi-    -- SkolemInfo of FamInstSkol.  Very like the ConDecl/TyConSkol case--    go (ForAllSkol _)       _                    = True-    -- Telescope tests: we need a ForAllSkol to force the telescope-    -- test, but the skolems might come from (say) a family instance decl-    --    type instance forall a. F [a] = a->a--    go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f-    -- e.g.   newtype T a = MkT ... deriving blah-    -- We use the skolems from T (TyConSkol) when typechecking-    -- the deriving clauses (SigTypeSkol DerivClauseCtxt)--    go _ _ = False--    eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool-    eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked--    h98_data_decl DataTypeFlavour = True-    h98_data_decl NewtypeFlavour  = True-    h98_data_decl _               = False---{- *********************************************************************-*                                                                      *-            Pretty printing-*                                                                      *-********************************************************************* -}--pprEvVars :: [EvVar] -> SDoc    -- Print with their types-pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)--pprEvVarTheta :: [EvVar] -> SDoc-pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)--pprEvVarWithType :: EvVar -> SDoc-pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)----wrapType :: Type -> [TyVar] -> [PredType] -> Type-wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty---{--************************************************************************-*                                                                      *-            CtEvidence-*                                                                      *-************************************************************************--Note [CtEvidence invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The `ctev_pred` field of a `CtEvidence` is a just a cache for the type-of the evidence. More precisely:--* For Givens, `ctev_pred` = `varType ctev_evar`-* For Wanteds, `ctev_pred` = `evDestType ctev_dest`--where--  evDestType :: TcEvDest -> TcType-  evDestType (EvVarDest evVar)       = varType evVar-  evDestType (HoleDest coercionHole) = varType (coHoleCoVar coercionHole)--The invariant is maintained by `setCtEvPredType`, the only function that-updates the `ctev_pred` field of a `CtEvidence`.--Why is the invariant important? Because when the evidence is a coercion, it may-be used in (CastTy ty co); and then we may call `typeKind` on that type (e.g.-in the kind-check of `eqType`); and expect to see a fully zonked kind.-(This came up in test T13333, in the MR that fixed #20641, namely !6942.)--Historical Note [Evidence field of CtEvidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the past we tried leaving the `ctev_evar`/`ctev_dest` field of a-constraint untouched (and hence un-zonked) on the grounds that it is-never looked at.  But in fact it is: the evidence can become part of a-type (via `CastTy ty kco`) and we may later ask the kind of that type-and expect a zonked result.  (For example, in the kind-check-of `eqType`.)--The safest thing is simply to keep `ctev_evar`/`ctev_dest` in sync-with `ctev_pref`, as stated in `Note [CtEvidence invariants]`.--Note [Bind new Givens immediately]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For Givens we make new EvVars and bind them immediately. Two main reasons:-  * Gain sharing.  E.g. suppose we start with g :: C a b, where-       class D a => C a b-       class (E a, F a) => D a-    If we generate all g's superclasses as separate EvTerms we might-    get    selD1 (selC1 g) :: E a-           selD2 (selC1 g) :: F a-           selC1 g :: D a-    which we could do more economically as:-           g1 :: D a = selC1 g-           g2 :: E a = selD1 g1-           g3 :: F a = selD2 g1--  * For *coercion* evidence we *must* bind each given:-      class (a~b) => C a b where ....-      f :: C a b => ....-    Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.-    But that superclass selector can't (yet) appear in a coercion-    (see evTermCoercion), so the easy thing is to bind it to an Id.--So a Given has EvVar inside it rather than (as previously) an EvTerm.---}---- | A place for type-checking evidence to go after it is generated.------  - Wanted equalities use HoleDest,---  - other Wanteds use EvVarDest.-data TcEvDest-  = EvVarDest EvVar         -- ^ bind this var to the evidence-              -- EvVarDest is always used for non-type-equalities-              -- e.g. class constraints--  | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence-              -- HoleDest is always used for type-equalities-              -- 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 }---  | 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]--ctEvPred :: CtEvidence -> TcPredType--- The predicate of a flavor-ctEvPred = ctev_pred--ctEvLoc :: CtEvidence -> CtLoc-ctEvLoc = ctev_loc--ctEvOrigin :: CtEvidence -> CtOrigin-ctEvOrigin = ctLocOrigin . ctEvLoc---- | Get the equality relation relevant for a 'CtEvidence'-ctEvEqRel :: CtEvidence -> EqRel-ctEvEqRel = predTypeEqRel . ctEvPred---- | Get the role relevant for a 'CtEvidence'-ctEvRole :: CtEvidence -> Role-ctEvRole = eqRelRole . ctEvEqRel--ctEvTerm :: CtEvidence -> EvTerm-ctEvTerm ev = EvExpr (ctEvExpr ev)---- | Extract the set of rewriters from a 'CtEvidence'--- See Note [Wanteds rewrite Wanteds]--- If the provided CtEvidence is not for a Wanted, just--- return an empty set.-ctEvRewriters :: CtEvidence -> RewriterSet-ctEvRewriters (CtWanted { ctev_rewriters = rewriters }) = rewriters-ctEvRewriters _other                                    = emptyRewriterSet--ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr-ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ })-            = Coercion $ ctEvCoercion ev-ctEvExpr ev = evId (ctEvEvId ev)--ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion-ctEvCoercion (CtGiven { ctev_evar = ev_id })-  = mkCoVarCo ev_id-ctEvCoercion (CtWanted { ctev_dest = dest })-  | HoleDest hole <- dest-  = -- ctEvCoercion is only called on type equalities-    -- and they always have HoleDests-    mkHoleCo hole-ctEvCoercion ev-  = 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--ctEvUnique :: CtEvidence -> Unique-ctEvUnique (CtGiven { ctev_evar = ev })    = varUnique ev-ctEvUnique (CtWanted { 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 }---- | Set the type of CtEvidence.------ This function ensures that the invariants on 'CtEvidence' hold, by updating--- 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 old_ctev@(CtWanted { ctev_dest = dest }) new_pred-  = old_ctev { ctev_pred = new_pred-             , ctev_dest = new_dest }-  where-    new_dest = case dest of-      EvVarDest ev -> EvVarDest (setVarType ev new_pred)-      HoleDest h   -> HoleDest  (setCoHoleType h new_pred)--instance Outputable TcEvDest where-  ppr (HoleDest h)   = text "hole" <> ppr h-  ppr (EvVarDest ev) = ppr ev--instance Outputable CtEvidence where-  ppr ev = ppr (ctEvFlavour ev)-           <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters)-                         -- Show the sub-goal depth too-               <> dcolon <+> ppr (ctEvPred ev)-    where-      pp_ev = case ev of-             CtGiven { ctev_evar = v } -> ppr v-             CtWanted {ctev_dest = d } -> ppr d--      rewriters = ctEvRewriters ev-      pp_rewriters | isEmptyRewriterSet rewriters = empty-                   | otherwise                    = semi <> ppr rewriters--isWanted :: CtEvidence -> Bool-isWanted (CtWanted {}) = True-isWanted _ = False--isGiven :: CtEvidence -> Bool-isGiven (CtGiven {})  = True-isGiven _ = False--{--************************************************************************-*                                                                      *-           RewriterSet-*                                                                      *-************************************************************************--}---- | Stores a set of CoercionHoles that have been used to rewrite a constraint.--- See Note [Wanteds rewrite Wanteds].-newtype RewriterSet = RewriterSet (UniqSet CoercionHole)-  deriving newtype (Outputable, Semigroup, Monoid)--emptyRewriterSet :: RewriterSet-emptyRewriterSet = RewriterSet emptyUniqSet--isEmptyRewriterSet :: RewriterSet -> Bool-isEmptyRewriterSet (RewriterSet set) = isEmptyUniqSet set--addRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet-addRewriterSet = coerce (addOneToUniqSet @CoercionHole)---- | Makes a 'RewriterSet' from all the coercion holes that occur in the--- given coercion.-rewriterSetFromCo :: Coercion -> RewriterSet-rewriterSetFromCo co = appEndo (rewriter_set_from_co co) emptyRewriterSet---- | Makes a 'RewriterSet' from all the coercion holes that occur in the--- given type.-rewriterSetFromType :: Type -> RewriterSet-rewriterSetFromType ty = appEndo (rewriter_set_from_ty ty) emptyRewriterSet---- | Makes a 'RewriterSet' from all the coercion holes that occur in the--- given types.-rewriterSetFromTypes :: [Type] -> RewriterSet-rewriterSetFromTypes tys = appEndo (rewriter_set_from_tys tys) emptyRewriterSet--rewriter_set_from_ty :: Type -> Endo RewriterSet-rewriter_set_from_tys :: [Type] -> Endo RewriterSet-rewriter_set_from_co :: Coercion -> Endo RewriterSet-(rewriter_set_from_ty, rewriter_set_from_tys, rewriter_set_from_co, _)-  = foldTyCo folder ()-  where-    folder :: TyCoFolder () (Endo RewriterSet)-    folder = TyCoFolder-               { tcf_view  = noView-               , tcf_tyvar = \ _ tv -> rewriter_set_from_ty (tyVarKind tv)-               , tcf_covar = \ _ cv -> rewriter_set_from_ty (varType cv)-               , tcf_hole  = \ _ hole -> coerce (`addOneToUniqSet` hole) S.<>-                                         rewriter_set_from_ty (varType (coHoleCoVar hole))-               , tcf_tycobinder = \ _ _ _ -> () }--{--************************************************************************-*                                                                      *-           CtFlavour-*                                                                      *-************************************************************************--}--data CtFlavour-  = Given     -- we have evidence-  | Wanted    -- we want evidence-  deriving Eq--instance Outputable CtFlavour where-  ppr Given  = text "[G]"-  ppr Wanted = text "[W]"--ctEvFlavour :: CtEvidence -> CtFlavour-ctEvFlavour (CtWanted {}) = Wanted-ctEvFlavour (CtGiven {})  = Given---- | Whether or not one 'Ct' can rewrite another is determined by its--- flavour and its equality relation. See also--- Note [Flavours with roles] in GHC.Tc.Solver.InertSet-type CtFlavourRole = (CtFlavour, EqRel)---- | Extract the flavour, role, and boxity from a 'CtEvidence'-ctEvFlavourRole :: CtEvidence -> CtFlavourRole-ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev)---- | Extract the flavour and role from a 'Ct'-ctFlavourRole :: Ct -> CtFlavourRole--- Uses short-cuts to role for special cases-ctFlavourRole (CDictCan { cc_ev = ev })-  = (ctEvFlavour ev, NomEq)-ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })-  = (ctEvFlavour ev, eq_rel)-ctFlavourRole ct-  = ctEvFlavourRole (ctEvidence ct)--{- Note [eqCanRewrite]-~~~~~~~~~~~~~~~~~~~~~~-(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form-lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of-a can-rewrite relation, see Definition [Can-rewrite relation] in-GHC.Tc.Solver.Monad.--With the solver handling Coercible constraints like equality constraints,-the rewrite conditions must take role into account, never allowing-a representational equality to rewrite a nominal one.--Note [Wanteds rewrite Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should one Wanted constraint be allowed to rewrite another?--This example (along with #8450) suggests not:-   f :: a -> Bool-   f x = ( [x,'c'], [x,True] ) `seq` True-Here we get-  [W] a ~ Char-  [W] a ~ Bool-but we do not want to complain about Bool ~ Char!--This example suggests yes (indexed-types/should_fail/T4093a):-  type family Foo a-  f :: (Foo e ~ Maybe e) => Foo e-In the ambiguity check, we get-  [G] g1 :: Foo e ~ Maybe e-  [W] w1 :: Foo alpha ~ Foo e-  [W] w2 :: Foo alpha ~ Maybe alpha-w1 gets rewritten by the Given to become-  [W] w3 :: Foo alpha ~ Maybe e-Now, the only way to make progress is to allow Wanteds to rewrite Wanteds.-Rewriting w3 with w2 gives us-  [W] w4 :: Maybe alpha ~ Maybe e-which will soon get us to alpha := e and thence to victory.--TL;DR we want equality saturation.--We thus want Wanteds to rewrite Wanteds in order to accept more programs,-but we don't want Wanteds to rewrite Wanteds because doing so can create-inscrutable error messages. We choose to allow the rewriting, but-every Wanted tracks the set of Wanteds it has been rewritten by. This is-called a RewriterSet, stored in the ctev_rewriters field of the CtWanted-constructor of CtEvidence.  (Only Wanteds have RewriterSets.)--Let's continue our first example above:--  inert: [W] w1 :: a ~ Char-  work:  [W] w2 :: a ~ Bool--Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding--  inert: [W] w1 :: a ~ Char-         [W] w2 {w1}:: Char ~ Bool--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 rewriteEvidence and-rewriteEqEvidence (in GHC.Tc.Solver.Canonical) add this RewriterSet to-the rewritten constraint's rewriter set.--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.Utils.anyUnfilledCoercionHoles 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.--Wrinkle: In #22707, we have a case 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 written a confusing program!--Note [Avoiding rewriting cycles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes-the can-rewrite relation among CtFlavour/Role pairs, saying which constraints-can rewrite which other constraints. It puts forth (R2):-  (R2) If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1-The naive can-rewrite relation says that (Given, Representational) can rewrite-(Wanted, Representational) and that (Wanted, Nominal) can rewrite-(Wanted, Representational), but neither of (Given, Representational) and-(Wanted, Nominal) can rewrite the other. This would violate (R2). See also-Note [Why R2?] in GHC.Tc.Solver.InertSet.--To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational).-This can, in theory, bite, in this scenario:--  type family F a-  data T a-  type role T nominal--  [G] F a ~N T a-  [W] F alpha ~N T alpha-  [W] F alpha ~R T a--As written, this makes no progress, and GHC errors. But, if we-allowed W/N to rewrite W/R, the first W could rewrite the second:--  [G] F a ~N T a-  [W] F alpha ~N T alpha-  [W] T alpha ~R T a--Now we decompose the second W to get--  [W] alpha ~N a--noting the role annotation on T. This causes (alpha := a), and then-everything else unlocks.--What to do? We could "decompose" nominal equalities into nominal-only-("NO") equalities and representational ones, where a NO equality rewrites-only nominals. That is, when considering whether [W] F alpha ~N T alpha-should rewrite [W] F alpha ~R T a, we could require splitting the first W-into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R-half of the split to rewrite the second W, and off we go. This splitting-would allow the split-off R equality to be rewritten by other equalities,-thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet.--However, note that I said that this bites in theory. That's because no-known program actually gives rise to this scenario. A direct encoding-ends up starting with--  [G] F a ~ T a-  [W] F alpha ~ T alpha-  [W] Coercible (F alpha) (T a)--where ~ and Coercible denote lifted class constraints. The ~s quickly-reduce to ~N: good. But the Coercible constraint gets rewritten to--  [W] Coercible (T alpha) (T a)--by the first Wanted. This is because Coercible is a class, and arguments-in class constraints use *nominal* rewriting, not the representational-rewriting that is restricted due to (R2). Note that reordering the code-doesn't help, because equalities (including lifted ones) are prioritized-over Coercible. Thus, I (Richard E.) see no way to write a program that-is rejected because of this infelicity. I have not proved it impossible,-exactly, but my usual tricks have not yielded results.--In the olden days, when we had Derived constraints, this Note was all-about G/R and D/N both rewriting D/R. Back then, the code in-typecheck/should_compile/T19665 really did get rejected. But now,-according to the rewriting of the Coercible constraint, the program-is accepted.---}--eqCanRewrite :: EqRel -> EqRel -> Bool-eqCanRewrite NomEq  _      = True-eqCanRewrite ReprEq ReprEq = True-eqCanRewrite ReprEq NomEq  = False--eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool--- Can fr1 actually rewrite fr2?--- Very important function!--- See Note [eqCanRewrite]--- See Note [Wanteds rewrite Wanteds]--- See Note [Avoiding rewriting cycles]-eqCanRewriteFR (Given,  r1)    (_,      r2)     = eqCanRewrite r1 r2-eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False-eqCanRewriteFR (Wanted, r1)    (Wanted, r2)     = eqCanRewrite r1 r2-eqCanRewriteFR (Wanted, _)     (Given, _)       = False--{--************************************************************************-*                                                                      *-            SubGoalDepth-*                                                                      *-************************************************************************--Note [SubGoalDepth]-~~~~~~~~~~~~~~~~~~~-The 'SubGoalDepth' takes care of stopping the constraint solver from looping.--The counter starts at zero and increases. It includes dictionary constraints,-equality simplification, and type family reduction. (Why combine these? Because-it's actually quite easy to mistake one for another, in sufficiently involved-scenarios, like ConstraintKinds.)--The flag -freduction-depth=n fixes the maximum level.--* The counter includes the depth of type class instance declarations.  Example:-     [W] d{7} : Eq [Int]-  That is d's dictionary-constraint depth is 7.  If we use the instance-     $dfEqList :: Eq a => Eq [a]-  to simplify it, we get-     d{7} = $dfEqList d'{8}-  where d'{8} : Eq Int, and d' has depth 8.--  For civilised (decidable) instance declarations, each increase of-  depth removes a type constructor from the type, so the depth never-  gets big; i.e. is bounded by the structural depth of the type.--* The counter also increments when resolving-equalities involving type functions. Example:-  Assume we have a wanted at depth 7:-    [W] d{7} : F () ~ a-  If there is a type function equation "F () = Int", this would be rewritten to-    [W] d{8} : Int ~ a-  and remembered as having depth 8.--  Again, without UndecidableInstances, this counter is bounded, but without it-  can resolve things ad infinitum. Hence there is a maximum level.--* Lastly, every time an equality is rewritten, the counter increases. Again,-  rewriting an equality constraint normally makes progress, but it's possible-  the "progress" is just the reduction of an infinitely-reducing type family.-  Hence we need to track the rewrites.--When compiling a program requires a greater depth, then GHC recommends turning-off this check entirely by setting -freduction-depth=0. This is because the-exact number that works is highly variable, and is likely to change even between-minor releases. Because this check is solely to prevent infinite compilation-times, it seems safe to disable it when a user has ascertained that their program-doesn't loop at the type level.---}---- | See Note [SubGoalDepth]-newtype SubGoalDepth = SubGoalDepth Int-  deriving (Eq, Ord, Outputable)--initialSubGoalDepth :: SubGoalDepth-initialSubGoalDepth = SubGoalDepth 0--bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth-bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1)--maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth-maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m)--subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool-subGoalDepthExceeded dflags (SubGoalDepth d)-  = mkIntWithInf d > reductionDepth dflags--{--************************************************************************-*                                                                      *-            CtLoc-*                                                                      *-************************************************************************--The 'CtLoc' gives information about where a constraint came from.-This is important for decent error message reporting because-dictionaries don't appear in the original source code.---}--data CtLoc = CtLoc { ctl_origin   :: CtOrigin-                   , ctl_env      :: TcLclEnv-                   , ctl_t_or_k   :: Maybe TypeOrKind  -- OK if we're not sure-                   , ctl_depth    :: !SubGoalDepth }--  -- The TcLclEnv includes particularly-  --    source location:  tcl_loc   :: RealSrcSpan-  --    context:          tcl_ctxt  :: [ErrCtxt]-  --    binder stack:     tcl_bndrs :: TcBinderStack-  --    level:            tcl_tclvl :: TcLevel--mkKindLoc :: TcType -> TcType   -- original *types* being compared-          -> CtLoc -> CtLoc-mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)-                        (KindEqOrigin s1 s2 (ctLocOrigin loc)-                                      (ctLocTypeOrKind_maybe loc))---- | Take a CtLoc and moves it to the kind level-toKindLoc :: CtLoc -> CtLoc-toKindLoc loc = loc { ctl_t_or_k = Just KindLevel }--mkGivenLoc :: TcLevel -> SkolemInfoAnon -> TcLclEnv -> CtLoc-mkGivenLoc tclvl skol_info env-  = CtLoc { ctl_origin   = GivenOrigin skol_info-          , ctl_env      = setLclEnvTcLevel env tclvl-          , ctl_t_or_k   = Nothing    -- this only matters for error msgs-          , ctl_depth    = initialSubGoalDepth }--ctLocEnv :: CtLoc -> TcLclEnv-ctLocEnv = ctl_env--ctLocLevel :: CtLoc -> TcLevel-ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc)--ctLocDepth :: CtLoc -> SubGoalDepth-ctLocDepth = ctl_depth--ctLocOrigin :: CtLoc -> CtOrigin-ctLocOrigin = ctl_origin--ctLocSpan :: CtLoc -> RealSrcSpan-ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc lcl--ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind-ctLocTypeOrKind_maybe = ctl_t_or_k--setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc-setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setLclEnvLoc lcl loc)--bumpCtLocDepth :: CtLoc -> CtLoc-bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d }--setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc-setCtLocOrigin ctl orig = ctl { ctl_origin = orig }--updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc-updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd-  = ctl { ctl_origin = upd orig }--setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc-setCtLocEnv ctl env = ctl { ctl_env = env }--pprCtLoc :: CtLoc -> SDoc--- "arising from ... at ..."--- Not an instance of Outputable because of the "arising from" prefix-pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl})-  = sep [ pprCtOrigin o-        , text "at" <+> ppr (getLclEnvLoc lcl)]+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- | This module defines types and simple operations over constraints, as used+-- in the type-checker and constraint solver.+module GHC.Tc.Types.Constraint (+        -- Constraints+        Xi, Ct(..), Cts,+        singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,+        isEmptyCts, emptyCts, andCts, ctsPreds,+        isPendingScDictCt, isPendingScDict, pendingScDict_maybe,+        superClassesMightHelp, getPendingWantedScs,+        isWantedCt, isGivenCt,+        isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg,+        isUnsatisfiableCt_maybe,+        ctEvidence, updCtEvidence,+        ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,+        ctRewriters, ctHasNoRewriters, wantedCtHasNoRewriters,+        ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv,+        mkNonCanonical, mkGivens,+        tyCoVarsOfCt, tyCoVarsOfCts,+        tyCoVarsOfCtList, tyCoVarsOfCtsList,+        boundOccNamesOfWC,++        -- Particular forms of constraint+        EqCt(..),    eqCtEvidence, eqCtLHS,+        DictCt(..),  dictCtEvidence, dictCtPred,+        IrredCt(..), irredCtEvidence, mkIrredCt, ctIrredCt, irredCtPred,++        -- QCInst+        QCInst(..), pendingScInst_maybe,++        ExpansionFuel, doNotExpand, consumeFuel, pendingFuel,+        assertFuelPrecondition, assertFuelPreconditionStrict,++        CtIrredReason(..), isInsolubleReason,++        CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,+        cteOK, cteImpredicative, cteTypeFamily,+        cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,+        cteConcrete, cteSkolemEscape,+        impredicativeProblem, insolubleOccursProblem, solubleOccursProblem,++        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(..),++        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,+        isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,+        addInsols, dropMisleading, addSimples, addImplics, addHoles,+        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,++        -- CtEvidence+        CtEvidence(..), TcEvDest(..),+        isWanted, isGiven,+        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,+        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+        addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts,++        wrapType,++        CtFlavour(..), ctEvFlavour,+        CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCtFlavourRole,+        eqCanRewrite, eqCanRewriteFR,++        -- Pretty printing+        pprEvVarTheta,+        pprEvVars, pprEvVarWithType,++  )+  where++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++import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Origin+import GHC.Tc.Types.CtLoc++import GHC.Builtin.Names++import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.Name.Reader++import GHC.Utils.FV+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)++import GHC.Data.Bag++import Data.Coerce+import qualified Data.Semigroup as S+import Control.Monad ( msum, when )+import Data.Maybe ( mapMaybe, isJust )++-- these are for CheckTyEqResult+import Data.Word  ( Word8 )+import Data.List  ( intersperse )++++{-+************************************************************************+*                                                                      *+*                       Canonical constraints                          *+*                                                                      *+*   These are the constraints the low-level simplifier works with      *+*                                                                      *+************************************************************************+-}++-- | A 'Xi'-type is one that has been fully rewritten with respect+-- to the inert set; that is, it has been rewritten by the algorithm+-- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years,+-- meant that a type was type-family-free. It does *not* mean this+-- any more.)+type Xi = TcType++type Cts = Bag Ct++-- | Says how many layers of superclasses can we expand.+--   Invariant: ExpansionFuel should always be >= 0+-- see Note [Expanding Recursive Superclasses and ExpansionFuel]+type ExpansionFuel = Int++-- | Do not expand superclasses any further+doNotExpand :: ExpansionFuel+doNotExpand = 0++-- | Consumes one unit of fuel.+--   Precondition: fuel > 0+consumeFuel :: ExpansionFuel -> ExpansionFuel+consumeFuel fuel = assertFuelPreconditionStrict fuel $ fuel - 1++-- | Returns True if we have any fuel left for superclass expansion+pendingFuel :: ExpansionFuel -> Bool+pendingFuel n = n > 0++insufficientFuelError :: SDoc+insufficientFuelError = text "Superclass expansion fuel should be > 0"++-- | asserts if fuel is non-negative+assertFuelPrecondition :: ExpansionFuel -> a -> a+{-# INLINE assertFuelPrecondition #-}+assertFuelPrecondition fuel = assertPpr (fuel >= 0) insufficientFuelError++-- | asserts if fuel is strictly greater than 0+assertFuelPreconditionStrict :: ExpansionFuel -> a -> a+{-# INLINE assertFuelPreconditionStrict #-}+assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError++-- | Constraint+data Ct+  -- | A dictionary constraint (canonical)+  = CDictCan      DictCt+  -- | 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]++           , di_cls :: Class+           , di_tys :: [Xi]   -- di_tys are rewritten w.r.t. inerts, so Xi++           , di_pend_sc :: ExpansionFuel+               -- See Note [The superclass story] in GHC.Tc.Solver.Dict+               -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver+               -- Invariants: di_pend_sc > 0 <=>+               --                    (a) di_cls has superclasses+               --                    (b) those superclasses are not yet explored+    }++dictCtEvidence :: DictCt -> CtEvidence+dictCtEvidence = di_ev++dictCtPred :: DictCt -> TcPredType+dictCtPred (DictCt { di_cls = cls, di_tys = tys }) = mkClassPred cls tys++instance Outputable DictCt where+  ppr dict = ppr (CDictCan dict)++--------------- EqCt --------------++{- 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 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 heterogeneous kinds] in+    GHC.Tc.Solver.Equality, wrinkle (EIK2)++These invariants ensure that the EqCts in inert_eqs constitute a terminating+generalised substitution. See Note [inert_eqs: the inert equalities]+in GHC.Tc.Solver.InertSet for what these words mean!++Note [EqCt occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A CEqCan relates a CanEqLHS (a type variable or type family applications) on+its left to an arbitrary type on its right. It is used for rewriting.+Because it is used for rewriting, it would be disastrous if the RHS+were to mention the LHS: this would cause a loop in rewriting.++We thus perform an occurs-check. There is, of course, some subtlety:++* 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, 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+  look in kinds or coercions.) An occurrence of the LHS in, say, an+  RHS coercion is OK, as we do not rewrite in coercions. No loop to+  be found.++  You might also worry about the possibility that a type family+  application LHS doesn't exactly appear in the RHS, but something+  that reduces to the LHS does. Yet that can't happen: the RHS is+  already inert, with all type family redexes reduced. So a simple+  syntactic check is just fine.++The occurs check is performed in GHC.Tc.Utils.Unify.checkTyEqRhs+and forms condition T3 in Note [Extending the inert equalities]+in GHC.Tc.Solver.InertSet.+-}++-- | 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,+      eq_rhs    :: Xi,         -- See invariants above+      eq_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev+    }++eqCtEvidence :: EqCt -> CtEvidence+eqCtEvidence = eq_ev++eqCtLHS :: EqCt -> CanEqLHS+eqCtLHS = eq_lhs++--------------- IrredCt --------------++data IrredCt    -- These stand for yet-unusable predicates+                -- See Note [CIrredCan constraints]+  = IrredCt { ir_ev     :: CtEvidence   -- See Note [Ct/evidence invariant]+            , ir_reason :: CtIrredReason }++mkIrredCt :: CtIrredReason -> CtEvidence -> Ct+mkIrredCt reason ev = CIrredCan (IrredCt { ir_ev = ev, ir_reason = reason })++irredCtEvidence :: IrredCt -> CtEvidence+irredCtEvidence = ir_ev++irredCtPred :: IrredCt -> PredType+irredCtPred = ctEvPred . irredCtEvidence++ctIrredCt :: CtIrredReason -> Ct -> IrredCt+ctIrredCt _      (CIrredCan ir) = ir+ctIrredCt reason ct             = IrredCt { ir_ev = ctEvidence ct+                                          , ir_reason = reason }++instance Outputable IrredCt where+  ppr irred = ppr (CIrredCan irred)++--------------- QCInst --------------++-- | 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_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+    }++instance Outputable QCInst where+  ppr (QCI { qci_ev = ev }) = ppr ev++------------------------------------------------------------------------------+--+-- Holes and other delayed errors+--+------------------------------------------------------------------------------++-- | A delayed error, to be reported after constraint solving, in order to benefit+-- from deferred unifications.+data DelayedError+  = DE_Hole Hole+    -- ^ A hole (in a type or in a term).+    --+    -- 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 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+         , hole_ty   :: TcType   -- ^ Type to be printed to the user+                                 -- For expression holes: type of expr+                                 -- For type holes: the missing type+         , hole_loc  :: CtLoc    -- ^ Where hole was written+         }+           -- For the hole_loc, we usually only want the TcLclEnv stored within.+           -- Except when we rewrite, where we need a whole location. And this+           -- might get reported to the user if reducing type families in a+           -- hole type loops.+++-- | Used to indicate which sort of hole we have.+data HoleSort = ExprHole HoleExprRef+                 -- ^ Either an out-of-scope variable or a "true" hole in an+                 -- expression (TypedHoles).+                 -- The HoleExprRef says where to write the+                 -- the erroring expression for -fdefer-type-errors.+              | TypeHole+                 -- ^ A hole in a type (PartialTypeSignatures)+              | ConstraintHole+                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...+                 -- Differentiated from TypeHole because a ConstraintHole+                 -- is simplified differently. See+                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.++instance Outputable Hole where+  ppr (Hole { hole_sort = ExprHole ref+            , hole_occ  = occ+            , hole_ty   = ty })+    = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty+  ppr (Hole { hole_sort = _other+            , hole_occ  = occ+            , hole_ty   = ty })+    = braces $ ppr occ <> colon <> ppr ty++instance Outputable HoleSort where+  ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref+  ppr TypeHole       = text "TypeHole"+  ppr ConstraintHole = text "ConstraintHole"++-- | Why did we require that a certain type be concrete?+data NotConcreteError+  -- | Concreteness was required by a representation-polymorphism+  -- check.+  --+  -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.+  = NCE_FRR+    { nce_loc        :: CtLoc+      -- ^ Where did this check take place?+    , nce_frr_origin :: FixedRuntimeRepOrigin+      -- ^ Which representation-polymorphism check did we perform?+    }++instance Outputable NotConcreteError where+  ppr (NCE_FRR { nce_frr_origin = frr_orig })+    = text "NCE_FRR" <+> parens (ppr (frr_type frr_orig))++------------+-- | Used to indicate extra information about why a CIrredCan is irreducible+data CtIrredReason+  = IrredShapeReason+      -- ^ This constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@)++  | NonCanonicalReason CheckTyEqResult+   -- ^ An equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;+   -- the 'CheckTyEqResult' states exactly why++  | ReprEqReason+    -- ^ An equality that cannot be decomposed because it is representational.+    -- Example: @a b ~R# Int@.+    -- These might still be solved later.+    -- INVARIANT: The constraint is a representational equality constraint++  | ShapeMismatchReason+    -- ^ A nominal equality that relates two wholly different types,+    -- like @Int ~# Bool@ or @a b ~# 3@.+    -- INVARIANT: The constraint is a nominal equality constraint++  | AbstractTyConReason+    -- ^ An equality like @T a b c ~ Q d e@ where either @T@ or @Q@+    -- is an abstract type constructor. See Note [Skolem abstract data]+    -- in GHC.Core.TyCon.+    -- INVARIANT: The constraint is an equality constraint between two TyConApps++  | PluginReason+    -- ^ A typechecker plugin returned this in the pluginBadCts field+    -- of TcPluginProgress++instance Outputable CtIrredReason where+  ppr IrredShapeReason          = text "(irred)"+  ppr (NonCanonicalReason cter) = ppr cter+  ppr ReprEqReason              = text "(repr)"+  ppr ShapeMismatchReason       = text "(shape)"+  ppr AbstractTyConReason       = text "(abstc)"+  ppr PluginReason              = text "(plugin)"++-- | Are we sure that more solving will never solve this constraint?+isInsolubleReason :: CtIrredReason -> Bool+isInsolubleReason IrredShapeReason          = False+isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter+isInsolubleReason ReprEqReason              = False+isInsolubleReason ShapeMismatchReason       = True+isInsolubleReason AbstractTyConReason       = True+isInsolubleReason PluginReason              = True++------------------------------------------------------------------------------+--+-- CheckTyEqResult, defined here because it is stored in a CtIrredReason+--+------------------------------------------------------------------------------++-- | A /set/ of problems in checking the validity of a type equality.+-- See 'checkTypeEq'.+newtype CheckTyEqResult = CTER Word8++-- | No problems in checking the validity of a type equality.+cteOK :: CheckTyEqResult+cteOK = CTER zeroBits++-- | Check whether a 'CheckTyEqResult' is marked successful.+cterHasNoProblem :: CheckTyEqResult -> Bool+cterHasNoProblem (CTER 0) = True+cterHasNoProblem _        = False++-- | An /individual/ problem that might be logged in a 'CheckTyEqResult'+newtype CheckTyEqProblem = CTEP Word8++cteImpredicative, cteTypeFamily, cteInsolubleOccurs,+  cteSolubleOccurs, cteConcrete,+  cteSkolemEscape :: CheckTyEqProblem+cteImpredicative   = CTEP (bit 0)   -- Forall or (=>) encountered+cteTypeFamily      = CTEP (bit 1)   -- Type family encountered++cteInsolubleOccurs = CTEP (bit 2)   -- Occurs-check+cteSolubleOccurs   = CTEP (bit 3)   -- Occurs-check under a type function, or in a coercion,+                                    -- or in a representational equality; see+   -- See Note [Occurs check and representational equality]+   -- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs+   -- See also Note [Insoluble mis-match] in GHC.Tc.Errors++-- 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+cteProblem (CTEP mask) = CTER mask++impredicativeProblem, insolubleOccursProblem, solubleOccursProblem :: CheckTyEqResult+impredicativeProblem   = cteProblem cteImpredicative+insolubleOccursProblem = cteProblem cteInsolubleOccurs+solubleOccursProblem   = cteProblem cteSolubleOccurs++occurs_mask :: Word8+occurs_mask = insoluble_mask .|. soluble_mask+  where+    CTEP insoluble_mask = cteInsolubleOccurs+    CTEP soluble_mask   = cteSolubleOccurs++-- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem'+cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool+CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0++-- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other+cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool+CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask++cterHasOnlyProblems :: CheckTyEqResult -> CheckTyEqResult -> Bool+CTER bits `cterHasOnlyProblems` CTER mask = (bits .&. complement mask) == 0++cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult+cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask)++cterHasOccursCheck :: CheckTyEqResult -> Bool+cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0++cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult+cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask)++-- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs+-- check under a type family or in a representation equality is soluble.+cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult+cterSetOccursCheckSoluble (CTER bits)+  = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask)+  where+    CTEP insoluble_mask = cteInsolubleOccurs++-- | Retain only information about occurs-check failures, because only that+-- matters after recurring into a kind.+cterFromKind :: CheckTyEqResult -> CheckTyEqResult+cterFromKind (CTER bits)+  = CTER (bits .&. occurs_mask)++cterIsInsoluble :: CheckTyEqResult -> Bool+cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0+  where+    mask = impredicative_mask .|. insoluble_occurs_mask++    CTEP impredicative_mask    = cteImpredicative+    CTEP insoluble_occurs_mask = cteInsolubleOccurs++instance Semigroup CheckTyEqResult where+  CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2)+instance Monoid CheckTyEqResult where+  mempty = cteOK++instance Eq CheckTyEqProblem where+  (CTEP b1) == (CTEP b2) = b1==b2++instance Outputable CheckTyEqProblem where+  ppr prob@(CTEP bits) = case lookup prob allBits of+                Just s  -> text s+                Nothing -> text "unknown:" <+> ppr bits++instance Outputable CheckTyEqResult where+  ppr cter | cterHasNoProblem cter+           = text "cteOK"+           | otherwise+           = braces $ fcat $ intersperse vbar $+             [ text str+             | (bitmask, str) <- allBits+             , cter `cterHasProblem` bitmask ]++allBits :: [(CheckTyEqProblem, String)]+allBits = [ (cteImpredicative,   "cteImpredicative")+          , (cteTypeFamily,      "cteTypeFamily")+          , (cteInsolubleOccurs, "cteInsolubleOccurs")+          , (cteSolubleOccurs,   "cteSolubleOccurs")+          , (cteConcrete,        "cteConcrete")+          , (cteSkolemEscape,    "cteSkolemEscape") ]++{- Note [CIrredCan constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CIrredCan constraints are used for constraints that are "stuck"+   - we can't solve them (yet)+   - we can't use them to solve other constraints+   - but they may become soluble if we substitute for some+     of the type variables in the constraint++Example 1:  (c Int), where c :: * -> Constraint.  We can't do anything+            with this yet, but if later c := Num, *then* we can solve it++Example 2:  a ~ b, where a :: *, b :: k, where k is a kind variable+            We don't want to use this to substitute 'b' for 'a', in case+            'k' is subsequently unified with (say) *->*, because then+            we'd have ill-kinded types floating about.  Rather we want+            to defer using the equality altogether until 'k' get resolved.++Note [Ct/evidence invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If  ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field+of (cc_ev ct), and is fully rewritten wrt the substitution.   Eg for DictCt,+   ctev_pred (di_ev ct) = (di_cls ct) (di_tys ct)+This holds by construction; look at the unique place where DictCt is+built (in GHC.Tc.Solver.Dict.canDictNC).++Note [Ct kind invariant]+~~~~~~~~~~~~~~~~~~~~~~~~+CEqCan requires that the kind of the lhs matches the kind+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.+-}++mkNonCanonical :: CtEvidence -> Ct+mkNonCanonical ev = CNonCanonical ev++mkGivens :: CtLoc -> [EvId] -> [Ct]+mkGivens loc ev_ids+  = map mk ev_ids+  where+    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+ctEvidence (CEqCan (EqCt { eq_ev = ev }))       = ev+ctEvidence (CIrredCan (IrredCt { ir_ev = ev })) = ev+ctEvidence (CNonCanonical ev)                   = ev+ctEvidence (CDictCan (DictCt { di_ev = ev }))   = ev++updCtEvidence :: (CtEvidence -> CtEvidence) -> Ct -> Ct+updCtEvidence upd ct+ = case ct of+     CQuantCan qci@(QCI { qci_ev = ev })   -> CQuantCan (qci { qci_ev = upd ev })+     CEqCan eq@(EqCt { eq_ev = ev })       -> CEqCan    (eq { eq_ev = upd ev })+     CIrredCan ir@(IrredCt { ir_ev = ev }) -> CIrredCan (ir { ir_ev = upd ev })+     CNonCanonical ev                      -> CNonCanonical (upd ev)+     CDictCan di@(DictCt { di_ev = ev })   -> CDictCan (di { di_ev = upd ev })++ctLoc :: Ct -> CtLoc+ctLoc = ctEvLoc . ctEvidence++ctOrigin :: Ct -> CtOrigin+ctOrigin = ctLocOrigin . ctLoc++ctPred :: Ct -> PredType+-- See Note [Ct/evidence invariant]+ctPred ct = ctEvPred (ctEvidence ct)++ctRewriters :: Ct -> RewriterSet+ctRewriters = ctEvRewriters . ctEvidence++ctEvId :: HasDebugCallStack => Ct -> EvVar+-- The evidence Id for this Ct+ctEvId ct = ctEvEvId (ctEvidence ct)++-- | Returns the evidence 'Id' for the argument 'Ct'+-- when this 'Ct' is a 'Wanted'.+--+-- Returns 'Nothing' otherwise.+wantedEvId_maybe :: Ct -> Maybe EvVar+wantedEvId_maybe ct+  = case ctEvidence ct of+    ctev@(CtWanted {})+      | otherwise+      -> Just $ ctEvEvId ctev+    CtGiven {}+      -> Nothing++-- | Makes a new equality predicate with the same role as the given+-- evidence.+mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType+mkTcEqPredLikeEv ev+  = case predTypeEqRel pred of+      NomEq  -> mkNomEqPred+      ReprEq -> mkReprEqPred+  where+    pred = ctEvPred ev++-- | Get the flavour of the given 'Ct'+ctFlavour :: Ct -> CtFlavour+ctFlavour = ctEvFlavour . ctEvidence++-- | Get the equality relation for the given 'Ct'+ctEqRel :: Ct -> EqRel+ctEqRel = ctEvEqRel . ctEvidence++instance Outputable Ct where+  ppr ct = ppr (ctEvidence ct) <+> parens pp_sort+    where+      pp_sort = case ct of+         CEqCan {}        -> text "CEqCan"+         CNonCanonical {} -> text "CNonCanonical"+         CDictCan (DictCt { di_pend_sc = psc })+            | psc > 0       -> text "CDictCan" <> parens (text "psc" <+> ppr psc)+            | otherwise     -> text "CDictCan"+         CIrredCan (IrredCt { ir_reason = reason }) -> text "CIrredCan" <> ppr reason+         CQuantCan (QCI { qci_pend_sc = psc })+            | psc > 0  -> text "CQuantCan"  <> parens (text "psc" <+> ppr psc)+            | otherwise -> text "CQuantCan"++instance Outputable EqCt where+  ppr (EqCt { eq_ev = ev }) = ppr ev++{-+************************************************************************+*                                                                      *+        Simple functions over evidence variables+*                                                                      *+************************************************************************+-}++---------------- Getting bound tyvars -------------------------+boundOccNamesOfWC :: WantedConstraints -> [OccName]+-- Return the OccNames of skolem-bound type variables+-- We could recurse into types, and get the forall-bound ones too,+-- but I'm going wait until that is needed+-- See Note [tidyAvoiding] in GHC.Core.TyCo.Tidy+boundOccNamesOfWC wc = bagToList (go_wc wc)+  where+    go_wc (WC { wc_impl = implics })+      = concatMapBag go_implic implics+    go_implic (Implic { ic_skols = tvs, ic_wanted = wc })+      = listToBag (map getOccName tvs) `unionBags` go_wc wc+++---------------- Getting free tyvars -------------------------++-- | Returns free variables of constraints as a non-deterministic set+tyCoVarsOfCt :: Ct -> TcTyCoVarSet+tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt++-- | Returns free variables of constraints as a non-deterministic set+tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet+tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv++-- | Returns free variables of constraints as a deterministically ordered+-- list. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoVarsOfCtList :: Ct -> [TcTyCoVar]+tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt++-- | Returns free variables of constraints as a deterministically ordered+-- list. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar]+tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred++-- | Returns free variables of constraints as a composable FV computation.+-- See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfCt :: Ct -> FV+tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)+  -- This must consult only the ctPred, so that it gets *tidied* fvs if the+  -- constraint has been tidied. Tidying a constraint does not tidy the+  -- fields of the Ct, only the predicate in the CtEvidence.++-- | Returns free variables of constraints as a composable FV computation.+-- See Note [Deterministic FV] in GHC.Utils.FV.+tyCoFVsOfCtEv :: CtEvidence -> FV+tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct)++-- | Returns free variables of a bag of constraints as a non-deterministic+-- set. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfCts :: Cts -> TcTyCoVarSet+tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts++-- | Returns free variables of a bag of constraints as a deterministically+-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfCtsList :: Cts -> [TcTyCoVar]+tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts++-- | Returns free variables of a bag of constraints as a deterministically+-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar]+tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs++-- | Returns free variables of a bag of constraints as a composable FV+-- computation. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfCts :: Cts -> FV+tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV++-- | Returns free variables of a bag of constraints as a composable FV+-- computation. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoFVsOfCtEvs :: [CtEvidence] -> FV+tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV++-- | Returns free variables of WantedConstraints as a non-deterministic+-- set. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet+-- Only called on *zonked* things+tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC++-- | Returns free variables of WantedConstraints as a deterministically+-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]+-- Only called on *zonked* things+tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC++-- | Returns free variables of WantedConstraints as a composable FV+-- computation. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfWC :: WantedConstraints -> FV+-- Only called on *zonked* things+tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_errors = errors })+  = tyCoFVsOfCts simple `unionFV`+    tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`+    tyCoFVsOfBag tyCoFVsOfDelayedError errors++-- | Returns free variables of Implication as a composable FV computation.+-- See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfImplic :: Implication -> FV+-- Only called on *zonked* things+tyCoFVsOfImplic (Implic { ic_skols = skols+                        , ic_given = givens+                        , ic_wanted = wanted })+  | isEmptyWC wanted+  = emptyFV+  | otherwise+  = tyCoFVsVarBndrs skols  $+    tyCoFVsVarBndrs givens $+    tyCoFVsOfWC wanted++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++tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV+tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV++{-+************************************************************************+*                                                                      *+                    CtEvidence+         The "flavor" of a canonical constraint+*                                                                      *+************************************************************************+-}++isWantedCt :: Ct -> Bool+isWantedCt = isWanted . ctEvidence++isGivenCt :: Ct -> Bool+isGivenCt = isGiven . ctEvidence++isPendingScDict :: Ct -> Bool+isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct+isPendingScDict _                  = False++isPendingScDictCt :: DictCt -> Bool+-- Says whether this is a CDictCan with di_pend_sc has positive fuel;+-- i.e. pending un-expanded superclasses+isPendingScDictCt (DictCt { di_pend_sc = f }) = pendingFuel f++pendingScDict_maybe :: Ct -> Maybe Ct+-- Says whether this is a CDictCan with di_pend_sc has fuel left,+-- AND if so exhausts the fuel so that they are not expanded again+pendingScDict_maybe (CDictCan dict@(DictCt { di_pend_sc = f }))+  | pendingFuel f = Just (CDictCan (dict { di_pend_sc = doNotExpand }))+  | otherwise     = Nothing+pendingScDict_maybe _ = Nothing++pendingScInst_maybe :: QCInst -> Maybe QCInst+-- Same as isPendingScDict, but for QCInsts+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+-- ^ True if taking superclasses of givens, or of wanteds (to perhaps+-- expose more equalities or functional dependencies) might help to+-- solve this constraint.  See Note [When superclasses help]+superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })+  = anyBag might_help_ct simples || anyBag might_help_implic implics+  where+    might_help_implic ic+       | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic)+       | otherwise                   = False++    might_help_ct ct = not (is_ip ct)++    is_ip (CDictCan (DictCt { di_cls = cls })) = isIPClass cls+    is_ip _                                    = False++getPendingWantedScs :: Cts -> ([Ct], Cts)+-- in the return values [Ct] has original fuel while Cts has fuel exhausted+getPendingWantedScs simples+  = mapAccumBagL get [] simples+  where+    get acc ct | Just ct_exhausted <- pendingScDict_maybe ct+               = (ct:acc, ct_exhausted)+               | otherwise+               = (acc,     ct)++{- Note [When superclasses help]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+First read Note [The superclass story] in GHC.Tc.Solver.Dict++We expand superclasses and iterate only if there is at unsolved wanted+for which expansion of superclasses (e.g. from given constraints)+might actually help. The function superClassesMightHelp tells if+doing this superclass expansion might help solve this constraint.+Note that++  * We look inside implications; maybe it'll help to expand the Givens+    at level 2 to help solve an unsolved Wanted buried inside an+    implication.  E.g.+        forall a. Ord a => forall b. [W] Eq a++  * We say "no" for implicit parameters.+    we have [W] ?x::ty, expanding superclasses won't help:+      - Superclasses can't be implicit parameters+      - If we have a [G] ?x:ty2, then we'll have another unsolved+        [W] ty ~ ty2 (from the functional dependency)+        which will trigger superclass expansion.++    It's a bit of a special case, but it's easy to do.  The runtime cost+    is low because the unsolved set is usually empty anyway (errors+    aside), and the first non-implicit-parameter will terminate the search.++    The special case is worth it (#11480, comment:2) because it+    applies to CallStack constraints, which aren't type errors. If we have+       f :: (C a) => blah+       f x = ...undefined...+    we'll get a CallStack constraint.  If that's the only unsolved+    constraint it'll eventually be solved by defaulting.  So we don't+    want to emit warnings about hitting the simplifier's iteration+    limit.  A CallStack constraint really isn't an unsolved+    constraint; it can always be solved by defaulting.+-}++singleCt :: Ct -> Cts+singleCt = unitBag++andCts :: Cts -> Cts -> Cts+andCts = unionBags++listToCts :: [Ct] -> Cts+listToCts = listToBag++ctsElts :: Cts -> [Ct]+ctsElts = bagToList++consCts :: Ct -> Cts -> Cts+consCts = consBag++snocCts :: Cts -> Ct -> Cts+snocCts = snocBag++extendCtsList :: Cts -> [Ct] -> Cts+extendCtsList cts xs | null xs   = cts+                     | otherwise = cts `unionBags` listToBag xs++emptyCts :: Cts+emptyCts = emptyBag++isEmptyCts :: Cts -> Bool+isEmptyCts = isEmptyBag++ctsPreds :: Cts -> [PredType]+ctsPreds cts = foldr ((:) . ctPred) [] cts++{-+************************************************************************+*                                                                      *+                Wanted constraints+*                                                                      *+************************************************************************+-}++data WantedConstraints+  = WC { wc_simple :: Cts              -- Unsolved constraints, all wanted+       , wc_impl   :: Bag Implication+       , wc_errors :: Bag DelayedError+    }++emptyWC :: WantedConstraints+emptyWC = WC { wc_simple = emptyBag+             , wc_impl   = emptyBag+             , wc_errors = emptyBag }++mkSimpleWC :: [CtEvidence] -> WantedConstraints+mkSimpleWC cts+  = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) }++mkImplicWC :: Bag Implication -> WantedConstraints+mkImplicWC implic+  = emptyWC { wc_impl = implic }++isEmptyWC :: WantedConstraints -> Bool+isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors })+  = isEmptyBag f && isEmptyBag i && isEmptyBag errors++-- | Checks whether a the given wanted constraints are solved, i.e.+-- that there are no simple constraints left and all the implications+-- are solved.+isSolvedWC :: WantedConstraints -> Bool+isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_errors = errors} =+  isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag errors++andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints+andWC (WC { wc_simple = f1, wc_impl = i1, wc_errors = e1 })+      (WC { wc_simple = f2, wc_impl = i2, wc_errors = e2 })+  = WC { wc_simple = f1 `unionBags` f2+       , wc_impl   = i1 `unionBags` i2+       , wc_errors = e1 `unionBags` e2 }++unionsWC :: [WantedConstraints] -> WantedConstraints+unionsWC = foldr andWC emptyWC++addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints+addSimples wc cts+  = wc { wc_simple = wc_simple wc `unionBags` cts }+    -- Consider: Put the new constraints at the front, so they get solved first++addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints+addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }++addInsols :: WantedConstraints -> Bag IrredCt -> WantedConstraints+addInsols wc insols+  = wc { wc_simple = wc_simple wc `unionBags` fmap CIrredCan insols }++addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints+addHoles wc holes+  = wc { wc_errors = mapBag DE_Hole holes `unionBags` wc_errors wc }++addNotConcreteError :: WantedConstraints -> NotConcreteError -> WantedConstraints+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 }++dropMisleading :: WantedConstraints -> WantedConstraints+-- Drop misleading constraints; really just class constraints+-- See Note [Constraints and errors] in GHC.Tc.Utils.Monad+--   for why this function is so strange, treating the 'simples'+--   and the implications differently.  Sigh.+dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors })+  = WC { wc_simple = filterBag insolubleWantedCt simples+       , wc_impl   = mapBag drop_implic implics+       , wc_errors = filterBag keep_delayed_error errors }+  where+    drop_implic implic+      = implic { ic_wanted = drop_wanted (ic_wanted implic) }+    drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors })+      = WC { wc_simple = filterBag keep_ct simples+           , wc_impl   = mapBag drop_implic implics+           , wc_errors  = filterBag keep_delayed_error errors }++    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+isSolvedStatus _              = False++isInsolubleStatus :: ImplicStatus -> Bool+isInsolubleStatus IC_Insoluble    = True+isInsolubleStatus IC_BadTelescope = True+isInsolubleStatus _               = False++insolubleImplic :: Implication -> Bool+insolubleImplic ic = isInsolubleStatus (ic_status ic)++-- | Gather all the type variables from 'WantedConstraints'+-- that it would be unhelpful to default. For the moment,+-- these are only 'ConcreteTv' metavariables participating+-- in a nominal equality whose other side is not concrete;+-- it's usually better to report those as errors instead of+-- defaulting.+nonDefaultableTyVarsOfWC :: WantedConstraints -> TyCoVarSet+-- Currently used in simplifyTop and in tcRule.+-- TODO: should we also use this in decideQuantifiedTyVars, kindGeneralize{All,Some}?+nonDefaultableTyVarsOfWC (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })+  =             concatMapBag non_defaultable_tvs_of_ct simples+  `unionVarSet` concatMapBag (nonDefaultableTyVarsOfWC . ic_wanted) implics+  `unionVarSet` concatMapBag non_defaultable_tvs_of_err errs+    where++      concatMapBag :: (a -> TyVarSet) -> Bag a -> TyCoVarSet+      concatMapBag f = foldr (\ r acc -> f r `unionVarSet` acc) emptyVarSet++      -- Don't default ConcreteTv metavariables involved+      -- in an equality with something non-concrete: it's usually+      -- better to report the unsolved Wanted.+      --+      -- Example: alpha[conc] ~# rr[sk].+      non_defaultable_tvs_of_ct :: Ct -> TyCoVarSet+      non_defaultable_tvs_of_ct ct =+        -- NB: using classifyPredType instead of inspecting the Ct+        -- so that we deal uniformly with CNonCanonical (which come up in tcRule),+        -- CEqCan (unsolved but potentially soluble, e.g. @alpha[conc] ~# RR@)+        -- and CIrredCan.+        case classifyPredType $ ctPred ct of+          EqPred NomEq lhs rhs+            | Just tv <- getTyVar_maybe lhs+            , isConcreteTyVar tv+            , not (isConcreteType rhs)+            -> unitVarSet tv+            | Just tv <- getTyVar_maybe rhs+            , isConcreteTyVar tv+            , not (isConcreteType lhs)+            -> unitVarSet tv+          _ -> emptyVarSet++      -- Make sure to apply the same logic as above to delayed errors.+      non_defaultable_tvs_of_err (DE_NotConcrete err)+        = 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 })+  =  anyBag insolubleWantedCt simples+       -- insolubleWantedCt: wanteds only: see Note [Given insolubles]+  || anyBag insolubleImplic implics+  || anyBag is_insoluble errors+  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+-- Namely:+--   a) an insoluble constraint as per 'insolubleIrredCt', i.e. either+--        - an insoluble equality constraint (e.g. Int ~ Bool), or+--        - a custom type error constraint, TypeError msg :: Constraint+--   b) that does not arise from a Given or a Wanted/Wanted fundep interaction+-- See Note [Insoluble Wanteds]+insolubleWantedCt ct+  | CIrredCan ir_ct <- ct+      -- CIrredCan: see (IW1) in Note [Insoluble Wanteds]+  , IrredCt { ir_ev = ev } <- ir_ct+  , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters })  <- ev+      -- It's a Wanted+  , insolubleIrredCt ir_ct+      -- It's insoluble+  , isEmptyRewriterSet rewriters+      -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds]+  , not (isGivenLoc loc)+      -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds]+  , not (isWantedWantedFunDepOrigin (ctLocOrigin loc))+      -- origin check: see (IW4) in Note [Insoluble Wanteds]+  = True++  | otherwise+  = False++-- | Returns True of constraints that are definitely insoluble,+--   as well as TypeError constraints.+-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.+--+-- The function is tuned for application /after/ constraint solving+--       i.e. assuming canonicalisation has been done+-- That's why it looks only for IrredCt; all insoluble constraints+-- are put into CIrredCan+insolubleCt :: Ct -> Bool+insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct+insolubleCt _                 = False++insolubleIrredCt :: IrredCt -> Bool+-- Returns True of Irred constraints that are /definitely/ insoluble+--+-- This function is critical for accurate pattern-match overlap warnings.+-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver+--+-- Note that this does not traverse through the constraint to find+-- nested custom type errors: it only detects @TypeError msg :: Constraint@,+-- and not e.g. @Eq (TypeError msg)@.+insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason })+  =  isInsolubleReason reason+  || isTopLevelUserTypeError (ctEvPred ev)+  -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg"+  -- and "Unsatisfiable msg". It deliberately does not detect TypeError+  -- nested in a type (e.g. it does not use "containsUserTypeError"), as that+  -- would be too eager: the TypeError might appear inside a type family+  -- application which might later reduce, but we only want to return 'True'+  -- for constraints that are definitely insoluble.+  --+  -- For example: Num (F Int (TypeError "msg")), where F is a type family.+  --+  -- Test case: T11503, with the 'Assert' type family:+  --+  -- > type Assert :: Bool -> Constraint -> Constraint+  -- > type family Assert check errMsg where+  -- >   Assert 'True  _errMsg = ()+  -- >   Assert _check errMsg  = errMsg++-- | Does this hole represent an "out of scope" error?+-- See Note [Insoluble holes]+isOutOfScopeHole :: Hole -> Bool+isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ))++instance Outputable WantedConstraints where+  ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e})+   = text "WC" <+> braces (vcat+        [ ppr_bag (text "wc_simple") s+        , ppr_bag (text "wc_impl") i+        , ppr_bag (text "wc_errors") e ])++ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc+ppr_bag doc bag+ | isEmptyBag bag = empty+ | otherwise      = hang (doc <+> equals)+                       2 (foldr (($$) . ppr) empty bag)++{- Note [Given insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14325, comment:)+    class (a~b) => C a b++    foo :: C a c => a -> c+    foo x = x++    hm3 :: C (f b) b => b -> f b+    hm3 x = foo x++In the RHS of hm3, from the [G] C (f b) b we get the insoluble+[G] f b ~# b.  Then we also get an unsolved [W] C b (f b).+Residual implication looks like+    forall b. C (f b) b => [G] f b ~# b+                           [W] C f (f b)++We do /not/ want to set the implication status to IC_Insoluble,+because that'll suppress reports of [W] C b (f b).  But we+may not report the insoluble [G] f b ~# b either (see Note [Given errors]+in GHC.Tc.Errors), so we may fail to report anything at all!  Yikes.++Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus)+             should ignore givens even if they are insoluble.++Note [Insoluble Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~+insolubleWantedCt returns True of a Wanted constraint that definitely+can't be solved.  But not quite all such constraints; see wrinkles.++(IW1) insolubleWantedCt is tuned for application /after/ constraint+   solving i.e. assuming canonicalisation has been done.  That's why+   it looks only for IrredCt; all insoluble constraints are put into+   CIrredCan++(IW2) We only treat it as insoluble if it has an empty rewriter set.  (See Note+   [Wanteds rewrite Wanteds].)  Otherwise #25325 happens: a Wanted constraint A+   that is /not/ insoluble rewrites some other Wanted constraint B, so B has A+   in its rewriter set.  Now B looks insoluble.  The danger is that we'll+   suppress reporting B because of its empty rewriter set; and suppress+   reporting A because there is an insoluble B lying around.  (This suppression+   happens in GHC.Tc.Errors.mkErrorItem.)  Solution: don't treat B as insoluble.++(IW3) If the Wanted arises from a Given (how can that happen?), don't+   treat it as a Wanted insoluble (obviously).++(IW4) If the Wanted came from a  Wanted/Wanted fundep interaction, don't+   treat the constraint as insoluble. See Note [Suppressing confusing errors]+   in GHC.Tc.Errors++Note [Insoluble holes]+~~~~~~~~~~~~~~~~~~~~~~+Hole constraints that ARE NOT treated as truly insoluble:+  a) type holes, arising from PartialTypeSignatures,+  b) "true" expression holes arising from TypedHoles++An "expression hole" or "type hole" isn't really an error+at all; it's a report saying "_ :: Int" here.  But an out-of-scope+variable masquerading as expression holes IS treated as truly+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+*                                                                      *+************************************************************************+-}++data Implication+  = Implic {   -- Invariants for a tree of implications:+               -- see TcType Note [TcLevel invariants]++      ic_tclvl :: TcLevel,       -- TcLevel of unification variables+                                 -- allocated /inside/ this implication++      ic_info  :: SkolemInfoAnon,    -- See Note [Skolems in an implication]+                                     -- See Note [Shadowing in a constraint]++      ic_skols :: [TcTyVar],     -- Introduced skolems; always skolem TcTyVars+                                 -- Their level numbers should be precisely ic_tclvl+                                 -- Their SkolemInfo should be precisely ic_info (almost)+                                 --       See Note [Implication invariants]++      ic_given  :: [EvVar],      -- Given evidence variables+                                 --   (order does not matter)+                                 -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType++      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?++      ic_warn_inaccessible :: Bool,+                                 -- True <=> we should report inaccessible code+                                 -- Note [Avoid -Winaccessible-code when deriving]+                                 -- in GHC.Tc.TyCl.Instance++      ic_env   :: !CtLocEnv,+                                 -- Records the context at the time of creation.+                                 --+                                 -- This provides all the information needed about+                                 -- the context to report the source of errors linked+                                 -- to this implication.++      ic_wanted :: WantedConstraints,  -- The wanteds+                                       -- See Invariant (WantedInf) in GHC.Tc.Utils.TcType++      ic_binds  :: EvBindsVar,    -- Points to the place to fill in the+                                  -- abstraction and bindings.++      -- The ic_need fields keep track of which Given evidence+      -- is used by this implication or its children+      -- 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+              ic_tclvl      = panic "newImplic:tclvl"+            , ic_binds      = panic "newImplic:binds"+            , ic_info       = panic "newImplic:info"+            , ic_warn_inaccessible = panic "newImplic:warn_inaccessible"++              -- 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        = emptyEvNeedSet+            , ic_need_implic = emptyEvNeedSet }++data ImplicStatus+  = IC_Solved     -- All wanteds in the tree are solved, all the way down+       { ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed+         -- See Note [Tracking redundant constraints] in GHC.Tc.Solver++  | IC_Insoluble  -- At least one insoluble Wanted constraint in the tree++  | IC_BadTelescope  -- Solved, but the skolems in the telescope are out of+                     -- dependency order. See Note [Checking telescopes]++  | IC_Unsolved   -- Neither of the above; might go either way++data HasGivenEqs -- See Note [HasGivenEqs]+  = NoGivenEqs      -- Definitely no given equalities,+                    --   except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet+  | LocalGivenEqs   -- Might have Given equalities, but only ones that affect only+                    --   local skolems e.g. forall a b. (a ~ F b) => ...+  | MaybeGivenEqs   -- Might have any kind of Given equalities; no floating out+                    --   is possible.+  deriving Eq++type UserGiven = Implication++getUserGivensFromImplics :: [Implication] -> [UserGiven]+getUserGivensFromImplics implics+  = reverse (filterOut (null . ic_given) implics)++{- Note [HasGivenEqs]+~~~~~~~~~~~~~~~~~~~~~+The GivenEqs data type describes the Given constraints of an implication constraint:++* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems+  which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet+  Examples: forall a. Eq a => ...+            forall a. (Show a, Num a) => ...+            forall a. a ~ Either Int Bool => ...  -- Let-bound skolem++* LocalGivenEqs: definitely no Given equalities that would affect principal+  types.  But may have equalities that affect only skolems of this implication+  (and hence do not affect principal types)+  Examples: forall a. F a ~ Int => ...+            forall a b. F a ~ G b => ...++* MaybeGivenEqs: may have Given equalities that would affect principal+  types+  Examples: forall. (a ~ b) => ...+            forall a. F a ~ b => ...+            forall a. c a => ...       -- The 'c' might be instantiated to (b ~)+            forall a. C a b => ....+               where class x~y => C a b+               so there is an equality in the superclass of a Given++The HasGivenEqs classifications affect two things:++* Suppressing redundant givens during error reporting; see GHC.Tc.Errors+  Note [Suppress redundant givens during error reporting]++* Floating in approximateWC.++Specifically, here's how it goes:++                 Stops floating    |   Suppresses Givens in errors+                 in approximateWC  |+                 -----------------------------------------------+ NoGivenEqs         NO             |         YES+ LocalGivenEqs      NO             |         NO+ MaybeGivenEqs      YES            |         NO+-}++instance Outputable Implication where+  ppr (Implic { ic_tclvl = tclvl, ic_skols = skols+              , ic_given = given, ic_given_eqs = given_eqs+              , ic_wanted = wanted, ic_status = status+              , ic_binds = binds+              , ic_need = need, ic_need_implic = need_implic+              , ic_info = info })+   = hang (text "Implic" <+> lbrace)+        2 (sep [ text "TcLevel =" <+> ppr tclvl+               , text "Skolems =" <+> pprTyVars skols+               , text "Given-eqs =" <+> ppr given_eqs+               , text "Status =" <+> ppr status+               , hang (text "Given =")  2 (pprEvVars given)+               , hang (text "Wanted =") 2 (ppr wanted)+               , text "Binds =" <+> ppr binds+               , 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"+  ppr IC_Unsolved     = text "Unsolved"+  ppr (IC_Solved { ics_dead = dead })+    = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead))++checkTelescopeSkol :: SkolemInfoAnon -> Bool+-- See Note [Checking telescopes]+checkTelescopeSkol (ForAllSkol {}) = True+checkTelescopeSkol _               = False++instance Outputable HasGivenEqs where+  ppr NoGivenEqs    = text "NoGivenEqs"+  ppr LocalGivenEqs = text "LocalGivenEqs"+  ppr MaybeGivenEqs = text "MaybeGivenEqs"++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Semigroup HasGivenEqs where+  NoGivenEqs <> other = other+  other <> NoGivenEqs = other++  MaybeGivenEqs <> _other = MaybeGivenEqs+  _other <> MaybeGivenEqs = MaybeGivenEqs++  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Monoid HasGivenEqs where+  mempty = NoGivenEqs++{- Note [Checking telescopes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When kind-checking a /user-written/ type, we might have a "bad telescope"+like this one:+  data SameKind :: forall k. k -> k -> Type+  type Foo :: forall a k (b :: k). SameKind a b -> Type++The kind of 'a' mentions 'k' which is bound after 'a'.  Oops.++One approach to doing this would be to bring each of a, k, and b into+scope, one at a time, creating a separate implication constraint for+each one, and bumping the TcLevel. This would work, because the kind+of, say, a would be untouchable when k is in scope (and the constraint+couldn't float out because k blocks it). However, it leads to terrible+error messages, complaining about skolem escape. While it is indeed a+problem of skolem escape, we can do better.++Instead, our approach is to bring the block of variables into scope+all at once, creating one implication constraint for the lot:++* We make a single implication constraint when kind-checking+  the 'forall' in Foo's kind, something like+      forall a k (b::k). { wanted constraints }++* Having solved {wanted}, before discarding the now-solved implication,+  the constraint solver checks the dependency order of the skolem+  variables (ic_skols).  This is done in setImplicationStatus.++* This check is only necessary if the implication was born from a+  'forall' in a user-written signature (the HsForAllTy case in+  GHC.Tc.Gen.HsType.  If, say, it comes from checking a pattern match+  that binds existentials, where the type of the data constructor is+  known to be valid (it in tcConPat), no need for the check.++  So the check is done /if and only if/ ic_info is ForAllSkol.++* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the+  original, user-written type variables.++* Be careful /NOT/ to discard an implication with a ForAllSkol+  ic_info, even if ic_wanted is empty.  We must give the+  constraint solver a chance to make that bad-telescope test!  Hence+  the extra guard in emitResidualTvConstraint; see #16247++* Don't mix up inferred and explicit variables in the same implication+  constraint.  E.g.+      foo :: forall a kx (b :: kx). SameKind a b+  We want an implication+      Implic { ic_skol = [(a::kx), kx, (b::kx)], ... }+  but GHC will attempt to quantify over kx, since it is free in (a::kx),+  and it's hopelessly confusing to report an error about quantified+  variables   kx (a::kx) kx (b::kx).+  Instead, the outer quantification over kx should be in a separate+  implication. TL;DR: an explicit forall should generate an implication+  quantified only over those explicitly quantified variables.++Note [Shadowing in a constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We assume NO SHADOWING in a constraint.  Specifically+ * The unification variables are all implicitly quantified at top+   level, and are all unique+ * The skolem variables bound in ic_skols are all fresh when the+   implication is created.+So we can safely substitute. For example, if we have+   forall a.  a~Int => ...(forall b. ...a...)...+we can push the (a~Int) constraint inwards in the "givens" without+worrying that 'b' might clash.++Note [Skolems in an implication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The skolems in an implication are used:++* When considering floating a constraint outside the implication in+  GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications+  For this, we can treat ic_skols as a set.++* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs)+  has its variables in the correct order; see Note [Checking telescopes].+  Only for these implications does ic_skols need to be a list.++Nota bene: Although ic_skols is a list, it is not necessarily+in dependency order:+- In the ic_info=ForAllSkol case, the user might have written them+  in the wrong order+- In the case of a type signature like+      f :: [a] -> [b]+  the renamer gathers the implicit "outer" forall'd variables {a,b}, but+  does not know what order to put them in.  The type checker can sort them+  into dependency order, but only after solving all the kind constraints;+  and to do that it's convenient to create the Implication!++So we accept that ic_skols may be out of order.  Think of it as a set or+(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly+wrong, order.++Note [Insoluble constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the errors that we get during canonicalization are best+reported when all constraints have been simplified as much as+possible. For instance, assume that during simplification the+following constraints arise:++ [Wanted]   F alpha ~  uf1+ [Wanted]   beta ~ uf1 beta++When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail+we will simply see a message:+    'Can't construct the infinite type  beta ~ uf1 beta'+and the user has no idea what the uf1 variable is.++Instead our plan is that we will NOT fail immediately, but:+    (1) Record the "frozen" error in the ic_insols field+    (2) Isolate the offending constraint from the rest of the inerts+    (3) Keep on simplifying/canonicalizing++At the end, we will hopefully have substituted uf1 := F alpha, and we+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)+*                                                                      *+************************************************************************++Note [Implication invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The skolems of an implication have the following invariants, which are checked+by checkImplicationInvariants:++a) They are all SkolemTv TcTyVars; no TyVars, no unification variables+b) Their TcLevel matches the ic_lvl for the implication+c) Their SkolemInfo matches the implication.++Actually (c) is not quite true.  Consider+   data T a = forall b. MkT a b++In tcConDecl for MkT we'll create an implication with ic_info of+DataConSkol; but the type variable 'a' will have a SkolemInfo of+TyConSkol.  So we allow the tyvar to have a SkolemInfo of TyConFlav if+the implication SkolemInfo is DataConSkol.+-}++checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m ()+{-# INLINE checkImplicationInvariants #-}+-- Nothing => OK, Just doc => doc gives info+checkImplicationInvariants implic = when debugIsOn (check_implic implic)++check_implic implic@(Implic { ic_tclvl = lvl+                            , ic_info = skol_info+                            , ic_skols = skols })+  | null bads = pure ()+  | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure"+                                       , nest 2 (vcat bads)+                                       , ppr implic ])+  where+    bads = mapMaybe check skols++    check :: TcTyVar -> Maybe SDoc+    check tv | not (isTcTyVar tv)+             = Just (ppr tv <+> text "is not a TcTyVar")+             | otherwise+             = check_details tv (tcTyVarDetails tv)++    check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc+    check_details tv (SkolemTv tv_skol_info tv_lvl _)+      | not (tv_lvl `sameDepthAs` lvl)+      = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl+                   , text "ic_lvl" <+> ppr lvl ])+      | not (skol_info `checkSkolInfoAnon` skol_info_anon)+      = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon+                   , text "ic_info" <+> ppr skol_info ])+      | otherwise+      = Nothing+      where+        skol_info_anon = getSkolemInfo tv_skol_info+    check_details tv details+      = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details)++checkSkolInfoAnon :: SkolemInfoAnon   -- From the implication+                  -> SkolemInfoAnon   -- From the type variable+                  -> Bool             -- True <=> ok+-- Used only for debug-checking; checkImplicationInvariants+-- So it doesn't matter much if its's incomplete+checkSkolInfoAnon sk1 sk2 = go sk1 sk2+  where+    go (SigSkol c1 t1 s1)   (SigSkol c2 t2 s2)   = c1==c2 && t1 `tcEqType` t2 && s1==s2+    go (SigTypeSkol cx1)    (SigTypeSkol cx2)    = cx1==cx2++    go (ForAllSkol _)       (ForAllSkol _)       = True++    go (IPSkol ips1)        (IPSkol ips2)        = ips1 == ips2+    go (DerivSkol pred1)    (DerivSkol pred2)    = pred1 `tcEqType` pred2+    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 &&+                                                   and (zipWith eq_pr ids1 ids2)+    go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2+    go ReifySkol            ReifySkol            = True+    go RuntimeUnkSkol       RuntimeUnkSkol       = True+    go ArrowReboundIfSkol   ArrowReboundIfSkol   = True+    go (UnkSkol _)          (UnkSkol _)          = True++    -------- Three slightly strange special cases --------+    go (DataConSkol _)      (TyConSkol f _)      = h98_data_decl f+    -- In the H98 declaration  data T a = forall b. MkT a b+    -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of+    -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol++    go (DataConSkol _)      FamInstSkol          = True+    -- In  data/newtype instance T a = MkT (a -> a),+    -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of+    -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol++    go FamInstSkol          (InstSkol {})         = True+    -- In instance C (T a) where { type F (T a) b = ... }+    -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi+    -- SkolemInfo of FamInstSkol.  Very like the ConDecl/TyConSkol case++    go (ForAllSkol _)       _                    = True+    -- Telescope tests: we need a ForAllSkol to force the telescope+    -- test, but the skolems might come from (say) a family instance decl+    --    type instance forall a. F [a] = a->a++    go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f+    -- e.g.   newtype T a = MkT ... deriving blah+    -- We use the skolems from T (TyConSkol) when typechecking+    -- the deriving clauses (SigTypeSkol DerivClauseCtxt)++    go _ _ = False++    eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool+    eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked++    h98_data_decl DataTypeFlavour = True+    h98_data_decl NewtypeFlavour  = True+    h98_data_decl _               = False+++{- *********************************************************************+*                                                                      *+            Pretty printing+*                                                                      *+********************************************************************* -}++pprEvVars :: [EvVar] -> SDoc    -- Print with their types+pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)++pprEvVarTheta :: [EvVar] -> SDoc+pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)++pprEvVarWithType :: EvVar -> SDoc+pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)++++wrapType :: Type -> [TyVar] -> [PredType] -> Type+wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty+++{-+************************************************************************+*                                                                      *+            CtEvidence+*                                                                      *+************************************************************************++Note [CtEvidence invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `ctev_pred` field of a `CtEvidence` is a just a cache for the type+of the evidence. More precisely:++* For Givens, `ctev_pred` = `varType ctev_evar`+* For Wanteds, `ctev_pred` = `evDestType ctev_dest`++where++  evDestType :: TcEvDest -> TcType+  evDestType (EvVarDest evVar)       = varType evVar+  evDestType (HoleDest coercionHole) = varType (coHoleCoVar coercionHole)++The invariant is maintained by `setCtEvPredType`, the only function that+updates the `ctev_pred` field of a `CtEvidence`.++Why is the invariant important? Because when the evidence is a coercion, it may+be used in (CastTy ty co); and then we may call `typeKind` on that type (e.g.+in the kind-check of `eqType`); and expect to see a fully zonked kind.+(This came up in test T13333, in the MR that fixed #20641, namely !6942.)++Historical Note [Evidence field of CtEvidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the past we tried leaving the `ctev_evar`/`ctev_dest` field of a+constraint untouched (and hence un-zonked) on the grounds that it is+never looked at.  But in fact it is: the evidence can become part of a+type (via `CastTy ty kco`) and we may later ask the kind of that type+and expect a zonked result.  (For example, in the kind-check+of `eqType`.)++The safest thing is simply to keep `ctev_evar`/`ctev_dest` in sync+with `ctev_pred`, as stated in `Note [CtEvidence invariants]`.++Note [Bind new Givens immediately]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For Givens we make new EvVars and bind them immediately. Two main reasons:+  * Gain sharing.  E.g. suppose we start with g :: C a b, where+       class D a => C a b+       class (E a, F a) => D a+    If we generate all g's superclasses as separate EvTerms we might+    get    selD1 (selC1 g) :: E a+           selD2 (selC1 g) :: F a+           selC1 g :: D a+    which we could do more economically as:+           g1 :: D a = selC1 g+           g2 :: E a = selD1 g1+           g3 :: F a = selD2 g1++  * For *coercion* evidence we *must* bind each given:+      class (a~b) => C a b where ....+      f :: C a b => ....+    Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.+    But that superclass selector can't (yet) appear in a coercion+    (see evTermCoercion), so the easy thing is to bind it to an Id.++So a Given has EvVar inside it rather than (as previously) an EvTerm.++Note [The rewrite-role of a constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rewrite-role of a constraint says what can rewrite that constraint:++* If the rewrite-role = Nominal, only a nominal equality can rewrite it++* If the rewrite-rule = Representational, either a nominal or+  representational equality can rewrit it.++Notice that the constraint may itself not be an equality at all.+For example, the rewrite-role of (Eq [a]) is Nominal; only nominal+equalities can rewrite it.+-}++-- | A place for type-checking evidence to go after it is generated.+--+--  - Wanted equalities use HoleDest,+--  - other Wanteds use EvVarDest.+data TcEvDest+  = EvVarDest EvVar         -- ^ bind this var to the evidence+              -- EvVarDest is always used for non-type-equalities+              -- e.g. class constraints++  | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence+              -- HoleDest is always used for type-equalities+              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep++data CtEvidence+  = 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 }++-- | 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 (CtGiven (GivenCt { ctev_pred = pred }))  = pred+ctEvPred (CtWanted (WantedCt { ctev_pred = pred })) = pred++ctEvLoc :: CtEvidence -> CtLoc+ctEvLoc (CtGiven (GivenCt { ctev_loc = loc }))  = loc+ctEvLoc (CtWanted (WantedCt { ctev_loc = loc })) = loc++ctEvOrigin :: CtEvidence -> CtOrigin+ctEvOrigin = ctLocOrigin . ctEvLoc++-- | Get the equality relation relevant for a 'CtEvidence'+ctEvEqRel :: HasDebugCallStack => CtEvidence -> EqRel+ctEvEqRel = predTypeEqRel . ctEvPred++-- | Get the rewrite-role relevant for a 'CtEvidence'+-- See Note [The rewrite-role of a constraint]+ctEvRewriteRole :: HasDebugCallStack => CtEvidence -> Role+ctEvRewriteRole = eqRelRole . ctEvRewriteEqRel++ctEvRewriteEqRel :: CtEvidence -> EqRel+-- ^ Return the rewrite-role of an abitrary CtEvidence+-- See Note [The rewrite-role of a constraint]+-- We return ReprEq for (a ~R# b) and NomEq for all other preds+ctEvRewriteEqRel = predTypeEqRel . ctEvPred++ctEvTerm :: CtEvidence -> EvTerm+ctEvTerm ev = EvExpr (ctEvExpr ev)++-- | Extract the set of rewriters from a 'CtEvidence'+-- See Note [Wanteds rewrite Wanteds]+-- If the provided CtEvidence is not for a Wanted, just+-- return an empty set.+ctEvRewriters :: CtEvidence -> RewriterSet+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 (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 _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+    mkHoleCo hole+ctEvCoercion ev+  = pprPanic "ctEvCoercion" (ppr ev)++ctEvEvId :: CtEvidence -> EvVar+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 (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 (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.+--+-- This function ensures that the invariants on 'CtEvidence' hold, by updating+-- the evidence and the ctev_pred in sync with each other.+-- See Note [CtEvidence invariants].+setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence+setCtEvPredType (CtGiven old_ev@(GivenCt { ctev_evar = ev })) new_pred+  = CtGiven (old_ev { ctev_pred = new_pred+                    , ctev_evar = setVarType ev new_pred })++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)+      HoleDest h   -> HoleDest  (setCoHoleType h new_pred)++instance Outputable TcEvDest where+  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)+           <+> hang (pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters))+                         -- Show the sub-goal depth too+                  2 (dcolon <+> pprPredType (ctEvPred ev))+    where+      pp_ev = case ev of+             CtGiven ev -> ppr (ctev_evar ev)+             CtWanted ev -> ppr (ctev_dest ev)++      rewriters = ctEvRewriters ev+      pp_rewriters | isEmptyRewriterSet rewriters = empty+                   | otherwise                    = semi <> ppr rewriters++isWanted :: CtEvidence -> Bool+isWanted (CtWanted {}) = True+isWanted _ = False++isGiven :: CtEvidence -> Bool+isGiven (CtGiven {})  = True+isGiven _ = False++{-+************************************************************************+*                                                                      *+           RewriterSet+*                                                                      *+************************************************************************+-}++-- | Stores a set of CoercionHoles that have been used to rewrite a constraint.+-- See Note [Wanteds rewrite Wanteds].+newtype RewriterSet = RewriterSet (UniqSet CoercionHole)+  deriving newtype (Outputable, Semigroup, Monoid)++emptyRewriterSet :: RewriterSet+emptyRewriterSet = RewriterSet emptyUniqSet++unitRewriterSet :: CoercionHole -> RewriterSet+unitRewriterSet = coerce (unitUniqSet @CoercionHole)++unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet+unionRewriterSet = coerce (unionUniqSets @CoercionHole)++isEmptyRewriterSet :: RewriterSet -> Bool+isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole)++addRewriter :: RewriterSet -> CoercionHole -> RewriterSet+addRewriter = coerce (addOneToUniqSet @CoercionHole)++rewriterSetFromCts :: Bag Ct -> RewriterSet+-- Take a bag of Wanted equalities, and collect them as a RewriterSet+rewriterSetFromCts cts+  = foldr add emptyRewriterSet cts+  where+    add ct rw_set =+      case ctEvidence ct of+        CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole+        _                                                 -> rw_set++{-+************************************************************************+*                                                                      *+           CtFlavour+*                                                                      *+************************************************************************+-}++data CtFlavour+  = Given     -- we have evidence+  | Wanted    -- we want evidence+  deriving Eq++instance Outputable CtFlavour where+  ppr Given  = text "[G]"+  ppr Wanted = text "[W]"++ctEvFlavour :: CtEvidence -> CtFlavour+ctEvFlavour (CtWanted {}) = Wanted+ctEvFlavour (CtGiven {})  = Given++-- | Whether or not one 'Ct' can rewrite another is determined by its+-- flavour and its equality relation. See also+-- Note [Flavours with roles] in GHC.Tc.Solver.InertSet+type CtFlavourRole = (CtFlavour, EqRel)++-- | Extract the flavour, role, and boxity from a 'CtEvidence'+ctEvFlavourRole :: HasDebugCallStack => CtEvidence -> CtFlavourRole+ctEvFlavourRole ev = (ctEvFlavour ev, ctEvRewriteEqRel ev)++-- | Extract the flavour and role from a 'Ct'+eqCtFlavourRole :: EqCt -> CtFlavourRole+eqCtFlavourRole (EqCt { eq_ev = ev, eq_eq_rel = eq_rel })+  = (ctEvFlavour ev, eq_rel)++dictCtFlavourRole :: DictCt -> CtFlavourRole+dictCtFlavourRole (DictCt { di_ev = ev })+  = (ctEvFlavour ev, NomEq)++-- | Extract the flavour and role from a 'Ct'+ctFlavourRole :: HasDebugCallStack => Ct -> CtFlavourRole+-- Uses short-cuts for the Role field, for special cases+ctFlavourRole (CDictCan di_ct) = dictCtFlavourRole di_ct+ctFlavourRole (CEqCan eq_ct)   = eqCtFlavourRole eq_ct+ctFlavourRole ct               = ctEvFlavourRole (ctEvidence ct)++{- Note [eqCanRewrite]+~~~~~~~~~~~~~~~~~~~~~~+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form+lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of+a can-rewrite relation, see Definition [Can-rewrite relation] in+GHC.Tc.Solver.Monad.++With the solver handling Coercible constraints like equality constraints,+the rewrite conditions must take role into account, never allowing+a representational equality to rewrite a nominal one.++Note [Wanteds rewrite Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should one Wanted constraint be allowed to rewrite another?++This example (along with #8450) suggests not:+   f :: a -> Bool+   f x = ( [x,'c'], [x,True] ) `seq` True+Here we get+  [W] a ~ Char+  [W] a ~ Bool+but we do not want to complain about Bool ~ Char!++This example suggests yes (indexed-types/should_fail/T4093a):+  type family Foo a+  f :: (Foo e ~ Maybe e) => Foo e+In the ambiguity check, we get+  [G] g1 :: Foo e ~ Maybe e+  [W] w1 :: Foo alpha ~ Foo e+  [W] w2 :: Foo alpha ~ Maybe alpha+w1 gets rewritten by the Given to become+  [W] w3 :: Foo alpha ~ Maybe e+Now, the only way to make progress is to allow Wanteds to rewrite Wanteds.+Rewriting w3 with w2 gives us+  [W] w4 :: Maybe alpha ~ Maybe e+which will soon get us to alpha := e and thence to victory.++TL;DR we want equality saturation.++We thus want Wanteds to rewrite Wanteds in order to accept more programs,+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 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+  coercion holes. The idea is that we wish to report the "root cause" -- the+  error that rewrote all the others.++* 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:++  inert: [W] w1 :: a ~ Char+  work:  [W] w2 :: a ~ Bool++Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding++  inert: [W] w1 :: a ~ Char+         [W] w2 {w1}:: Char ~ Bool++The {w1} in the second line of output is the RewriterSet of w1.++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 prioritise constraints that have no rewriters. Here's why.++Consider this, which came up in T22793:+  inert: {}+  work list: [W] co_ayf : awq ~ awo+  work item: [W] co_ayb : awq ~ awp++  ==> {just put work item in inert set}+  inert: co_ayb : awq ~ awp+  work list: {}+  work: [W] co_ayf : awq ~ awo++  ==> {rewrite ayf with co_ayb}+  work list: {}+  inert: co_ayb : awq ~ awp+         co_aym{co_ayb} : awp ~ awo+                ^ rewritten by ayb++  ----- start again in simplify_loop in Solver.hs -----+  inert: {}+  work list: [W] co_ayb : awq ~ awp+  work: co_aym{co_ayb} : awp ~ awo++  ==> {add to inert set}+  inert: co_aym{co_ayb} : awp ~ awo+  work list: {}+  work: co_ayb : awq ~ awp++  ==> {rewrite co_ayb}+  inert: co_aym{co_ayb} : awp ~ awo+         co_ayp{co_aym} : awq ~ awo+  work list: {}++Now both wanteds have been rewriten by the other! This happened because+in our simplify_loop iteration, we happened to start with co_aym. All would have+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.Monad.selectNextWorkItem`.++Wrinkles++(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.++(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+  written a confusing program!  (T22707 and T22793 were close, but they do+  not exhibit this behaviour.)  So belt and braces: see the `suppress`+  stuff in GHC.Tc.Errors.mkErrorItem.++Note [Avoiding rewriting cycles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes+the can-rewrite relation among CtFlavour/Role pairs, saying which constraints+can rewrite which other constraints. It puts forth (R2):+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+The naive can-rewrite relation says that (Given, Representational) can rewrite+(Wanted, Representational) and that (Wanted, Nominal) can rewrite+(Wanted, Representational), but neither of (Given, Representational) and+(Wanted, Nominal) can rewrite the other. This would violate (R2). See also+Note [Why R2?] in GHC.Tc.Solver.InertSet.++To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational).+This can, in theory, bite, in this scenario:++  type family F a+  data T a+  type role T nominal++  [G] F a ~N T a+  [W] F alpha ~N T alpha+  [W] F alpha ~R T a++As written, this makes no progress, and GHC errors. But, if we+allowed W/N to rewrite W/R, the first W could rewrite the second:++  [G] F a ~N T a+  [W] F alpha ~N T alpha+  [W] T alpha ~R T a++Now we decompose the second W to get++  [W] alpha ~N a++noting the role annotation on T. This causes (alpha := a), and then+everything else unlocks.++What to do? We could "decompose" nominal equalities into nominal-only+("NO") equalities and representational ones, where a NO equality rewrites+only nominals. That is, when considering whether [W] F alpha ~N T alpha+should rewrite [W] F alpha ~R T a, we could require splitting the first W+into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R+half of the split to rewrite the second W, and off we go. This splitting+would allow the split-off R equality to be rewritten by other equalities,+thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet.++However, note that I said that this bites in theory. That's because no+known program actually gives rise to this scenario. A direct encoding+ends up starting with++  [G] F a ~ T a+  [W] F alpha ~ T alpha+  [W] Coercible (F alpha) (T a)++where ~ and Coercible denote lifted class constraints. The ~s quickly+reduce to ~N: good. But the Coercible constraint gets rewritten to++  [W] Coercible (T alpha) (T a)++by the first Wanted. This is because Coercible is a class, and arguments+in class constraints use *nominal* rewriting, not the representational+rewriting that is restricted due to (R2). Note that reordering the code+doesn't help, because equalities (including lifted ones) are prioritized+over Coercible. Thus, I (Richard E.) see no way to write a program that+is rejected because of this infelicity. I have not proved it impossible,+exactly, but my usual tricks have not yielded results.++In the olden days, when we had Derived constraints, this Note was all+about G/R and D/N both rewriting D/R. Back then, the code in+typecheck/should_compile/T19665 really did get rejected. But now,+according to the rewriting of the Coercible constraint, the program+is accepted.++-}++eqCanRewrite :: EqRel -> EqRel -> Bool+eqCanRewrite NomEq  _      = True+eqCanRewrite ReprEq ReprEq = True+eqCanRewrite ReprEq NomEq  = False++eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool+-- Can fr1 actually rewrite fr2?+-- Very important function!+-- See Note [eqCanRewrite]+-- See Note [Wanteds rewrite Wanteds]+-- See Note [Avoiding rewriting cycles]+eqCanRewriteFR (Given,  r1)    (_,      r2)     = eqCanRewrite r1 r2+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
@@ -0,0 +1,259 @@+module GHC.Tc.Types.CtLoc (++  -- * CtLoc+  CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,+  ctLocTypeOrKind_maybe, toInvisibleLoc,+  ctLocDepth, bumpCtLocDepth, isGivenLoc, mkGivenLoc, mkKindEqLoc,+  setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,+  pprCtLoc, adjustCtLoc, adjustCtLocTyConBinder,++  -- * CtLocEnv+  CtLocEnv(..),+  getCtLocEnvLoc, setCtLocEnvLoc, setCtLocRealLoc,+  getCtLocEnvLvl, setCtLocEnvLvl,+  ctLocEnvInGeneratedCode,++  -- * SubGoalDepth+  SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,+  bumpSubGoalDepth, subGoalDepthExceeded++  ) where++import GHC.Prelude++import GHC.Tc.Types.BasicTypes+import GHC.Tc.Types.ErrCtxt+import GHC.Tc.Types.Origin++import GHC.Tc.Utils.TcType++import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import GHC.Types.Basic( IntWithInf, mkIntWithInf, TypeOrKind(..) )++import GHC.Core.TyCon( TyConBinder, isVisibleTyConBinder, isNamedTyConBinder )++import GHC.Utils.Outputable+++{- *********************************************************************+*                                                                      *+            SubGoalDepth+*                                                                      *+********************************************************************* -}++{- Note [SubGoalDepth]+~~~~~~~~~~~~~~~~~~~~~~+The 'SubGoalDepth' takes care of stopping the constraint solver from looping.++The counter starts at zero and increases. It includes dictionary constraints,+equality simplification, and type family reduction. (Why combine these? Because+it's actually quite easy to mistake one for another, in sufficiently involved+scenarios, like ConstraintKinds.)++The flag -freduction-depth=n fixes the maximum level.++* The counter includes the depth of type class instance declarations.  Example:+     [W] d{7} : Eq [Int]+  That is d's dictionary-constraint depth is 7.  If we use the instance+     $dfEqList :: Eq a => Eq [a]+  to simplify it, we get+     d{7} = $dfEqList d'{8}+  where d'{8} : Eq Int, and d' has depth 8.++  For civilised (decidable) instance declarations, each increase of+  depth removes a type constructor from the type, so the depth never+  gets big; i.e. is bounded by the structural depth of the type.++* The counter also increments when resolving+equalities involving type functions. Example:+  Assume we have a wanted at depth 7:+    [W] d{7} : F () ~ a+  If there is a type function equation "F () = Int", this would be rewritten to+    [W] d{8} : Int ~ a+  and remembered as having depth 8.++  Again, without UndecidableInstances, this counter is bounded, but without it+  can resolve things ad infinitum. Hence there is a maximum level.++* Lastly, every time an equality is rewritten, the counter increases. Again,+  rewriting an equality constraint normally makes progress, but it's possible+  the "progress" is just the reduction of an infinitely-reducing type family.+  Hence we need to track the rewrites.++When compiling a program requires a greater depth, then GHC recommends turning+off this check entirely by setting -freduction-depth=0. This is because the+exact number that works is highly variable, and is likely to change even between+minor releases. Because this check is solely to prevent infinite compilation+times, it seems safe to disable it when a user has ascertained that their program+doesn't loop at the type level.++-}++-- | See Note [SubGoalDepth]+newtype SubGoalDepth = SubGoalDepth Int+  deriving (Eq, Ord, Outputable)++initialSubGoalDepth :: SubGoalDepth+initialSubGoalDepth = SubGoalDepth 0++bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth+bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1)++maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth+maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m)++subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool+subGoalDepthExceeded reductionDepth (SubGoalDepth d)+  = mkIntWithInf d > reductionDepth+++{- *********************************************************************+*                                                                      *+            CtLoc+*                                                                      *+************************************************************************++The 'CtLoc' gives information about where a constraint came from.+This is important for decent error message reporting because+dictionaries don't appear in the original source code.++-}++data CtLoc = CtLoc { ctl_origin   :: CtOrigin+                   , ctl_env      :: CtLocEnv -- Everything we need to know about+                                              -- the context this Ct arose in.+                   , ctl_t_or_k   :: Maybe TypeOrKind  -- OK if we're not sure+                   , ctl_depth    :: !SubGoalDepth }++mkKindEqLoc :: TcType -> TcType   -- original *types* being compared+            -> CtLoc -> CtLoc+mkKindEqLoc s1 s2 ctloc+  | CtLoc { ctl_t_or_k = t_or_k, ctl_origin = origin } <- ctloc+  = ctloc { ctl_origin = KindEqOrigin s1 s2 origin t_or_k+          , ctl_t_or_k = Just KindLevel }++adjustCtLocTyConBinder :: TyConBinder -> CtLoc -> CtLoc+-- Adjust the CtLoc when decomposing a type constructor+adjustCtLocTyConBinder tc_bndr loc+  = adjustCtLoc is_vis is_kind loc+  where+    is_vis  = isVisibleTyConBinder tc_bndr+    is_kind = isNamedTyConBinder tc_bndr++adjustCtLoc :: Bool    -- True <=> A visible argument+            -> Bool    -- True <=> A kind argument+            -> CtLoc -> CtLoc+-- Adjust the CtLoc when decomposing a type constructor, application, etc+adjustCtLoc is_vis is_kind loc+  = loc2+  where+    loc1 | is_kind   = toKindLoc loc+         | otherwise = loc+    loc2 | is_vis    = loc1+         | otherwise = toInvisibleLoc loc1++-- | Take a CtLoc and moves it to the kind level+toKindLoc :: CtLoc -> CtLoc+toKindLoc loc = loc { ctl_t_or_k = Just KindLevel }++toInvisibleLoc :: CtLoc -> CtLoc+toInvisibleLoc loc = updateCtLocOrigin loc toInvisibleOrigin++mkGivenLoc :: TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc+mkGivenLoc tclvl skol_info env+  = CtLoc { ctl_origin   = GivenOrigin skol_info+          , ctl_env      = setCtLocEnvLvl env tclvl+          , ctl_t_or_k   = Nothing    -- this only matters for error msgs+          , ctl_depth    = initialSubGoalDepth }++ctLocEnv :: CtLoc -> CtLocEnv+ctLocEnv = ctl_env++ctLocLevel :: CtLoc -> TcLevel+ctLocLevel loc = getCtLocEnvLvl (ctLocEnv loc)++ctLocDepth :: CtLoc -> SubGoalDepth+ctLocDepth = ctl_depth++ctLocOrigin :: CtLoc -> CtOrigin+ctLocOrigin = ctl_origin++ctLocSpan :: CtLoc -> RealSrcSpan+ctLocSpan (CtLoc { ctl_env = lcl}) = getCtLocEnvLoc lcl++ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind+ctLocTypeOrKind_maybe = ctl_t_or_k++setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc+setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setCtLocRealLoc lcl loc)++bumpCtLocDepth :: CtLoc -> CtLoc+bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d }++setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc+setCtLocOrigin ctl orig = ctl { ctl_origin = orig }++updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc+updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd+  = ctl { ctl_origin = upd orig }++setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc+setCtLocEnv ctl env = ctl { ctl_env = env }++isGivenLoc :: CtLoc -> Bool+isGivenLoc loc = isGivenOrigin (ctLocOrigin loc)++pprCtLoc :: CtLoc -> SDoc+-- "arising from ... at ..."+-- Not an instance of Outputable because of the "arising from" prefix+pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl})+  = sep [ pprCtOrigin o+        , text "at" <+> ppr (getCtLocEnvLoc lcl)]+++{- *********************************************************************+*                                                                      *+            CtLocEnv+*                                                                      *+********************************************************************* -}++-- | Local typechecker environment for a constraint.+--+-- Used to restore the environment of a constraint+-- when reporting errors, see `setCtLocM`.+--+-- See also 'TcLclCtxt'.+data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt]+                         , ctl_loc :: !RealSrcSpan+                         , ctl_bndrs :: !TcBinderStack+                         , ctl_tclvl :: !TcLevel+                         , ctl_in_gen_code :: !Bool+                         , ctl_rdr :: !LocalRdrEnv }++getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan+getCtLocEnvLoc = ctl_loc++getCtLocEnvLvl :: CtLocEnv -> TcLevel+getCtLocEnvLvl = ctl_tclvl++setCtLocEnvLvl :: CtLocEnv -> TcLevel -> CtLocEnv+setCtLocEnvLvl env lvl = env { ctl_tclvl = lvl }++setCtLocRealLoc :: CtLocEnv -> RealSrcSpan -> CtLocEnv+setCtLocRealLoc env ss = env { ctl_loc = ss }++setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv+-- See Note [Error contexts in generated code]+-- for the ctl_in_gen_code manipulation+setCtLocEnvLoc env (RealSrcSpan loc _)+  = env { ctl_loc = loc, ctl_in_gen_code = False }++setCtLocEnvLoc env loc@(UnhelpfulSpan _)+  | isGeneratedSrcSpan loc+  = env { ctl_in_gen_code = True }+  | otherwise+  = env++ctLocEnvInGeneratedCode :: CtLocEnv -> Bool+ctLocEnvInGeneratedCode = ctl_in_gen_code
+ compiler/GHC/Tc/Types/ErrCtxt.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}++module GHC.Tc.Types.ErrCtxt+  ( ErrCtxt, ErrCtxtMsg(..)+  , UserSigType(..), FunAppCtxtFunArg(..)+  , TyConInstFlavour(..)+  )+  where++import GHC.Prelude+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, 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
@@ -7,7 +7,7 @@    -- * HsWrapper   HsWrapper(..),-  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,+  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast,   mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta,   collectHsWrapBinders,   idHsWrapper, isIdHsWrapper,@@ -15,22 +15,26 @@    -- * Evidence bindings   TcEvBinds(..), EvBindsVar(..),-  EvBindMap(..), emptyEvBindMap, extendEvBinds,+  EvBindMap(..), emptyEvBindMap, extendEvBinds, unionEvBindMap,   lookupEvBind, evBindMapBinds,   foldEvBindMap, nonDetStrictFoldEvBindMap,   filterEvBindMap,   isEmptyEvBindMap,   evBindMapToVarSet,   varSetMinusEvBindMap,-  EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,+  EvBindInfo(..), EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,   evBindVar, isCoEvBindsVar,    -- * 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(..), @@ -42,7 +46,6 @@   TcMCoercion, TcMCoercionN, TcMCoercionR,   Role(..), LeftOrRight(..), pickLR,   maybeSymCo,-  unwrapIP, wrapIP,    -- * QuoteWrapper   QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy@@ -50,27 +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.Builtin.Names+import GHC.Builtin.Types( unitTy ) +import GHC.Utils.FV import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable@@ -109,6 +120,7 @@ type TcMCoercionN = MCoercionN  -- nominal type TcMCoercionR = MCoercionR  -- representational + -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion maybeSymCo IsSwapped  co = mkSymCo co@@ -170,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 [Wrapper returned from tcSubMult]   deriving Data.Data  -- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data@@ -196,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]@@ -229,7 +253,7 @@  mk_wp_fun_co :: Mult -> TcCoercionR -> TcCoercionR -> TcCoercionR mk_wp_fun_co mult arg_co res_co-  = mkNakedFunCo1 Representational FTF_T_T (multToCo mult) arg_co res_co+  = mkNakedFunCo Representational FTF_T_T (multToCo mult) arg_co res_co     -- FTF_T_T: WpFun is always (->)  mkWpCastR :: TcCoercionR -> HsWrapper@@ -257,6 +281,16 @@ mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids +-- mkWpForAllCast [tv{vis}] constructs a cast+--   forall tv. res  ~R#   forall tv{vis} res`.+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep+--+-- It's a no-op if all binders are invisible;+-- but in that case we refrain from calling it.+mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper+mkWpForAllCast bndrs res_ty+  = mkWpCastR (mkForAllVisCos bndrs (mkRepReflCo res_ty))+ mkWpEvLams :: [Var] -> HsWrapper mkWpEvLams ids = mk_co_lam_fn WpEvLam ids @@ -300,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,@@ -345,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     } @@ -357,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -416,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 @@ -447,24 +492,29 @@ instance Outputable EvBindMap where   ppr (EvBindMap m) = ppr m +data EvBindInfo+  = EvBindGiven { -- See Note [Tracking redundant constraints] in GHC.Tc.Solver+    }+  | EvBindWanted { ebi_canonical :: CanonicalEvidence -- See Note [Desugaring non-canonical evidence]+    }+ ----------------- -- All evidence is bound by EvBinds; no side effects data EvBind-  = EvBind { eb_lhs      :: EvVar-           , eb_rhs      :: EvTerm-           , eb_is_given :: Bool  -- True <=> given-                 -- See Note [Tracking redundant constraints] in GHC.Tc.Solver+  = EvBind { eb_lhs  :: EvVar+           , eb_rhs  :: EvTerm+           , eb_info :: EvBindInfo     }  evBindVar :: EvBind -> EvVar evBindVar = eb_lhs -mkWantedEvBind :: EvVar -> EvTerm -> EvBind-mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm }+mkWantedEvBind :: EvVar -> CanonicalEvidence -> EvTerm -> EvBind+mkWantedEvBind ev c tm = EvBind { eb_info = EvBindWanted c, eb_lhs = ev, eb_rhs = tm }  -- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm mkGivenEvBind :: EvVar -> EvTerm -> EvBind-mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }+mkGivenEvBind ev tm = EvBind { eb_info = EvBindGiven, eb_lhs = ev, eb_rhs = tm }   -- An EvTerm is, conceptually, a CoreExpr that implements the constraint.@@ -479,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@@ -499,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]@@ -568,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@@ -638,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)@@ -650,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.Interact.interactDict.+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 @@ -664,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.Canonical.canClassNC-     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@@ -737,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)@@ -765,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.Interact.interactDict).+  (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]@@ -805,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  {- ********************************************************************* *                                                                      *@@ -831,42 +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_is_given = is_given, eb_rhs = rhs } <- ev_bind-     , is_given-     = 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -874,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 "<>"))@@ -915,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@@ -940,12 +1043,14 @@   getUnique = ebv_uniq  instance Outputable EvBind where-  ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given })+  ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_info = info })      = sep [ pp_gw <+> ppr v            , nest 2 $ equals <+> ppr e ]+      -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing      where-       pp_gw = brackets (if is_given then char 'G' else char 'W')-   -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing+       pp_gw = brackets $ case info of+           EvBindGiven{}  -> char 'G'+           EvBindWanted{} -> char 'W'  instance Outputable EvTerm where   ppr (EvExpr e)         = ppr e@@ -967,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
@@ -0,0 +1,239 @@+module GHC.Tc.Types.LclEnv (+    TcLclEnv(..)+  , TcLclCtxt(..)+  , modifyLclCtxt++  , getLclEnvArrowCtxt+  , getLclEnvThBndrs+  , getLclEnvTypeEnv+  , getLclEnvBinderStack+  , getLclEnvErrCtxt+  , getLclEnvLoc+  , getLclEnvRdrEnv+  , getLclEnvTcLevel+  , getLclEnvThLevel+  , setLclEnvTcLevel+  , setLclEnvLoc+  , setLclEnvRdrEnv+  , setLclEnvBinderStack+  , setLclEnvErrCtxt+  , setLclEnvThLevel+  , setLclEnvTypeEnv+  , modifyLclEnvTcLevel++  , lclEnvInGeneratedCode++  , addLclEnvErrCtxt++  , ArrowCtxt(..)+  , ThBindEnv+  , TcTypeEnv+) where++import GHC.Prelude++import GHC.Tc.Utils.TcType ( TcLevel )+import GHC.Tc.Errors.Types ( TcRnMessage )++import GHC.Core.UsageEnv ( UsageEnv )++import GHC.Types.Name.Reader ( LocalRdrEnv )+import GHC.Types.Name.Env ( NameEnv )+import GHC.Types.SrcLoc ( RealSrcSpan )+import GHC.Types.Basic ( TopLevelFlag )++import GHC.Types.Error ( Messages )++import GHC.Tc.Types.BasicTypes+import GHC.Tc.Types.TH+import GHC.Tc.Types.TcRef+import GHC.Tc.Types.ErrCtxt+import GHC.Tc.Types.Constraint ( WantedConstraints )++{-+************************************************************************+*                                                                      *+                The local typechecker environment+*                                                                      *+************************************************************************++Note [The Global-Env/Local-Env story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type checking, we keep in the tcg_type_env+        * All types and classes+        * All Ids derived from types and classes (constructors, selectors)++At the end of type checking, we zonk the local bindings,+and as we do so we add to the tcg_type_env+        * Locally defined top-level Ids++Why?  Because they are now Ids not TcIds.  This final GlobalEnv is+        a) fed back (via the knot) to typechecking the+           unfoldings of interface signatures+        b) used in the ModDetails of this module+-}++data TcLclEnv           -- Changes as we move inside an expression+                        -- Discarded after typecheck/rename; not passed on to desugarer+  = TcLclEnv {+        -- The part that we sometimes restore using `restoreLclEnv`.+        tcl_lcl_ctxt    :: !TcLclCtxt,++        -- These are exactly the parts of TcLclEnv which are not set by `restoreLclEnv`.++        tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here.+        tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints+        tcl_errs :: TcRef (Messages TcRnMessage)     -- Place to accumulate diagnostics+    }++data TcLclCtxt+  = TcLclCtxt {+        tcl_loc        :: RealSrcSpan,     -- Source span+        tcl_ctxt       :: [ErrCtxt],       -- Error context, innermost on top+        tcl_in_gen_code :: Bool,           -- See Note [Rebindable syntax and XXExprGhcRn]+        tcl_tclvl      :: TcLevel,+        tcl_bndrs      :: TcBinderStack,   -- Used for reporting relevant bindings,+                                           -- and for tidying type++        tcl_rdr :: LocalRdrEnv,         -- Local name envt+                -- Maintained during renaming, of course, but also during+                -- type checking, solely so that when renaming a Template-Haskell+                -- splice we have the right environment for the renamer.+                --+                --   Does *not* include global name envt; may shadow it+                --   Includes both ordinary variables and type variables;+                --   they are kept distinct because tyvar have a different+                --   occurrence constructor (Name.TvOcc)+                -- We still need the unsullied global name env so that+                --   we can look up record field names+++        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)+            -- We can't put this info in the TypeEnv because it's needed+            -- (and extended) in the renamer, for untyped splices++        tcl_arrow_ctxt :: ArrowCtxt,       -- Arrow-notation context++        tcl_env  :: TcTypeEnv    -- The local type environment:+                                 -- Ids and TyVars defined in this module+    }++getLclEnvThLevel :: TcLclEnv -> ThLevel+getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt++setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv+setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l })++getLclEnvThBndrs :: TcLclEnv -> ThBindEnv+getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt++getLclEnvArrowCtxt :: TcLclEnv -> ArrowCtxt+getLclEnvArrowCtxt = tcl_arrow_ctxt . tcl_lcl_ctxt++getLclEnvTypeEnv :: TcLclEnv -> TcTypeEnv+getLclEnvTypeEnv = tcl_env . tcl_lcl_ctxt++setLclEnvTypeEnv :: TcTypeEnv -> TcLclEnv -> TcLclEnv+setLclEnvTypeEnv ty_env = modifyLclCtxt (\env -> env { tcl_env = ty_env})++setLclEnvTcLevel :: TcLevel -> TcLclEnv -> TcLclEnv+setLclEnvTcLevel lvl = modifyLclCtxt (\env -> env {tcl_tclvl = lvl })++modifyLclEnvTcLevel :: (TcLevel -> TcLevel) -> TcLclEnv -> TcLclEnv+modifyLclEnvTcLevel f = modifyLclCtxt (\env -> env { tcl_tclvl = f (tcl_tclvl env)})++getLclEnvTcLevel :: TcLclEnv -> TcLevel+getLclEnvTcLevel = tcl_tclvl . tcl_lcl_ctxt++setLclEnvLoc :: RealSrcSpan -> TcLclEnv -> TcLclEnv+setLclEnvLoc loc = modifyLclCtxt (\lenv -> lenv { tcl_loc = loc })++getLclEnvLoc :: TcLclEnv -> RealSrcSpan+getLclEnvLoc = tcl_loc . tcl_lcl_ctxt++getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt]+getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt++setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv+setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt })++addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv+addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) })++lclEnvInGeneratedCode :: TcLclEnv -> Bool+lclEnvInGeneratedCode = tcl_in_gen_code . tcl_lcl_ctxt++getLclEnvBinderStack :: TcLclEnv -> TcBinderStack+getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt++setLclEnvBinderStack :: TcBinderStack -> TcLclEnv -> TcLclEnv+setLclEnvBinderStack stack = modifyLclCtxt (\env -> env { tcl_bndrs = stack })++getLclEnvRdrEnv :: TcLclEnv -> LocalRdrEnv+getLclEnvRdrEnv = tcl_rdr . tcl_lcl_ctxt++setLclEnvRdrEnv :: LocalRdrEnv -> TcLclEnv -> TcLclEnv+setLclEnvRdrEnv rdr_env = modifyLclCtxt (\env -> env { tcl_rdr = rdr_env })++modifyLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv+modifyLclCtxt upd env =+  let !res = upd (tcl_lcl_ctxt env)+  in env { tcl_lcl_ctxt = res }++++type TcTypeEnv = NameEnv TcTyThing++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+   -- cross-stage at arbitrary types if the Id is bound at top level.+   --+   -- 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+---------------------------++{- Note [Escaping the arrow scope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In arrow notation, a variable bound by a proc (or enclosed let/kappa)+is not in scope to the left of an arrow tail (-<) or the head of (|..|).+For example++        proc x -> (e1 -< e2)++Here, x is not in scope in e1, but it is in scope in e2.  This can get+a bit complicated:++        let x = 3 in+        proc y -> (proc z -> e1) -< e2++Here, x and z are in scope in e1, but y is not.++We implement this by+recording the environment when passing a proc (using newArrowScope),+and returning to that (using escapeArrowScope) on the left of -< and the+head of (|..|).++All this can be dealt with by the *renamer*. But the type checker needs+to be involved too.  Example (arrowfail001)+  class Foo a where foo :: a -> ()+  data Bar = forall a. Foo a => Bar a+  get :: Bar -> ()+  get = proc x -> case x of Bar a -> foo -< a+Here the call of 'foo' gives rise to a (Foo a) constraint that should not+be captured by the pattern match on 'Bar'.  Rather it should join the+constraints from further out.  So we must capture the constraint bag+from further out in the ArrowCtxt that we push inwards.+-}++data ArrowCtxt   -- Note [Escaping the arrow scope]+  = NoArrowCtxt+  | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints)
+ compiler/GHC/Tc/Types/LclEnv.hs-boot view
@@ -0,0 +1,6 @@+module GHC.Tc.Types.LclEnv where++-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Base ()++data TcLclEnv
compiler/GHC/Tc/Types/Origin.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilyDependencies #-}  -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation.@@ -13,28 +16,41 @@    -- * 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(..), -  -- * CtOrigin and CallStack-  isPushCallStackOrigin, callStackOriginFS,+  -- * CallStack+  isPushCallStackOrigin_maybe,+   -- * FixedRuntimeRep origin-  FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..),+  FixedRuntimeRepOrigin(..),+  FixedRuntimeRepContext(..),   pprFixedRuntimeRepContext,-  StmtOrigin(..), RepPolyFun(..), ArgPos(..),-  ClsInstOrQC(..), NakedScFlag(..),+  StmtOrigin(..), ArgPos(..),+  mkFRRUnboxedTuple, mkFRRUnboxedSum, -  -- * Arrow command origin+  -- ** FixedRuntimeRep origin for rep-poly 'Id's+  RepPolyId(..), Polarity(..), Position(..), mkArgPos,++  -- ** Arrow command FixedRuntimeRep origin   FRRArrowContext(..), pprFRRArrowContext,++  -- ** ExpectedFunTy FixedRuntimeRepOrigin   ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, +  -- * InstanceWhat+  InstanceWhat(..), SafeOverlapping   ) where  import GHC.Prelude@@ -46,12 +62,12 @@ 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 )  import GHC.Unit.Module+import GHC.Unit.Module.Warnings import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader@@ -64,11 +80,15 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad+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 (..))+ {- ********************************************************************* *                                                                      *           UserTypeCtxt@@ -83,11 +103,22 @@                     -- Also used for types in SPECIALISE pragmas        Name              -- Name of the function        ReportRedundantConstraints-         -- This is usually 'WantRCC', but 'NoRCC' for+         -- See Note [Tracking redundant constraints] in GHC.Tc.Solver+         -- This field is usually 'WantRCC', but 'NoRCC' for          --   * Record selectors (not important here)          --   * Class and instance methods.  Here the code may legitimately          --     be more polymorphic than the signature generated from the          --     class declaration+         --   * Functions whose type signature has hidden the constraints+         --     behind a type synonym.  E.g.+         --          type Foo = forall a. Eq a => a -> a+         --          id :: Foo+         --          id x = x+         --     Here we can't give a good location for the redundant constraints+         --     (see lhsSigWcTypeContextSpan), so we don't report redundant+         --     constraints at all. It's not clear that this a good choice;+         --     perhaps we should report, just with a less informative SrcSpan.+         --     c.f. #16154    | InfSigCtxt Name     -- Inferred type for function   | ExprSigCtxt         -- Expression type signature@@ -102,10 +133,8 @@   | 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     -- Types in a default declaration+  | DefaultDeclCtxt     -- Class or types in a default declaration   | InstDeclCtxt Bool   -- An instance declaration                         --    True:  stand-alone deriving                         --    False: vanilla instance declaration@@ -126,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@@ -134,10 +166,14 @@ -- | Report Redundant Constraints. data ReportRedundantConstraints   = NoRRC            -- ^ Don't report redundant constraints-  | WantRRC SrcSpan  -- ^ Report redundant constraints, and here-                     -- is the SrcSpan for the constraints-                     -- E.g. f :: (Eq a, Ord b) => blah-                     -- The span is for the (Eq a, Ord b)++  | WantRRC SrcSpan  -- ^ Report redundant constraints+      -- The SrcSpan is for the constraints+      -- E.g. f :: (Eq a, Ord b) => blah+      --      The span is for the (Eq a, Ord b)+      -- We need to record the span here because we have+      -- long since discarded the HsType in favour of a Type+   deriving( Eq )  -- Just for checkSkolInfoAnon  reportRedundantConstraints :: ReportRedundantConstraints -> Bool@@ -163,18 +199,17 @@   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) pprUserTypeCtxt (TySynCtxt c)     = text "the RHS of the type synonym" <+> quotes (ppr c) pprUserTypeCtxt PatSigCtxt        = text "a pattern type signature" pprUserTypeCtxt (ForSigCtxt n)    = text "the foreign declaration for" <+> quotes (ppr n)-pprUserTypeCtxt DefaultDeclCtxt   = text "a type in a `default' declaration"+pprUserTypeCtxt DefaultDeclCtxt   = text "a `default' declaration" pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" pprUserTypeCtxt (InstDeclCtxt True)  = text "a stand-alone deriving instance declaration" pprUserTypeCtxt SpecInstCtxt      = text "a SPECIALISE instance pragma"@@ -186,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)@@ -255,10 +291,17 @@        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.-      (HsMatchContext GhcTc)+      HsMatchContextRn              -- e.g.   data T = forall a. Eq a => MkT a              --        f (MkT x) = ...              -- The pattern MkT x will allocate an existential type@@ -267,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)@@ -278,7 +322,7 @@   | UnifyForAllSkol     -- We are unifying two for-all types        TcType           -- The instantiated type *inside* the forall -  | TyConSkol TyConFlavour Name  -- bound in a type declaration of the given flavour+  | TyConSkol (TyConFlavour TyCon) Name -- bound in a type declaration of the given flavour    | DataConSkol Name    -- bound as an existential in a Haskell98 datacon decl or                         -- as any variable in a GADT datacon decl@@ -297,10 +341,10 @@ -- -- We're hoping to be able to get rid of this entirely, but for the moment -- it's still needed.-unkSkol :: HasCallStack => SkolemInfo+unkSkol :: HasDebugCallStack => SkolemInfo unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon -unkSkolAnon :: HasCallStack => SkolemInfoAnon+unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon unkSkolAnon = UnkSkol callStack  -- | Wrap up the origin of a skolem type variable with a new 'Unique',@@ -314,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 @@ -333,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")@@ -410,15 +454,15 @@   whatever it tidies to, say a''; and then we walk over the type   replacing the binder a by the tidied version a'', to give        forall a''. Eq a'' => forall b''. b'' -> a''-  We need to do this under (=>) arrows, to match what topSkolemise+  We need to do this under (=>) arrows and (->), to match what skolemisation   does.  * Typically a'' will have a nice pretty name like "a", but the point is   that the foral-bound variables of the signature we report line up with   the instantiated skolems lying  around in other types.-+-} -************************************************************************+{- ********************************************************************* *                                                                      *             CtOrigin *                                                                      *@@ -433,6 +477,7 @@   = HsTypeRnThing (HsType GhcRn)   | TypeThing Type   | HsExprRnThing (HsExpr GhcRn)+  | HsExprTcThing (HsExpr GhcTc)   | NameThing Name  -- | Some kind of type variable binder.@@ -446,6 +491,7 @@   ppr (HsTypeRnThing ty) = ppr ty   ppr (TypeThing ty) = ppr ty   ppr (HsExprRnThing expr) = ppr expr+  ppr (HsExprTcThing expr) = ppr expr   ppr (NameThing name) = ppr name  instance Outputable TyVarBndrs where@@ -467,7 +513,7 @@          ScDepth         -- ^ The number of superclass selections necessary to                         -- get this constraint; see Note [Replacement vs keeping]-                        -- in GHC.Tc.Solver.Interact+                        -- in GHC.Tc.Solver.Dict          Bool   -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds                --                      i.e. ones with (ScOrigin _ NakedSc)@@ -476,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  @@ -511,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@@ -528,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@@ -538,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@@ -578,9 +620,8 @@   | IfThenElseOrigin    -- An if-then-else expression   | BracketOrigin       -- An overloaded quotation bracket   | StaticOrigin        -- A static form-  | Shouldn'tHappenOrigin String-                            -- the user should never see this one-  | GhcBug20076             -- see #20076+  | ImpedanceMatching Id   -- See Note [Impedance matching] in GHC.Tc.Gen.Bind+  | Shouldn'tHappenOrigin String  -- The user should never see this one    -- | Testing whether the constraint associated with an instance declaration   -- in a signature file is satisfied upon instantiation.@@ -590,13 +631,14 @@       Module  -- ^ Module in which the instance was declared       ClsInst -- ^ The declared typeclass instance -  | NonLinearPatternOrigin+  | NonLinearPatternOrigin NonLinearPatternReason (LPat GhcRn)+  | 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.Canonical   | FRROrigin       FixedRuntimeRepOrigin @@ -610,15 +652,31 @@       Type   -- the instance-sig type       Type   -- the instantiated type of the method   | AmbiguityCheckOrigin UserTypeCtxt+  | ImplicitLiftOrigin HsImplicitLiftSplice +data NonLinearPatternReason+  = LazyPatternReason+  | GeneralisedPatternReason+  | PatternSynonymReason+  | 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@@ -668,30 +726,24 @@ 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 (HsRecSel _ f)       = OccurrenceOfRecSel (unLoc $ foLabel f)-exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l+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 exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"-exprCtOrigin (HsLam _ matches)    = matchesCtOrigin matches-exprCtOrigin (HsLamCase _ _ ms)   = matchesCtOrigin ms+exprCtOrigin (HsLam _ _ ms)       = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _)       = lexprCtOrigin e1-exprCtOrigin (HsAppType _ e1 _ _) = lexprCtOrigin e1+exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e-exprCtOrigin (HsPar _ _ e _)      = lexprCtOrigin e+exprCtOrigin (HsPar _ e)          = lexprCtOrigin e exprCtOrigin (HsProjection _ _)   = SectionOrigin exprCtOrigin (SectionL _ _ _)     = SectionOrigin exprCtOrigin (SectionR _ _ _)     = SectionOrigin@@ -700,7 +752,7 @@ exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {})           = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs-exprCtOrigin (HsLet _ _ _ _ e)   = lexprCtOrigin e+exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e exprCtOrigin (HsDo {})           = DoOrigin exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {})      = RecordUpdOrigin@@ -713,7 +765,16 @@ exprCtOrigin (HsUntypedSplice {})  = Shouldn'tHappenOrigin "TH untyped splice" exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"-exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a+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]+exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a+                                               | OrigStmt _ <- thing = DoOrigin+                                               | OrigPat p  <- thing = DoPatOrigin p+exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"+exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)  -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin@@ -730,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 @@ -744,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 @@ -767,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)))@@ -806,22 +871,19 @@          , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"          ] -pprCtOrigin GhcBug20076-  = vcat [ text "GHC Bug #20076 <https://gitlab.haskell.org/ghc/ghc/-/issues/20076>"-         , text "Assuming you have a partial type signature, you can avoid this error"-         , text "by either adding an extra-constraints wildcard (like `(..., _) => ...`,"-         , text "with the underscore at the end of the constraint), or by avoiding the"-         , text "use of a simplifiable constraint in your partial type signature." ]- pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) })   = hang (ctoHerald <+> text "the \"provided\" constraints claimed by")        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 [ ctoHerald <+> text "matching required constraints"+         , text "in a binding group involving" <+> quotes (ppr x)]+ pprCtOrigin (CycleBreakerOrigin orig)   = pprCtOrigin orig @@ -845,80 +907,100 @@   = 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 :: HasCallStack => 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 NonLinearPatternOrigin = text "a non-linear pattern"-pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]-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 GhcBug20076                  = text "GHC Bug #20076"-pprCtO (WantedSuperclassOrigin {})  = text "a superclass constraint"-pprCtO (InstanceSigOrigin {})       = text "a type signature in an instance"-pprCtO (AmbiguityCheckOrigin {})    = text "a type ambiguity check"+-- 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")+pprNonLinearPatternReason GeneralisedPatternReason = parens (text "non-variable pattern bindings that have been generalised aren't linear")+pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms aren't linear")+pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear")+pprNonLinearPatternReason OtherPatternReason = empty++ {- ********************************************************************* *                                                                      *              CallStacks and CtOrigin@@ -927,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))  {- ************************************************************************@@ -991,12 +1077,17 @@   = FixedRuntimeRepOrigin     { frr_type    :: Type        -- ^ What type are we checking?-       -- For example, `a[tau]` in `a[tau] :: TYPE rr[tau]`.+       -- For example, @a[tau]@ in @a[tau] :: TYPE rr[tau]@.      , frr_context :: FixedRuntimeRepContext       -- ^ What context requires a fixed runtime representation?     } +instance Outputable FixedRuntimeRepOrigin where+  ppr (FixedRuntimeRepOrigin { frr_type = ty, frr_context = cxt })+    = text "FrOrigin" <> braces (vcat [ text "frr_type:" <+> ppr ty+                                      , text "frr_context:" <+> ppr cxt ])+ -- | The context in which a representation-polymorphism check was performed. -- -- Does not include the type on which the check was performed; see@@ -1017,6 +1108,32 @@   -- Test cases: LevPolyLet, RepPolyPatBind.   | FRRBinder !Name +  -- | Types appearing in negative position in the type of a+  -- representation-polymorphic 'Id' must have a fixed runtime representation.+  --+  -- This includes:+  --+  --  - arguments,+  --+  --    Test cases: RepPolyMagic, RepPolyRightSection, RepPolyWrappedVar,+  --                T14561b, T17817.+  --+  --  - continuation result types, such as in 'catch#', 'keepAlive#'+  --    and 'control0#'.+  --+  --    Test case: T21906.+  | FRRRepPolyId+      !Name+      !RepPolyId+      !(Position Neg)++  -- | A partial application of the constructor of a representation-polymorphic+  -- unlifted newtype in which the argument type does not have a fixed+  -- runtime representation.+  --+  -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.+  | FRRRepPolyUnliftedNewtype !DataCon+   -- | Pattern binds must have a fixed runtime representation.   --   -- Test case: RepPolyInferPatBind.@@ -1039,26 +1156,20 @@   -- Test case: T20363.   | FRRDataConPatArg !DataCon !Int -  -- | An instantiation of a function with no binding (e.g. `coerce`, `unsafeCoerce#`, an unboxed tuple 'DataCon')-  -- in which one of the remaining arguments types does not have a fixed runtime representation.-  ---  -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.-  | FRRNoBindingResArg !RepPolyFun !ArgPos--  -- | Arguments to unboxed tuples must have fixed runtime representations.+  -- | The 'RuntimeRep' arguments to unboxed tuples must be concrete 'RuntimeRep's.   --   -- Test case: RepPolyTuple.-  | FRRTupleArg !Int+  | FRRUnboxedTuple !Int    -- | Tuple sections must have a fixed runtime representation.   --   -- Test case: RepPolyTupleSection.-  | FRRTupleSection !Int+  | FRRUnboxedTupleSection !Int -  -- | Unboxed sums must have a fixed runtime representation.+  -- | The 'RuntimeRep' arguments to unboxed sums must be concrete 'RuntimeRep's.   --   -- Test cases: RepPolySum.-  | FRRUnboxedSum+  | FRRUnboxedSum !(Maybe Int)    -- | The body of a @do@ expression or a monad comprehension must   -- have a fixed runtime representation.@@ -1088,8 +1199,8 @@   -- See 'FRRArrowContext' for more details.   | FRRArrow !FRRArrowContext -  -- | A representation-polymorphic check arising from a call-  -- to 'matchExpectedFunTys' or 'matchActualFunTySigma'.+  -- | A representation-polymorphism check arising from a call+  -- to 'matchExpectedFunTys' or 'matchActualFunTy'.   --   -- See 'ExpectedFunTyOrigin' for more details.   | FRRExpectedFunTy@@ -1097,6 +1208,35 @@       !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'.+  = RepPolyPrimOp+  -- | An unboxed tuple constructor.+  | RepPolyTuple+  -- | An unboxed sum constructor.+  | RepPolySum+  -- | An unspecified representation-polymorphic function,+  -- e.g. a pseudo-op such as 'coerce'.+  | RepPolyFunction++-- | A synonym for 'FRRUnboxedTuple' exposed in the hs-boot file+-- for "GHC.Tc.Types.Origin".+mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext+mkFRRUnboxedTuple = FRRUnboxedTuple++-- | A synonym for 'FRRUnboxedSum' exposed in the hs-boot file+-- for "GHC.Tc.Types.Origin".+mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext+mkFRRUnboxedSum = FRRUnboxedSum+ -- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check. -- -- Note that this function does not include the specific 'RuntimeRep'@@ -1112,6 +1252,8 @@ pprFixedRuntimeRepContext (FRRBinder binder)   = sep [ text "The binder"         , quotes (ppr binder) ]+pprFixedRuntimeRepContext (FRRRepPolyId nm id pos)+  = text "The" <+> ppr pos <+> text "of" <+> pprRepPolyId id nm pprFixedRuntimeRepContext FRRPatBind   = text "The pattern binding" pprFixedRuntimeRepContext FRRPatSynArg@@ -1127,30 +1269,17 @@       = text "newtype constructor pattern"       | otherwise       = text "data constructor pattern in" <+> speakNth i <+> text "position"-pprFixedRuntimeRepContext (FRRNoBindingResArg fn arg_pos)-  = vcat [ text "Unsaturated use of a representation-polymorphic" <+> what_fun <> dot-         , what_arg <+> text "argument of" <+> quotes (ppr fn) ]-  where-    what_fun, what_arg :: SDoc-    what_fun = case fn of-      RepPolyWiredIn {} -> text "primitive function"-      RepPolyDataCon dc -> what_con <+> text "constructor"-        where-          what_con :: SDoc-          what_con-            | isNewDataCon dc-            = text "newtype"-            | otherwise-            = text "data"-    what_arg = case arg_pos of-      ArgPosInvis -> text "An invisible"-      ArgPosVis i -> text "The" <+> speakNth i-pprFixedRuntimeRepContext (FRRTupleArg i)-  = text "The tuple argument in" <+> speakNth i <+> text "position"-pprFixedRuntimeRepContext (FRRTupleSection i)-  = text "The" <+> speakNth i <+> text "component of the tuple section"-pprFixedRuntimeRepContext FRRUnboxedSum+pprFixedRuntimeRepContext (FRRRepPolyUnliftedNewtype dc)+  = vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype."+         , text "The argument of the newtype constructor" <+> quotes (ppr dc) ]+pprFixedRuntimeRepContext (FRRUnboxedTuple i)+  = text "The" <+> speakNth i <+> text "component of the unboxed tuple"+pprFixedRuntimeRepContext (FRRUnboxedTupleSection i)+  = text "The" <+> speakNth i <+> text "component of the unboxed tuple section"+pprFixedRuntimeRepContext (FRRUnboxedSum Nothing)   = text "The unboxed sum"+pprFixedRuntimeRepContext (FRRUnboxedSum (Just i))+  = text "The" <+> speakNth i <+> text "component of the unboxed sum" pprFixedRuntimeRepContext (FRRBodyStmt stmtOrig i)   = vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma          , text "arising from the" <+> ppr stmtOrig <> comma ]@@ -1166,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@@ -1181,23 +1317,6 @@   ppr MonadComprehension = text "monad comprehension"   ppr DoNotation         = quotes ( text "do" ) <+> text "statement" --- | A function with representation-polymorphic arguments,--- such as @coerce@ or @(#, #)@.------ Used for reporting partial applications of representation-polymorphic--- functions in error messages.-data RepPolyFun-  = RepPolyWiredIn !Id-    -- ^ A wired-in function with representation-polymorphic-    -- arguments, such as 'coerce'.-  | RepPolyDataCon !DataCon-    -- ^ A data constructor with representation-polymorphic arguments,-    -- such as an unboxed tuple or a newtype constructor with @-XUnliftedNewtypes@.--instance Outputable RepPolyFun where-  ppr (RepPolyWiredIn id) = ppr id-  ppr (RepPolyDataCon dc) = ppr dc- -- | The position of an argument (to be reported in an error message). data ArgPos   = ArgPosInvis@@ -1207,6 +1326,133 @@  {- ********************************************************************* *                                                                      *+            FixedRuntimeRep: representation-polymorphic Ids+*                                                                      *+********************************************************************* -}++{- 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 = 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 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"++      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+    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)+  where+    id_desc = case id of+      RepPolyPrimOp   {} -> text "the primop"+      RepPolySum      {} -> text "the unboxed sum constructor"+      RepPolyTuple    {} -> text "the unboxed tuple constructor"+      RepPolyFunction {} -> empty++{- *********************************************************************+*                                                                      *                        FixedRuntimeRep: arrows *                                                                      * ********************************************************************* -}@@ -1276,7 +1522,7 @@ ********************************************************************* -}  -- | In what context are we calling 'matchExpectedFunTys'--- or 'matchActualFunTySigma'?+-- or 'matchActualFunTy'? -- -- Used for two things: --@@ -1297,9 +1543,9 @@   --   -- Test cases for representation-polymorphism checks:   --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK-  = ExpectedFunTySyntaxOp-    !CtOrigin-    !(HsExpr GhcRn)+  = forall (p :: Pass)+     . (OutputableBndrId p)+    => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))       -- ^ rebindable syntax operator    -- | A view pattern must have a function type.@@ -1315,8 +1561,7 @@   -- Test cases for representation-polymorphism checks:   --   RepPolyApp   | forall (p :: Pass)-      . (OutputableBndrId p)-      => ExpectedFunTyArg+     . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg           !TypedThing             -- ^ function           !(HsExpr (GhcPass p))@@ -1336,16 +1581,8 @@   -- | Ensure that a lambda abstraction has a function type.   --   -- Test cases for representation-polymorphism checks:-  --   RepPolyLambda-  | ExpectedFunTyLam-      !(MatchGroup GhcRn (LHsExpr GhcRn))--  -- | Ensure that a lambda case expression has a function type.-  ---  -- Test cases for representation-polymorphism checks:-  --   RepPolyMatch-  | ExpectedFunTyLamCase-      LamCaseVariant+  --   RepPolyLambda, RepPolyMatch+  | ExpectedFunTyLam HsLamVariant       !(HsExpr GhcRn)        -- ^ the entire lambda-case expression @@ -1373,8 +1610,7 @@       | otherwise       -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts      <+> text "for" <+> quotes (ppr fun)-    ExpectedFunTyLam {} -> binder_of $ text "lambda"-    ExpectedFunTyLamCase lc_variant _ -> binder_of $ lamCaseKeyword lc_variant+    ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant   where     the_arg_of :: SDoc     the_arg_of = text "The" <+> speakNth i <+> text "argument of"@@ -1392,12 +1628,50 @@         , text "is applied to" ] pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))   = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts-pprExpectedFunTyHerald (ExpectedFunTyLam match)-  = sep [ text "The lambda expression" <+>-                   quotes (pprSetDepth (PartWay 1) $-                           pprMatches match)-        -- The pprSetDepth makes the lambda abstraction print briefly+pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr)+  = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression"+                     <+> quotes (pprSetDepth (PartWay 1) (ppr expr))+               -- The pprSetDepth makes the lambda abstraction print briefly         , text "has" ]-pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)-  = sep [ text "The function" <+> quotes (ppr expr)-        , text "requires" ]++{- *******************************************************************+*                                                                    *+                       InstanceWhat+*                                                                    *+**********************************************************************-}++-- | Indicates if Instance met the Safe Haskell overlapping instances safety+-- check.+--+-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+type SafeOverlapping = Bool++data InstanceWhat  -- How did we solve this constraint?+  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]++  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)+                         -- 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)++  | LocalInstance        -- Solved by a quantified constraint+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]++  | TopLevInstance       -- Solved by a top-level instance decl+      { iw_dfun_id   :: DFunId+      , iw_safe_over :: SafeOverlapping+      , iw_warn      :: Maybe (WarningTxt GhcRn) }+            -- See Note [Implementation of deprecated instances]+            -- in GHC.Tc.Solver.Dict++instance Outputable InstanceWhat where+  ppr BuiltinInstance   = text "a built-in instance"+  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"+  ppr BuiltinEqInstance = text "a built-in equality instance"+  ppr LocalInstance     = text "a locally-quantified instance"+  ppr (TopLevInstance { iw_dfun_id = dfun })+      = hang (text "instance" <+> pprSigmaType (idType dfun))+           2 (text "--" <+> pprDefinedAt (idName dfun))
compiler/GHC/Tc/Types/Origin.hs-boot view
@@ -1,14 +1,19 @@ module GHC.Tc.Types.Origin where -import GHC.Stack ( HasCallStack )+import GHC.Prelude.Basic ( Int, Maybe )+import GHC.Utils.Misc ( HasDebugCallStack )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )  data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext data FixedRuntimeRepOrigin+  = FixedRuntimeRepOrigin+    { frr_type    :: Type+    , frr_context :: FixedRuntimeRepContext+    } -data CtOrigin-data ClsInstOrQC = IsClsInst-                 | IsQC CtOrigin+mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext+mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext -unkSkol :: HasCallStack => SkolemInfo+unkSkol :: HasDebugCallStack => SkolemInfo
+ compiler/GHC/Tc/Types/TH.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Tc.Types.TH (+    SpliceType(..)+  , SpliceOrBracket(..)+  , ThLevel(.., TypedBrack, UntypedBrack)+  , PendingStuff(..)+  , 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.Tc.Types.TcRef+import GHC.Tc.Types.Constraint+import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )+import GHC.Types.ThLevelIndex++---------------------------+-- Template Haskell stages and levels+---------------------------++data SpliceType = Typed | Untyped+data SpliceOrBracket = IsSplice | IsBracket++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:  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+      -- Haskell code for the splice. See Note [RunSplice ThLevel].+      --+      -- Contains a list of mod finalizers collected while executing the splice.+      --+      -- 'addModFinalizer' inserts finalizers here, and from here they are taken+      -- to construct an @HsSpliced@ annotation for untyped splices. See Note+      -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.+      --+      -- For typed splices, the typechecker takes finalizers from here and+      -- inserts them in the list of finalizers in the global environment.+      --+      -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice".++  | Comp        -- Ordinary Haskell code+                -- Binding level = 0++  | Brack                       -- Inside brackets+      ThLevel                   --  Enclosing level+      PendingStuff++data PendingStuff+  = RnPending                     -- Renaming the inside of a bracket+      (TcRef [PendingRnSplice])   -- Pending splices in here++  | RnPendingTyped                -- Renaming the inside of a *typed* bracket++  | TcPending                     -- Typechecking the inside of a typed bracket+      (TcRef [PendingTcSplice])   --   Accumulate pending splices here+      (TcRef WantedConstraints)   --     and type constraints here+      QuoteWrapper                -- A type variable and evidence variable+                                  -- for the overall monad of+                                  -- the bracket. Splices are checked+                                  -- against this monad. The evidence+                                  -- variable is used for desugaring+                                  -- `lift`.++isTypedPending :: PendingStuff -> Bool+isTypedPending (RnPending _) = False+isTypedPending (RnPendingTyped) = True+isTypedPending (TcPending _ _ _) = True++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)++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)+++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' 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+Proper fix would probably require renaming argument `reifyInstances` separately prior+to evaluation of the overall splice.++'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert+the finalizer (see Note [Delaying modFinalizers in untyped splices]), and+'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to+set 'RunSplice' when renaming or typechecking the splice, where 'Splice',+'Brack' or 'Comp' are used instead.++-}+
+ compiler/GHC/Tc/Types/TcRef.hs view
@@ -0,0 +1,37 @@+module GHC.Tc.Types.TcRef (TcRef, newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM) where++import GHC.Prelude++import Control.Monad.IO.Class+import Data.IORef++-- | Type alias for 'IORef'; the convention is we'll use this for mutable+-- bits of data in the typechecker which are updated during typechecking and+-- returned at the end.+type TcRef a = IORef a++-- The following functions are all marked INLINE so that we+-- don't end up passing a Monad or MonadIO dictionary.++newTcRef :: MonadIO m => a -> m (TcRef a)+newTcRef = \ a -> liftIO $ newIORef a+{-# INLINE newTcRef #-}++readTcRef :: MonadIO m => TcRef a -> m a+readTcRef = \ ref -> liftIO $ readIORef ref+{-# INLINE readTcRef #-}++writeTcRef :: MonadIO m => TcRef a -> a -> m ()+writeTcRef = \ ref a -> liftIO $ writeIORef ref a+{-# INLINE writeTcRef #-}++updTcRef :: MonadIO m => TcRef a -> (a -> a) -> m ()+updTcRef = \ ref fn -> liftIO $ modifyIORef' ref fn+{-# INLINE updTcRef #-}++updTcRefM :: MonadIO m => TcRef a -> (a -> m a) -> m ()+updTcRefM ref upd+  = do { contents      <- readTcRef ref+       ; !new_contents <- upd contents+       ; writeTcRef ref new_contents }+{-# INLINE updTcRefM #-}
compiler/GHC/Tc/Utils/TcType.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE MultiWayIf          #-}  {- (c) The University of Glasgow 2006@@ -22,23 +24,27 @@   --------------------------------   -- 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(..), InferResult(..),+  ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),   ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,-  ExpRhoType,+  ExpRhoType, ExpRhoTypeFRR,   mkCheckExpType,+  checkingExpType_maybe, checkingExpType, +  ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType,+  isVisibleExpPatType, isExpFunPatType,+   SyntaxOpType(..), synKnownType, mkSynFunTys,    --------------------------------   -- TcLevel   TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,   strictlyDeeperThan, deeperThanOrSame, sameDepthAs,-  tcTypeLevel, tcTyVarLevel, maxTcLevel,+  tcTypeLevel, tcTyVarLevel, maxTcLevel, minTcLevel,    --------------------------------   -- MetaDetails@@ -47,9 +53,11 @@   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,   ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,-  isConcreteTyVarTy, isConcreteTyVarTy_maybe,+  isConcreteTyVarTy, isConcreteTyVarTy_maybe, concreteInfo_maybe,+  ConcreteTyVars, noConcreteTyVars,   isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,+  isQLInstTyVar, isRuntimeUnkTyVar,   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,   isTouchableMetaTyVar, isPromotableMetaTyVar,   findDupTyVarTvs, mkTyVarNamePairs,@@ -62,7 +70,7 @@   --------------------------------   -- Splitters   getTyVar, getTyVar_maybe, getCastedTyVar_maybe,-  tcSplitForAllTyVarBinder_maybe,+  tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN,   tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars,   tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders,   tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders,@@ -72,7 +80,7 @@   tcSplitTyConApp, tcSplitTyConApp_maybe,   tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe,-  tcSplitSigmaTy, tcSplitNestedSigmaTys,+  tcSplitSigmaTy, tcSplitSigmaTyBndrs, tcSplitNestedSigmaTys, tcSplitIOType_maybe,    ---------------------------------   -- Predicates.@@ -80,25 +88,23 @@   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,+  isRigidTy, anyTy_maybe,     -- Re-exported from GHC.Core.TyCo.Compare   -- mainly just for back-compat reasons-  eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,-  pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,+  eqType, eqTypes, nonDetCmpType, eqTypeX,+  pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical,   tcEqTyConApps, eqForAllVis, eqVarBndrs,    ---------------------------------   -- Misc type manipulators    deNoteType,-  orphNamesOfType, orphNamesOfCo,-  orphNamesOfTypes, orphNamesOfCoCon,   getDFunTyKey, evVarPred,   ambigTkvsOfTy, @@ -114,31 +120,17 @@    -- * Finding "exact" (non-dead) type variables   exactTyCoVarsOfType, exactTyCoVarsOfTypes,-  anyRewritableTyVar, anyRewritableTyFamApp,--  ----------------------------------  -- Foreign import and export-  IllegalForeignTypeReason(..),-  TypeCannotBeMarshaledReason(..),-  isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool-  isFFIImportResultTy, -- :: DynFlags -> Type -> Bool-  isFFIExportResultTy, -- :: Type -> Bool-  isFFIExternalTy,     -- :: Type -> Bool-  isFFIDynTy,          -- :: Type -> Type -> Bool-  isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool-  isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool-  isFFILabelTy,        -- :: Type -> Bool-  isFunPtrTy,          -- :: Type -> Bool-  tcSplitIOType_maybe, -- :: Type -> Maybe Type+  anyRewritableTyVar, anyRewritableTyFamApp, UnderFam,    ---------------------------------   -- Patersons sizes-  PatersonSize(..), PatersonSizeFailure(..),+  PatersonSize(..), PatersonCondFailure(..),+  PatersonCondFailureContext(..),   ltPatersonSize,   pSizeZero, pSizeOne,   pSizeType, pSizeTypeX, pSizeTypes,   pSizeClassPred, pSizeClassPredX,-  pSizeTyConApp,+  pSizeTyConApp, pSizeHead,   noMoreTyVars, allDistinctTyVars,   TypeSize, sizeType, sizeTypes, scopedSort,   isTerminatingClass, isStuckTypeFamily,@@ -163,8 +155,8 @@   mkTyConTy, mkTyVarTy, mkTyVarTys,   mkTyCoVarTy, mkTyCoVarTys, -  isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,-  mkClassPred,+  isClassPred, isEqPred, couldBeIPLike, isEqClassPred,+  isEqualityClass, mkClassPred,   tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,   isRuntimeRepVar, isFixedRuntimeRepKind,   isVisiblePiTyBinder, isInvisiblePiTyBinder,@@ -174,11 +166,11 @@   TvSubstEnv, emptySubst, mkEmptySubst,   zipTvSubst,   mkTvSubstPrs, notElemSubst, unionSubst,-  getTvSubstEnv, getSubstInScope, extendSubstInScope,+  getTvSubstEnv, substInScopeSet, extendSubstInScope,   extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,   Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,   Type.extendTvSubst,-  isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv,+  isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,   Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars,   substTyAddInScope,   substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,@@ -207,7 +199,7 @@    ---------------------------------   -- argument visibility-  tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible+  tyConVisibilities, isNextTyConArgVisible, isNextArgVisible    ) where @@ -221,12 +213,10 @@ import GHC.Core.TyCo.Ppr import GHC.Core.Class import GHC.Types.Var-import GHC.Types.ForeignCall import GHC.Types.Var.Set import GHC.Core.Coercion import GHC.Core.Type as Type import GHC.Core.Predicate-import GHC.Types.RepType import GHC.Core.TyCon  import {-# SOURCE #-} GHC.Tc.Types.Origin@@ -234,14 +224,13 @@   , FixedRuntimeRepOrigin, FixedRuntimeRepContext )  -- others:-import GHC.Driver.Session-import GHC.Core.FVs import GHC.Types.Name as Name             -- We use this to make dictionaries for type literals.             -- Perhaps there's a better way to do this?+import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Builtin.Names-import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey+import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey                          , listTyCon, constraintKind ) import GHC.Types.Basic import GHC.Utils.Misc@@ -249,17 +238,11 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Error( Validity'(..) )-import GHC.Utils.Unique (anyOfUnique)-import qualified GHC.LanguageExtensions as LangExt -import Data.IORef+import Data.IORef ( IORef ) import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition, nub, (\\) ) -import GHC.Generics ( Generic )- {- ************************************************************************ *                                                                      *@@ -372,7 +355,7 @@ type TcInvisTVBinder   = InvisTVBinder type TcReqTVBinder     = ReqTVBinder --- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]+-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl type TcTyCon       = TyCon type MonoTcTyCon   = TcTyCon type PolyTcTyCon   = TcTyCon@@ -397,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@@ -406,51 +390,7 @@ type TcDTyVarSet    = DTyVarSet type TcDTyCoVarSet  = DTyCoVarSet -{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [How TcTyCons work] in GHC.Tc.TyCl -Invariants:--* TcTyCon: a TyCon built with the TcTyCon constructor--* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar)--* TcTyCons contain TcTyVars--* MonoTcTyCon:-  - Flag tcTyConIsPoly = False--  - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable-    The order is important: Specified then Required variables.   E.g. in-        data T a (b :: k) = ...-    the order will be [k, a, b].--    NB: There are no Inferred binders in tyConScopedTyVars; 'a' may-    also be poly-kinded, but that kind variable will be added by-    generaliseTcTyCon, in the passage to a PolyTcTyCon.--  - tyConBinders are irrelevant; we just use tcTyConScopedTyVars-    Well not /quite/ irrelevant: its length gives the number of Required binders,-    and so allows up to distinguish between the Specified and Required elements of-    tyConScopedTyVars.--* PolyTcTyCon:-  - Flag tcTyConIsPoly = True; this is used only to short-cut zonking--  - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars,-    with fixed kinds, and accurate skolem info: no unification variables here--    tyConBinders includes the Inferred binders if any--    tyConBinders uses the Names from the original, renamed program.--  - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders)-    All the types have been swizzled back to use the original Names-    See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon---}- {- ********************************************************************* *                                                                      *           ExpType: an "expected type" in the type checker@@ -469,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@.@@ -480,40 +424,106 @@          -- @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+-- | Like 'ExpType', but on kind level+type ExpKind = ExpType  instance Outputable ExpType where   ppr (Check ty) = text "Check" <> braces (ppr ty)   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 mkCheckExpType = Check +-- | Returns the expected type when in checking mode.+checkingExpType_maybe :: ExpType -> Maybe TcType+checkingExpType_maybe (Check ty) = Just ty+checkingExpType_maybe (Infer {}) = Nothing +-- | Returns the expected type when in checking mode.+--   Panics if in inference mode.+checkingExpType :: ExpType -> TcType+checkingExpType (Check ty)    = ty+checkingExpType et@(Infer {}) = pprPanic "checkingExpType" (ppr et)++-- Expected type of a pattern in a lambda or a function left-hand side.+data ExpPatType =+    ExpFunPatTy    (Scaled ExpSigmaTypeFRR)   -- the type A of a function A -> B+  | ExpForAllPatTy ForAllTyBinder             -- the binder (a::A) of  forall (a::A) -> B or forall (a :: A). B++mkCheckExpFunPatTy :: Scaled TcType -> ExpPatType+mkCheckExpFunPatTy (Scaled mult ty) = ExpFunPatTy (Scaled mult (mkCheckExpType ty))++mkInvisExpPatType :: InvisTyBinder -> ExpPatType+mkInvisExpPatType (Bndr tv spec) = ExpForAllPatTy (Bndr tv (Invisible spec))++isVisibleExpPatType :: ExpPatType -> Bool+isVisibleExpPatType (ExpForAllPatTy (Bndr _ vis)) = isVisibleForAllTyFlag vis+isVisibleExpPatType (ExpFunPatTy {})              = True++isExpFunPatType :: ExpPatType -> Bool+isExpFunPatType ExpFunPatTy{}    = True+isExpFunPatType ExpForAllPatTy{} = False++instance Outputable ExpPatType where+  ppr (ExpFunPatTy t) = ppr t+  ppr (ExpForAllPatTy tv) = text "forall" <+> ppr tv+ {- ********************************************************************* *                                                                      *           SyntaxOpType@@ -605,7 +615,7 @@ a bit awkward for the /producer/.  Why? Because sometimes we can't produce the SkolemInfo until we have the TcTyVars! -Example: in `GHC.Tc.Utils.Unify.tcTopSkolemise` we create SkolemTvs whose+Example: in `GHC.Tc.Utils.Unify.tcSkolemise` we create SkolemTvs whose `SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created SkolemTvs.  So we a RecrusiveDo idiom, like this: @@ -628,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@@ -637,7 +648,7 @@            , mtv_ref   :: IORef MetaDetails            , mtv_tclvl :: TcLevel }  -- See Note [TcLevel invariants] -vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails+vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False  instance Outputable TcTyVarDetails where@@ -657,7 +668,7 @@   | Indirect TcType  -- | What restrictions are on this metavariable around unification?--- These are checked in GHC.Tc.Utils.Unify.startSolvingByUnification.+-- These are checked in GHC.Tc.Utils.Unify.checkTopShape data MetaInfo    = TauTv         -- ^ This MetaTv is an ordinary unification variable                    -- A TauTv is always filled in with a tau-type, which@@ -670,9 +681,9 @@    | 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.Canonical+                     -- GHC.Tc.Solver.Equality     | ConcreteTv ConcreteTvOrigin         -- ^ A unification variable that can only be unified@@ -701,15 +712,26 @@    -- See 'FixedRuntimeRepOrigin' for more information.   = ConcreteFRR FixedRuntimeRepOrigin +-- | A mapping from skolem type variable 'Name' to concreteness information,+--+-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.+type ConcreteTyVars = NameEnv ConcreteTvOrigin+-- | The 'Id' has no outer forall'd type variables which must be instantiated+-- to concrete types.+noConcreteTyVars :: ConcreteTyVars+noConcreteTyVars = emptyNameEnv+ {- ********************************************************************* *                                                                      *                 Untouchable type variables *                                                                      * ********************************************************************* -} -newtype TcLevel = TcLevel Int deriving( Eq, Ord )+data TcLevel = TcLevel {-# UNPACK #-} !Int+             | QLInstVar   -- See Note [TcLevel invariants] for what this Int is   -- See also Note [TcLevel assignment]+  -- See also Note [The QLInstVar TcLevel]  {- Note [TcLevel invariants]@@ -719,6 +741,9 @@   and each Implication   has a level number (of type TcLevel) +* INVARIANT (KindInv) Given a type variable (tv::ki) at at level L,+                      the free vars of `ki` all have level <= L+ * INVARIANTS.  In a tree of Implications,      (ImplicInv) The level number (ic_tclvl) of an Implication is@@ -741,15 +766,36 @@ The level of a MetaTyVar also governs its untouchability.  See Note [Unification preconditions] in GHC.Tc.Utils.Unify. +  -- See also Note [The QLInstVar TcLevel]+ Note [TcLevel assignment] ~~~~~~~~~~~~~~~~~~~~~~~~~ We arrange the TcLevels like this -   0   Top level-   1   First-level implication constraints-   2   Second-level implication constraints+   0          Top level+   1          First-level implication constraints+   2          Second-level implication constraints    ...etc...+   QLInstVar  The level for QuickLook instantiation variables+              See Note [The QLInstVar TcLevel] +Note [The QLInstVar TcLevel]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+QuickLook instantiation variables are identified by having a TcLevel+of QLInstVar.  See Note [Quick Look overview] in GHC.Tc.Gen.App.++The QLInstVar level behaves like infinity: it is greater than any+other TcLevel.  See `strictlyDeeperThan` and friends in this module.+That ensures that we never unify an ordinary unification variable+with a QL instantiation variable, e.g.+      alpha[tau:3] := Maybe beta[tau:qlinstvar]+(This is an immediate consequence of our general rule that we never+unify a variable with a type mentioning deeper variables; the skolem+escape check.)++QL instantation variables are eventually turned into ordinary unificaiton+variables; see (QL3) in Note [Quick Look overview].+ Note [GivenInv] ~~~~~~~~~~~~~~~ Invariant (GivenInv) is not essential, but it is easy to guarantee, and@@ -799,37 +845,58 @@ -}  maxTcLevel :: TcLevel -> TcLevel -> TcLevel-maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b)+maxTcLevel (TcLevel a) (TcLevel b)+  | a > b      = TcLevel a+  | otherwise  = TcLevel b+maxTcLevel _ _ = QLInstVar +minTcLevel :: TcLevel -> TcLevel -> TcLevel+minTcLevel tcla@(TcLevel a) tclb@(TcLevel b)+  | a < b                              = tcla+  | otherwise                          = tclb+minTcLevel tcla@(TcLevel {}) QLInstVar = tcla+minTcLevel QLInstVar tclb@(TcLevel {}) = tclb+minTcLevel QLInstVar QLInstVar         = QLInstVar+ topTcLevel :: TcLevel -- See Note [TcLevel assignment] topTcLevel = TcLevel 0   -- 0 = outermost level  isTopTcLevel :: TcLevel -> Bool isTopTcLevel (TcLevel 0) = True-isTopTcLevel _           = False+isTopTcLevel _            = False  pushTcLevel :: TcLevel -> TcLevel -- See Note [TcLevel assignment] pushTcLevel (TcLevel us) = TcLevel (us + 1)+pushTcLevel QLInstVar    = QLInstVar  strictlyDeeperThan :: TcLevel -> TcLevel -> Bool+-- See Note [The QLInstVar TcLevel] strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)   = tv_tclvl > ctxt_tclvl+strictlyDeeperThan QLInstVar (TcLevel {})  = True+strictlyDeeperThan _ _                     = False  deeperThanOrSame :: TcLevel -> TcLevel -> Bool+-- See Note [The QLInstVar TcLevel] deeperThanOrSame (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)   = tv_tclvl >= ctxt_tclvl+deeperThanOrSame (TcLevel {}) QLInstVar  = False+deeperThanOrSame QLInstVar    _           = True  sameDepthAs :: TcLevel -> TcLevel -> Bool sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)-  = ctxt_tclvl == tv_tclvl   -- NB: invariant ctxt_tclvl >= tv_tclvl-                             --     So <= would be equivalent+  = ctxt_tclvl == tv_tclvl+    -- NB: invariant ctxt_tclvl >= tv_tclvl+    --     So <= would be equivalent+sameDepthAs QLInstVar QLInstVar = True+sameDepthAs _         _         = False  checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool -- Checks (WantedInv) from Note [TcLevel invariants]-checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)-  = ctxt_tclvl >= tv_tclvl+checkTcLevelInvariant ctxt_tclvl tv_tclvl+  = ctxt_tclvl `deeperThanOrSame` tv_tclvl  -- Returns topTcLevel for non-TcTyVars tcTyVarLevel :: TcTyVar -> TcLevel@@ -852,7 +919,8 @@       | otherwise = lvl  instance Outputable TcLevel where-  ppr (TcLevel us) = ppr us+  ppr (TcLevel n) = ppr n+  ppr QLInstVar   = text "qlinst"  {- ********************************************************************* *                                                                      *@@ -903,7 +971,8 @@ -- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a -- /visible/ argument to @C@. ----- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".+-- See also Note [Showing invisible bits of types in error messages]+-- in "GHC.Tc.Errors.Ppr". tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] tcTyFamInstsAndVis = tcTyFamInstsAndVisX False @@ -959,10 +1028,11 @@ -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts +type UnderFam = Bool   -- True <=> we are in the argument of a type family application+ any_rewritable :: EqRel   -- Ambient role-               -> (EqRel -> TcTyVar -> Bool)           -- check tyvar-               -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family-               -> (TyCon -> Bool)                      -- expand type synonym?+               -> (UnderFam -> EqRel -> TcTyVar -> Bool)           -- Check tyvar+               -> (UnderFam -> EqRel -> TyCon -> [TcType] -> Bool) -- Check type family application                -> TcType -> Bool -- Checks every tyvar and tyconapp (not including FunTys) within a type, -- ORing the results of the predicates above together@@ -975,66 +1045,79 @@ -- -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. {-# INLINE any_rewritable #-} -- this allows specialization of predicates-any_rewritable role tv_pred tc_pred should_expand-  = go role emptyVarSet+any_rewritable role tv_pred tc_pred ty+  = go False emptyVarSet role ty   where-    go_tv rl bvs tv | tv `elemVarSet` bvs = False-                    | otherwise           = tv_pred rl tv+    go_tv uf bvs rl tv | tv `elemVarSet` bvs = False+                       | otherwise           = tv_pred uf rl tv -    go rl bvs ty@(TyConApp tc tys)+    go :: UnderFam -> VarSet -> EqRel -> TcType -> Bool+    go under_fam bvs rl (TyConApp tc tys)++      -- Expand synonyms, unless (a) we are at Nominal role and (b) the synonym+      -- is type-family-free; then it suffices just to look at the args       | isTypeSynonymTyCon tc-      , should_expand tc-      , Just ty' <- coreView ty   -- should always match-      = go rl bvs ty'+      , case rl of { NomEq -> not (isFamFreeTyCon tc); ReprEq -> True }+      , Just ty' <- expandSynTyConApp_maybe tc tys+      = go under_fam bvs rl ty' -      | tc_pred rl tc tys-      = True+      -- Check if we are going under a type family application+      | case rl of+           NomEq  -> isTypeFamilyTyCon tc+           ReprEq -> isFamilyTyCon     tc+      = if | tc_pred under_fam rl tc tys -> True+           | otherwise                   -> go_fam under_fam (tyConArity tc) bvs tys        | otherwise-      = go_tc rl bvs tc tys+      = go_tc under_fam bvs rl tc tys -    go rl bvs (TyVarTy tv)       = go_tv rl bvs tv-    go _ _     (LitTy {})        = False-    go rl bvs (AppTy fun arg)    = go rl bvs fun || go NomEq bvs arg-    go rl bvs (FunTy _ w arg res)  = go NomEq bvs arg_rep || go NomEq bvs res_rep ||-                                     go rl bvs arg || go rl bvs res || go NomEq bvs w+    go uf bvs rl (TyVarTy tv)        = go_tv uf bvs rl tv+    go _  _    _ (LitTy {})          = False+    go uf bvs rl (AppTy fun arg)     = go uf bvs rl fun || go uf bvs NomEq arg+    go uf bvs rl (FunTy _ w arg res) = go uf bvs NomEq arg_rep || go uf bvs NomEq res_rep ||+                                       go uf bvs rl arg || go uf bvs rl res || go uf bvs NomEq w       where arg_rep = getRuntimeRep arg -- forgetting these causes #17024             res_rep = getRuntimeRep res-    go rl bvs (ForAllTy tv ty)   = go rl (bvs `extendVarSet` binderVar tv) ty-    go rl bvs (CastTy ty _)      = go rl bvs ty-    go _  _   (CoercionTy _)     = False+    go uf bvs rl (ForAllTy tv ty)   = go uf (bvs `extendVarSet` binderVar tv) rl ty+    go uf bvs rl (CastTy ty _)      = go uf bvs rl ty+    go _  _   _  (CoercionTy _)     = False -    go_tc NomEq  bvs _  tys = any (go NomEq bvs) tys-    go_tc ReprEq bvs tc tys = any (go_arg bvs)-                              (tyConRoleListRepresentational tc `zip` tys)+    go_tc :: UnderFam -> VarSet -> EqRel -> TyCon -> [TcType] -> Bool+    go_tc uf bvs NomEq  _  tys = any (go uf bvs NomEq) tys+    go_tc uf bvs ReprEq tc tys = any2 (go_arg uf bvs) tys (tyConRoleListRepresentational tc) -    go_arg bvs (Nominal,          ty) = go NomEq  bvs ty-    go_arg bvs (Representational, ty) = go ReprEq bvs ty-    go_arg _   (Phantom,          _)  = False  -- We never rewrite with phantoms+    go_arg uf bvs ty Nominal          = go uf bvs NomEq ty+    go_arg uf bvs ty Representational = go uf bvs ReprEq ty+    go_arg _   _  _  Phantom          = False  -- We never rewrite with phantoms +    -- For a type-family or data-family application (F t1 .. tn), all arguments+    --   have Nominal role (whether in F's arity or, if over-saturated, beyond it)+    -- Switch on under_fam for arguments <= arity+    go_fam uf 0 bvs tys      = any (go uf bvs NomEq) tys   -- Like AppTy+    go_fam _  _ _   []       = False+    go_fam uf n bvs (ty:tys) = go True bvs NomEq ty || go_fam uf (n-1) bvs tys+                               -- True <=> switch on under_fam+ anyRewritableTyVar :: EqRel    -- Ambient role-                   -> (EqRel -> TcTyVar -> Bool)  -- check tyvar+                   -> (UnderFam -> EqRel -> TcTyVar -> Bool)  -- check tyvar                    -> TcType -> Bool -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function.-anyRewritableTyVar role pred-  = any_rewritable role pred-      (\ _ _ _ -> False) -- no special check for tyconapps-                         -- (this False is ORed with other results, so it-                         --  really means "do nothing special"; the arguments-                         --   are still inspected)-      (\ _ -> False)     -- don't expand synonyms-    -- NB: No need to expand synonyms, because we can find-    -- all free variables of a synonym by looking at its-    -- arguments+anyRewritableTyVar role check_tv+  = any_rewritable role+      check_tv+      (\ _ _ _ _ -> False) -- No special check for tyconapps+                           -- (this False is ORed with other results,+                           --  so it really means "do nothing special";+                           --  the arguments are still inspected)  anyRewritableTyFamApp :: EqRel   -- Ambient role-                      -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp-                          -- should return True only for type family applications+                      -> (UnderFam -> EqRel -> TyCon -> [TcType] -> Bool)+                         -- Check a type-family application                       -> TcType -> Bool   -- always ignores casts & coercions -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableTyFamApp role check_tyconapp-  = any_rewritable role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon)+  = any_rewritable role (\ _ _ _ -> False) check_tyconapp  {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1183,6 +1266,18 @@         _             -> False   | otherwise = False +isQLInstTyVar :: TcTyVar -> Bool+isQLInstTyVar tv+  = case tcTyVarDetails tv of+      MetaTv { mtv_tclvl = QLInstVar } -> True+      _                                -> False++isRuntimeUnkTyVar :: TcTyVar -> Bool+isRuntimeUnkTyVar tv+  = case tcTyVarDetails tv of+      MetaTv { mtv_info = RuntimeUnkTv } -> True+      _                                  -> False+ isCycleBreakerTyVar tv   | isTyVar tv -- See Note [Coercion variables in free variable lists]   , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv@@ -1204,6 +1299,10 @@   | otherwise   = Nothing +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'? isConcreteTyVar :: TcTyVar -> Bool@@ -1373,7 +1472,7 @@ -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([PiTyVarBinder], Type) tcSplitPiTys ty-  = assert (all isTyBinder (fst sty) )   -- No CoVar binders here+  = assert (all isTyBinder (fst sty))   -- No CoVar binders here     sty   where sty = splitPiTys ty @@ -1396,7 +1495,7 @@ -- returning just the tyvars. tcSplitForAllTyVars :: Type -> ([TyVar], Type) tcSplitForAllTyVars ty-  = assert (all isTyVar (fst sty) ) sty+  = assert (all isTyVar (fst sty)) sty   where sty = splitForAllTyCoVars ty  -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible'@@ -1417,6 +1516,20 @@     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs     split orig_ty _                            tvs = (reverse tvs, orig_ty) +tcSplitForAllTyVarsReqTVBindersN :: Arity -> Type -> (Arity, [ForAllTyBinder], Type)+-- Split off at most N /required/ (aka visible) binders, plus any invisible ones+-- in the way, /and/ any trailing invisible ones+tcSplitForAllTyVarsReqTVBindersN n_req ty+  = split n_req ty ty []+  where+    split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs+      | isVisibleForAllTyFlag argf, n_req > 0  -- Split off a visible forall+      = split (n_req - 1) ty ty (b:bs)+      | isInvisibleForAllTyFlag argf           -- Split off an invisible forall,+      = split n_req       ty ty (b:bs)         -- even if n_req=0, i.e. the trailing ones+    split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs+    split n_req orig_ty _ty bs                          = (n_req, reverse bs, orig_ty)+ -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)@@ -1461,6 +1574,11 @@                         (tvs, rho) -> case tcSplitPhiTy rho of                                         (theta, tau) -> (tvs, theta, tau) +tcSplitSigmaTyBndrs :: Type -> ([TcInvisTVBinder], ThetaType, Type)+tcSplitSigmaTyBndrs ty = case tcSplitForAllInvisTVBinders ty of+                        (tvs, rho) -> case tcSplitPhiTy rho of+                                        (theta, tau) -> (tvs, theta, tau)+ -- | Split a sigma type into its parts, going underneath as many arrows -- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)@@ -1568,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)@@ -1699,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.  ---------------------------@@ -1733,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@@ -1790,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]@@ -1850,7 +1968,7 @@ Notice that in the recursive-superclass case we include C again at the end of the chain.  One could exclude C in this case, but the code is more awkward and there seems no good reason to do so.-(However C.f. GHC.Tc.Solver.Canonical.mk_strict_superclasses, which /does/+(However C.f. GHC.Tc.Solver.Dict.mk_strict_superclasses, which /does/ appear to do so.)  The algorithm is expand( so_far, pred ):@@ -1888,19 +2006,20 @@ -}  isSigmaTy :: TcType -> Bool--- isSigmaTy returns true of any qualified type.  It doesn't--- *necessarily* have any foralls.  E.g---        f :: (?x::Int) => Int -> Int-isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty'-isSigmaTy (ForAllTy {})                = True+-- isSigmaTy returns true of any type with /invisible/ quantifiers at the top:+--     forall a. blah+--     Eq a => blah+--     ?x::Int => blah+-- But NOT+--     forall a -> blah+isSigmaTy (ForAllTy (Bndr _ af) _)     = isInvisibleForAllTyFlag af isSigmaTy (FunTy { ft_af = af })       = isInvisibleFunArg af+isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' isSigmaTy _                            = False + isRhoTy :: TcType -> Bool   -- True of TcRhoTypes; see Note [TcRhoType]-isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty'-isRhoTy (ForAllTy {})                = False-isRhoTy (FunTy { ft_af = af })       = isVisibleFunArg af-isRhoTy _                            = True+isRhoTy ty = not (isSigmaTy ty)  -- | Like 'isRhoTy', but also says 'True' for 'Infer' types isRhoExpTy :: ExpType -> Bool@@ -1909,7 +2028,7 @@  isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing--- Used only by bindLocalMethods+-- Used by bindLocalMethods and for -fprof-late-overloaded isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _  ty)             = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af })       = isInvisibleFunArg af@@ -1919,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@@ -1930,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@,@@ -1970,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  {-@@ -2037,8 +2159,8 @@ -}  tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)--- (tcSplitIOType_maybe t) returns Just (IO,t',co)---              if co : t ~ IO t'+-- (tcSplitIOType_maybe t) returns Just (IO,t')+--              if t = IO t' --              returns Nothing otherwise tcSplitIOType_maybe ty   = case tcSplitTyConApp_maybe ty of@@ -2048,251 +2170,8 @@         _ ->             Nothing --- | Reason why a type in an FFI signature is invalid-data IllegalForeignTypeReason-  = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason-  | ForeignDynNotPtr-      !Type -- ^ Expected type-      !Type -- ^ Actual type-  | SafeHaskellMustBeInIO-  | IOResultExpected-  | UnexpectedNestedForall-  | LinearTypesNotAllowed-  | OneArgExpected-  | AtLeastOneArgExpected-  deriving Generic --- | Reason why a type cannot be marshalled through the FFI.-data TypeCannotBeMarshaledReason-  = NotADataType-  | NewtypeDataConNotInScope !(Maybe TyCon)-  | UnliftedFFITypesNeeded-  | NotABoxedMarshalableTyCon-  | ForeignLabelNotAPtr-  | NotSimpleUnliftedType-  | NotBoxedKindAny-  deriving Generic--isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason--- Checks for valid argument type for a 'foreign import'-isFFIArgumentTy dflags safety ty-   = checkRepTyCon (legalOutgoingTyCon dflags safety) ty--isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason--- Types that are allowed as arguments of a 'foreign export'-isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty--isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason-isFFIImportResultTy dflags ty-  = checkRepTyCon (legalFIResultTyCon dflags) ty--isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason-isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty--isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason--- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of--- either, and the wrapped function type must be equal to the given type.--- We assume that all types have been run through normaliseFfiType, so we don't--- need to worry about expanding newtypes here.-isFFIDynTy expected ty-    -- Note [Foreign import dynamic]-    -- In the example below, expected would be 'CInt -> IO ()', while ty would-    -- be 'FunPtr (CDouble -> IO ())'.-    | Just (tc, [ty']) <- splitTyConApp_maybe ty-    , anyOfUnique tc [ptrTyConKey, funPtrTyConKey]-    , eqType ty' expected-    = IsValid-    | otherwise-    = NotValid (ForeignDynNotPtr expected ty)--isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason--- The type of a foreign label must be Ptr, FunPtr, or a newtype of either.-isFFILabelTy ty = checkRepTyCon ok ty-  where-    ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey-          = IsValid-          | otherwise-          = NotValid ForeignLabelNotAPtr---- | Check validity for a type of the form @Any :: k@.------ This function returns:------  - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@,---  - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types,---  - @Nothing@ if the type is not @Any@.-checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)-checkAnyTy ty-  | Just ki <- anyTy_maybe ty-  = Just $-      if isJust $ kindBoxedRepLevity_maybe ki-      then IsValid-      -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305.-      else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny)-  | otherwise-  = Nothing--isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason--- Checks for valid argument type for a 'foreign import prim'--- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType),--- which can be used to pass the address to a Haskell object on the heap to--- the foreign function.-isFFIPrimArgumentTy dflags ty-  | Just validity <- checkAnyTy ty-  = validity-  | otherwise-  = checkRepTyCon (legalFIPrimArgTyCon dflags) ty--isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason--- Checks for valid result type for a 'foreign import prim' Currently--- it must be an unlifted type, including unboxed tuples, unboxed--- sums, or the well-known type Any (at kind Type or UnliftedType).-isFFIPrimResultTy dflags ty-  | Just validity <- checkAnyTy ty-  = validity-  | otherwise-  = checkRepTyCon (legalFIPrimResultTyCon dflags) ty--isFunPtrTy :: Type -> Bool-isFunPtrTy ty-  | Just (tc, [_]) <- splitTyConApp_maybe ty-  = tc `hasKey` funPtrTyConKey-  | otherwise-  = False---- normaliseFfiType gets run before checkRepTyCon, so we don't--- need to worry about looking through newtypes or type functions--- here; that's already been taken care of.-checkRepTyCon-  :: (TyCon -> Validity' TypeCannotBeMarshaledReason)-  -> Type-  -> Validity' IllegalForeignTypeReason-checkRepTyCon check_tc ty-  = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of-      Just (tc, tys)-        | isNewTyCon tc -> NotValid (mk_nt_reason tc tys)-        | otherwise     -> check_tc tc-      Nothing -> NotValid NotADataType-  where-    mk_nt_reason tc tys-      | null tys  = NewtypeDataConNotInScope Nothing-      | otherwise = NewtypeDataConNotInScope (Just tc)- {--Note [Foreign import dynamic]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign-type.  Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.--We use isFFIDynTy to check whether a signature is well-formed. For example,-given a (illegal) declaration like:--foreign import ccall "dynamic"-  foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()--isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried-result type 'CInt -> IO ()', and return False, as they are not equal.--------------------------------------------------These chaps do the work; they are not exported-------------------------------------------------}--legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason-legalFEArgTyCon tc-  -- It's illegal to make foreign exports that take unboxed-  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000-  = boxedMarshalableTyCon tc--legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason-legalFIResultTyCon dflags tc-  | tc == unitTyCon         = IsValid-  | otherwise               = marshalableTyCon dflags tc--legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason-legalFEResultTyCon tc-  | tc == unitTyCon         = IsValid-  | otherwise               = boxedMarshalableTyCon tc--legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason--- Checks validity of types going from Haskell -> external world-legalOutgoingTyCon dflags _ tc-  = marshalableTyCon dflags tc---- Check for marshalability of a primitive type.--- We exclude lifted types such as RealWorld and TYPE.--- They can technically appear in types, e.g.--- f :: RealWorld -> TYPE LiftedRep -> RealWorld--- f x _ = x--- but there are no values of type RealWorld or TYPE LiftedRep,--- so it doesn't make sense to use them in FFI.-marshalablePrimTyCon :: TyCon -> Bool-marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc))--marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason-marshalableTyCon dflags tc-  | marshalablePrimTyCon tc-  , not (null (tyConPrimRep tc)) -- Note [Marshalling void]-  = validIfUnliftedFFITypes dflags-  | otherwise-  = boxedMarshalableTyCon tc--boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason-boxedMarshalableTyCon tc-   | anyOfUnique tc      [ intTyConKey, int8TyConKey, int16TyConKey-                         , int32TyConKey, int64TyConKey-                         , wordTyConKey, word8TyConKey, word16TyConKey-                         , word32TyConKey, word64TyConKey-                         , floatTyConKey, doubleTyConKey-                         , ptrTyConKey, funPtrTyConKey-                         , charTyConKey-                         , stablePtrTyConKey-                         , boolTyConKey-                         ]-  = IsValid--  | otherwise = NotValid NotABoxedMarshalableTyCon--legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason--- Check args of 'foreign import prim', only allow simple unlifted types.-legalFIPrimArgTyCon dflags tc-  | marshalablePrimTyCon tc-  = validIfUnliftedFFITypes dflags-  | otherwise-  = NotValid NotSimpleUnliftedType--legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason--- Check result type of 'foreign import prim'. Allow simple unlifted--- types and also unboxed tuple and sum result types.-legalFIPrimResultTyCon dflags tc-  | marshalablePrimTyCon tc-  , not (null (tyConPrimRep tc))   -- Note [Marshalling void]-  = validIfUnliftedFFITypes dflags--  | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc-  = validIfUnliftedFFITypes dflags--  | otherwise-  = NotValid $ NotSimpleUnliftedType--validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason-validIfUnliftedFFITypes dflags-  | xopt LangExt.UnliftedFFITypes dflags =  IsValid-  | otherwise = NotValid UnliftedFFITypesNeeded--{--Note [Marshalling void]-~~~~~~~~~~~~~~~~~~~~~~~-We don't treat State# (whose PrimRep is VoidRep) as marshalable.-In turn that means you can't write-        foreign import foo :: Int -> State# RealWorld--Reason: the back end falls over with panic "primRepHint:VoidRep";-        and there is no compelling reason to permit it--}--{- ************************************************************************ *                                                                      *         Visiblities@@ -2303,8 +2182,8 @@ -- | For every arg a tycon can take, the returned list says True if the argument -- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to -- allow for oversaturation.-tcTyConVisibilities :: TyCon -> [Bool]-tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True+tyConVisibilities :: TyCon -> [Bool]+tyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True   where     tc_binder_viss      = map isVisibleTyConBinder (tyConBinders tc)     tc_return_kind_viss = map isVisiblePiTyBinder (fst $ tcSplitPiTys (tyConResKind tc))@@ -2312,13 +2191,14 @@ -- | If the tycon is applied to the types, is the next argument visible? isNextTyConArgVisible :: TyCon -> [Type] -> Bool isNextTyConArgVisible tc tys-  = tcTyConVisibilities tc `getNth` length tys+  = tyConVisibilities tc `getNth` length tys  -- | Should this type be applied to a visible argument?+-- E.g. (s t): is `t` a visible argument of `s`? isNextArgVisible :: TcType -> Bool isNextArgVisible ty-  | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisiblePiTyBinder bndr-  | otherwise                              = True+  | Just (bndr, _) <- tcSplitPiTy_maybe (typeKind ty) = isVisiblePiTyBinder bndr+  | otherwise                                         = True     -- this second case might happen if, say, we have an unzonked TauTv.     -- But TauTvs can't range over types that take invisible arguments @@ -2387,18 +2267,29 @@ has a separate call to isStuckTypeFamily, so the `F` above will still be accepted. -} ---- | Why was the LHS 'PatersonSize' not strictly smaller than the RHS 'PatersonSize'?+-- | Why did the Paterson conditions fail; that is, why+-- was the context P not Paterson-smaller than the head H? -- -- See Note [Paterson conditions] in GHC.Tc.Validity.-data PatersonSizeFailure-  -- | Either side contains a type family.-  = PSF_TyFam TyCon-  -- | The size of the LHS is not strictly less than the size of the RHS.-  | PSF_Size-  -- | These type variables appear more often in the LHS than in the RHS.-  | PSF_TyVar [TyVar] -- ^  no duplicates in this list+data PatersonCondFailure+  -- | Some type variables occur more often in P than in H.+  -- See (PC1) in Note [Paterson conditions] in GHC.Tc.Validity.+  = PCF_TyVar+    [TyVar]  -- ^ the type variables which appear more often in the context+  -- | P is not smaller in size than H.+  -- See (PC2) in Note [Paterson conditions] in GHC.Tc.Validity.+  | PCF_Size+  -- | P contains a type family.+  -- See (PC3) in Note [Paterson conditions] in GHC.Tc.Validity.+  | PCF_TyFam+    TyCon  -- ^ the type constructor of the type family +-- | Indicates whether a Paterson condition failure occurred in an instance declaration or a type family equation.+-- Useful for differentiating context in error messages.+data PatersonCondFailureContext+  = InInstanceDecl+  | InTyFamEquation+ --------------------------------------  -- | The Paterson size of a given type, in the sense of@@ -2409,7 +2300,6 @@ data PatersonSize   -- | The type mentions a type family, so the size could be anything.   = PS_TyFam TyCon-   -- | The type does not mention a type family.   | PS_Vanilla { ps_tvs :: [TyVar]  -- ^ free tyvars, including repetitions;                , ps_size :: Int     -- ^ number of type constructors and variables@@ -2432,14 +2322,14 @@ --  - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong. ltPatersonSize :: PatersonSize                -> PatersonSize-               -> Maybe PatersonSizeFailure+               -> Maybe PatersonCondFailure ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 })                (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 })-  | s1 >= s2                                = Just PSF_Size-  | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PSF_TyVar bad_tvs)+  | s1 >= s2                                = Just PCF_Size+  | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PCF_TyVar bad_tvs)   | otherwise                               = Nothing -- OK!-ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc)-ltPatersonSize _ (PS_TyFam tc) = Just (PSF_TyFam tc)+ltPatersonSize (PS_TyFam tc) _ = Just (PCF_TyFam tc)+ltPatersonSize _ (PS_TyFam tc) = Just (PCF_TyFam tc)   -- NB: this last equation is never taken when checking instances, because   -- type families are disallowed in instance heads.   --@@ -2507,6 +2397,13 @@  | 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 @@ -2533,11 +2430,11 @@   = isIPClass cls    -- Implicit parameter constraints always terminate because                      -- there are no instances for them --- they are only solved                      -- by "local instances" in expressions-    || isEqPredClass cls+    || isEqualityClass cls     || cls `hasKey` typeableClassKey             -- Typeable constraints are bigger than they appear due             -- to kind polymorphism, but we can never get instance divergence this way-    || cls `hasKey` coercibleTyConKey+    || cls `hasKey` unsatisfiableClassNameKey  allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool -- (allDistinctTyVars tvs tys) returns True if tys are
compiler/GHC/Tc/Utils/TcType.hs-boot view
@@ -1,15 +1,22 @@ module GHC.Tc.Utils.TcType where import GHC.Utils.Outputable( SDoc )+import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )-import GHC.Stack+import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin )+import GHC.Types.Name.Env ( NameEnv )  data MetaDetails  data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc-vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails+vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool-isConcreteTyVar :: TcTyVar -> Bool +type ConcreteTyVars = NameEnv ConcreteTvOrigin+data ConcreteTvOrigin+  = ConcreteFRR FixedRuntimeRepOrigin++isConcreteTyVar :: TcTyVar -> Bool+noConcreteTyVars :: ConcreteTyVars
+ compiler/GHC/Tc/Zonk/Monad.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++-- | The 'ZonkM' monad, a stripped down 'TcM', used when zonking within+-- the typechecker in "GHC.Tc.Zonk.TcType".+--+-- See Note [Module structure for zonking] in GHC.Tc.Zonk.Type.+module GHC.Tc.Zonk.Monad+  ( -- * The 'ZonkM' monad, a stripped down 'TcM' for zonking+    ZonkM(ZonkM,runZonkM)+  , ZonkGblEnv(..), getZonkGblEnv, getZonkTcLevel++   -- ** Logging within 'ZonkM'+  , traceZonk++  )+  where++import GHC.Prelude++import GHC.Driver.Flags ( DumpFlag(Opt_D_dump_tc_trace) )++import GHC.Types.SrcLoc ( SrcSpan )++import GHC.Tc.Types.BasicTypes ( TcBinderStack )+import GHC.Tc.Utils.TcType   ( TcLevel )++import GHC.Utils.Logger+import GHC.Utils.Outputable++import Control.Monad          ( when )+import Control.Monad.IO.Class ( MonadIO(..) )++import GHC.Exts               ( oneShot )++--------------------------------------------------------------------------------++-- | Information needed by the 'ZonkM' monad, which is a slimmed down version+-- of 'TcM' with just enough information for zonking.+data ZonkGblEnv+  = ZonkGblEnv+    { zge_logger       :: Logger     -- needed for traceZonk+    , zge_name_ppr_ctx :: NamePprCtx --          ''+    , zge_src_span     :: SrcSpan  -- needed for skolemiseUnboundMetaTyVar+    , zge_tc_level     :: TcLevel  --               ''+    , zge_binder_stack :: TcBinderStack -- needed for tcInitTidyEnv+    }++-- | A stripped down version of 'TcM' which is sufficient for zonking types.+newtype ZonkM a = ZonkM' { runZonkM :: ZonkGblEnv -> IO a }+{-+NB: we write the following instances by hand:++--  deriving (Functor, Applicative, Monad, MonadIO)+--    via ReaderT ZonkGblEnv IO++See Note [Instances for ZonkT] in GHC.Tc.Zonk.Env for the reasoning:++  - oneShot annotations,+  - strictness annotations to enable worker-wrapper.+-}++{-# COMPLETE ZonkM #-}+pattern ZonkM :: forall a. (ZonkGblEnv -> IO a) -> ZonkM a+pattern ZonkM m <- ZonkM' m+  where+    ZonkM m = ZonkM' (oneShot m)+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad++instance Functor ZonkM where+  fmap f (ZonkM g) = ZonkM $ \ !env -> fmap f (g env)+  a <$ ZonkM g     = ZonkM $ \ !env -> a <$ g env+  {-# INLINE fmap #-}+  {-# INLINE (<$) #-}+instance Applicative ZonkM where+  pure a = ZonkM (\ !_ -> pure a)+  ZonkM f <*> ZonkM x = ZonkM (\ !env -> f env <*> x env )+  ZonkM m *> f = ZonkM (\ !env -> m env *> runZonkM f env)+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+  {-# INLINE (*>) #-}++instance Monad ZonkM where+  ZonkM m >>= f =+    ZonkM (\ !env -> do { r <- m env+                        ; runZonkM (f r) env })+  (>>)   = (*>)+  {-# INLINE (>>=) #-}+  {-# INLINE (>>) #-}++instance MonadIO ZonkM where+  liftIO f = ZonkM (\ !_ -> f)+  {-# INLINE liftIO #-}++getZonkGblEnv :: ZonkM ZonkGblEnv+getZonkGblEnv = ZonkM return+{-# INLINE getZonkGblEnv #-}++getZonkTcLevel :: ZonkM TcLevel+getZonkTcLevel = ZonkM (\env -> return (zge_tc_level env))++-- | Same as 'traceTc', but for the 'ZonkM' monad.+traceZonk :: String -> SDoc -> ZonkM ()+traceZonk herald doc = ZonkM $+  \ ( ZonkGblEnv { zge_logger = !logger, zge_name_ppr_ctx = ppr_ctx }) ->+    do { let sty   = mkDumpStyle ppr_ctx+             flag  = Opt_D_dump_tc_trace+             title = ""+             msg   = hang (text herald) 2 doc+       ; when (logHasDumpFlag logger flag) $+         logDumpFile logger sty flag title FormatText msg+       }+{-# INLINE traceZonk #-}+  -- see Note [INLINE conditional tracing utilities] in GHC.Tc.Utils.Monad
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
@@ -1,5 +1,7 @@  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-} -- -- (c) The University of Glasgow --@@ -7,33 +9,21 @@ module GHC.Types.Avail (     Avails,     AvailInfo(..),-    avail,-    availField,-    availTC,     availsToNameSet,-    availsToNameSetWithSelectors,     availsToNameEnv,     availExportsDecl,-    availName, availGreName,-    availNames, availNonFldNames,-    availNamesWithSelectors,-    availFlds,-    availGreNames,-    availSubordinateGreNames,+    availName,+    availNames,+    availSubordinateNames,     stableAvailCmp,     plusAvail,     trimAvail,     filterAvail,     filterAvails,     nubAvails,--    GreName(..),-    greNameMangledName,-    greNamePrintableName,-    greNameSrcSpan,-    greNameFieldLabel,-    partitionGreNames,-    stableGreNameCmp,+    sortAvails,+    DetOrdAvails(DetOrdAvails, getDetOrdAvails, DefinitelyDeterministicAvails),+    emptyDetOrdAvails   ) where  import GHC.Prelude@@ -41,9 +31,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Types.SrcLoc -import GHC.Types.FieldLabel import GHC.Utils.Binary import GHC.Data.List.SetOps import GHC.Utils.Outputable@@ -52,10 +40,8 @@  import Control.DeepSeq import Data.Data ( Data )-import Data.Either ( partitionEithers ) import Data.Functor.Classes ( liftCompare )-import Data.List ( find )-import Data.Maybe+import Data.List ( find, sortBy ) import qualified Data.Semigroup as S  -- -----------------------------------------------------------------------------@@ -66,7 +52,7 @@    -- | An ordinary identifier in scope, or a field label without a parent type   -- (see Note [Representing pattern synonym fields in AvailInfo]).-  = Avail GreName+  = Avail Name    -- | A type or class in scope   --@@ -75,74 +61,49 @@   --   -- > AvailTC Eq [Eq, ==, \/=]   | AvailTC-       Name         -- ^ The name of the type or class-       [GreName]      -- ^ The available pieces of type or class-                    -- (see Note [Representing fields in AvailInfo]).+       Name      -- ^ The name of the type or class+       [Name]    -- ^ The available pieces of type or class -   deriving ( Eq    -- ^ Used when deciding if the interface has changed-            , Data )+   deriving Data  -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] -{--Note [Representing fields in AvailInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [FieldLabel] in GHC.Types.FieldLabel.--When -XDuplicateRecordFields is disabled (the normal case), a-datatype like--  data T = MkT { foo :: Int }--gives rise to the AvailInfo--  AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo]--whereas if -XDuplicateRecordFields is enabled it gives--  AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT]--where the label foo does not match the selector name $sel:foo:MkT.--The labels in a field list are not necessarily unique:-data families allow the same parent (the family tycon) to have-multiple distinct fields with the same label. For example,--  data family F a-  data instance F Int  = MkFInt { foo :: Int }-  data instance F Bool = MkFBool { foo :: Bool}--gives rise to--  AvailTC F [ F, MkFInt, MkFBool-            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt-            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ]--Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags-need not be the same for all the elements of the list.  In the example above,-this occurs if the two data instances are defined in different modules, with-different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors`-extensions.  Thus it is possible to have--  AvailTC F [ F, MkFInt, MkFBool-            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt-            , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ]+-- | Occurrences of Avails in interface files must be deterministically ordered+-- to guarantee interface file determinism.+--+-- 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 { getDetOrdAvails :: Avails }+  deriving newtype (Binary, Outputable, NFData) -If the two data instances are defined in different modules, both without-`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to-export them from the same module (even with `-XDuplicateRecordfields` enabled),-because they would be represented identically.  The workaround here is to enable-`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules.  See-also #13352.+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+{-# COMPLETE DetOrdAvails #-} -Note [Representing pattern synonym fields in AvailInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Representing pattern synonym fields in AvailInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record pattern synonym fields cannot be represented using AvailTC like fields of-normal record types (see Note [Representing fields in AvailInfo]), because they-do not always have a parent type constructor.  So we represent them using the-Avail constructor, with a NormalGreName that carries the underlying FieldLabel.+normal record types, because they do not always have a parent type constructor.+So we represent them using the Avail constructor.  Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration @@ -150,43 +111,22 @@  gives rise to the AvailInfo -  Avail (NormalGreName MkFoo)-  Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo))+  Avail MkFoo, Avail f  However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in an export list, then whenever `f` is imported the parent will be `T`, represented as -  AvailTC T [ NormalGreName T-            , NormalGreName MkFoo-            , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ]--See also Note [GreNames] in GHC.Types.Name.Reader.+  AvailTC T [ T, MkFoo, f ] -}  -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering-stableAvailCmp (Avail c1)     (Avail c2)     = c1 `stableGreNameCmp` c2+stableAvailCmp (Avail c1)     (Avail c2)     = c1 `stableNameCmp` c2 stableAvailCmp (Avail {})     (AvailTC {})   = LT-stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms+stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableNameCmp ns ms stableAvailCmp (AvailTC {})   (Avail {})     = GT -stableGreNameCmp :: GreName -> GreName -> Ordering-stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2-stableGreNameCmp (NormalGreName {}) (FieldGreName  {}) = LT-stableGreNameCmp (FieldGreName  f1) (FieldGreName  f2) = flSelector f1 `stableNameCmp` flSelector f2-stableGreNameCmp (FieldGreName  {}) (NormalGreName {}) = GT--avail :: Name -> AvailInfo-avail n = Avail (NormalGreName n)--availField :: FieldLabel -> AvailInfo-availField fl = Avail (FieldGreName fl)--availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo-availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls)-- -- ----------------------------------------------------------------------------- -- Operations on AvailInfo @@ -194,10 +134,6 @@ availsToNameSet avails = foldr add emptyNameSet avails       where add avail set = extendNameSetList set (availNames avail) -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet-availsToNameSetWithSelectors avails = foldr add emptyNameSet avails-      where add avail set = extendNameSetList set (availNamesWithSelectors avail)- availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo availsToNameEnv avails = foldr add emptyNameEnv avails      where add avail env = extendNameEnvList env@@ -207,109 +143,42 @@ -- invariant that the parent is first if it appears at all. availExportsDecl :: AvailInfo -> Bool availExportsDecl (AvailTC ty_name names)-  | n : _ <- names = NormalGreName ty_name == n+  | n : _ <- names = ty_name == n   | otherwise      = False availExportsDecl _ = True  -- | Just the main name made available, i.e. not the available pieces -- of type or class brought into scope by the 'AvailInfo' availName :: AvailInfo -> Name-availName (Avail n)     = greNameMangledName n+availName (Avail   n)   = n availName (AvailTC n _) = n -availGreName :: AvailInfo -> GreName-availGreName (Avail c) = c-availGreName (AvailTC n _) = NormalGreName n---- | All names made available by the availability information (excluding overloaded selectors)-availNames :: AvailInfo -> [Name]-availNames (Avail c) = childNonOverloadedNames c-availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs--childNonOverloadedNames :: GreName -> [Name]-childNonOverloadedNames (NormalGreName n) = [n]-childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ]---- | All names made available by the availability information (including overloaded selectors)-availNamesWithSelectors :: AvailInfo -> [Name]-availNamesWithSelectors (Avail c) = [greNameMangledName c]-availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs---- | Names for non-fields made available by the availability information-availNonFldNames :: AvailInfo -> [Name]-availNonFldNames (Avail (NormalGreName n)) = [n]-availNonFldNames (Avail (FieldGreName {})) = []-availNonFldNames (AvailTC _ ns) = mapMaybe f ns-  where-    f (NormalGreName n) = Just n-    f (FieldGreName {}) = Nothing---- | Fields made available by the availability information-availFlds :: AvailInfo -> [FieldLabel]-availFlds (Avail c) = maybeToList (greNameFieldLabel c)-availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs- -- | Names and fields made available by the availability information.-availGreNames :: AvailInfo -> [GreName]-availGreNames (Avail c)      = [c]-availGreNames (AvailTC _ cs) = cs+availNames :: AvailInfo -> [Name]+availNames (Avail c)      = [c]+availNames (AvailTC _ cs) = cs  -- | Names and fields made available by the availability information, other than -- the main decl itself.-availSubordinateGreNames :: AvailInfo -> [GreName]-availSubordinateGreNames (Avail {}) = []-availSubordinateGreNames avail@(AvailTC _ ns)+availSubordinateNames :: AvailInfo -> [Name]+availSubordinateNames (Avail {}) = []+availSubordinateNames avail@(AvailTC _ ns)   | availExportsDecl avail = tail ns   | otherwise              = ns ---- | Used where we may have an ordinary name or a record field label.--- See Note [GreNames] in GHC.Types.Name.Reader.-data GreName = NormalGreName Name-             | FieldGreName FieldLabel-    deriving (Data, Eq)--instance Outputable GreName where-  ppr (NormalGreName n) = ppr n-  ppr (FieldGreName fl) = ppr fl--instance NFData GreName where-  rnf (NormalGreName n) = rnf n-  rnf (FieldGreName f) = rnf f--instance HasOccName GreName where-  occName (NormalGreName n) = occName n-  occName (FieldGreName fl) = occName fl--instance Ord GreName where-  compare = stableGreNameCmp---- | A 'Name' for internal use, but not for output to the user.  For fields, the--- 'OccName' will be the selector.  See Note [GreNames] in GHC.Types.Name.Reader.-greNameMangledName :: GreName -> Name-greNameMangledName (NormalGreName n) = n-greNameMangledName (FieldGreName fl) = flSelector fl---- | A 'Name' suitable for output to the user.  For fields, the 'OccName' will--- be the field label.  See Note [GreNames] in GHC.Types.Name.Reader.-greNamePrintableName :: GreName -> Name-greNamePrintableName (NormalGreName n) = n-greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl--greNameSrcSpan :: GreName -> SrcSpan-greNameSrcSpan (NormalGreName n) = nameSrcSpan n-greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl)--greNameFieldLabel :: GreName -> Maybe FieldLabel-greNameFieldLabel (NormalGreName {}) = Nothing-greNameFieldLabel (FieldGreName fl)  = Just fl--partitionGreNames :: [GreName] -> ([Name], [FieldLabel])-partitionGreNames = partitionEithers . map to_either+-- | Sort 'Avails'/'AvailInfo's+sortAvails :: Avails -> DetOrdAvails+sortAvails = DefinitelyDeterministicAvails . sortBy stableAvailCmp . map sort_subs   where-    to_either (NormalGreName n) = Left n-    to_either (FieldGreName fl) = Right fl-+    sort_subs :: AvailInfo -> AvailInfo+    sort_subs (Avail n) = Avail n+    sort_subs (AvailTC n []) = AvailTC n []+    sort_subs (AvailTC n (m:ms))+       | n == m+       = AvailTC n (m:sortBy stableNameCmp ms)+       | otherwise+       = AvailTC n (sortBy stableNameCmp (m:ms))+       -- Maintain the AvailTC Invariant  -- ----------------------------------------------------------------------------- -- Utility@@ -322,7 +191,7 @@ plusAvail (AvailTC _ [])     a2@(AvailTC {})   = a2 plusAvail a1@(AvailTC {})       (AvailTC _ []) = a1 plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))-  = case (NormalGreName n1==s1, NormalGreName n2==s2) of  -- Maintain invariant the parent is first+  = case (n1 == s1, n2 == s2) of  -- Maintain invariant the parent is first        (True,True)   -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2))        (True,False)  -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2)))        (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2))@@ -332,7 +201,7 @@ -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo trimAvail avail@(Avail {})         _ = avail-trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of+trimAvail avail@(AvailTC n ns) m = case find (== m) ns of     Just c  -> AvailTC n [c]     Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m]) @@ -344,10 +213,10 @@ filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest =   case ie of-    Avail c | keep (greNameMangledName c) -> ie : rest+    Avail c | keep c -> ie : rest             | otherwise -> rest     AvailTC tc cs ->-        let cs' = filter (keep . greNameMangledName) cs+        let cs' = filter keep cs         in if null cs' then rest else AvailTC tc cs' : rest  @@ -355,7 +224,7 @@ -- 'avails' may have several items with the same availName -- E.g  import Ix( Ix(..), index ) -- will give Ix(Ix,index,range) and Ix(index)--- We want to combine these; addAvail does that+-- We want to combine these; plusAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails)   where@@ -394,18 +263,6 @@   rnf (Avail n) = rnf n   rnf (AvailTC a b) = rnf a `seq` rnf b -instance Binary GreName where-    put_ bh (NormalGreName aa) = do-            putByte bh 0-            put_ bh aa-    put_ bh (FieldGreName ab) = do-            putByte bh 1-            put_ bh ab-    get bh = do-            h <- getByte bh-            case h of-              0 -> do aa <- get bh-                      return (NormalGreName aa)-              _ -> do ab <- get bh-                      return (FieldGreName ab)-+-- | Create an empty DetOrdAvails+emptyDetOrdAvails :: DetOrdAvails+emptyDetOrdAvails = DefinitelyDeterministicAvails []
compiler/GHC/Types/Basic.hs view
@@ -16,9 +16,13 @@  {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Types.Basic (         LeftOrRight(..),@@ -26,7 +30,8 @@          ConTag, ConTagZ, fIRST_TAG, -        Arity, RepArity, JoinArity, FullArgCount,+        Arity, VisArity, RepArity, JoinArity, FullArgCount,+        JoinPointHood(..), isJoinPoint,          Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -34,14 +39,16 @@         FunctionOrData(..),          RecFlag(..), isRec, isNonRec, boolToRecFlag,-        Origin(..), isGenerated,+        Origin(..), isGenerated, DoPmc(..), requiresPMC,+        GenReason(..), isDoExpansionGenerated, doExpansionFlavour,+        doExpansionOrigin,          RuleName, pprRuleName,          TopLevelFlag(..), isTopLevel, isNotTopLevel,          OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,+        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, hasNonCanonicalFlag,          Boxity(..), isBoxed, @@ -75,12 +82,12 @@         EP(..),          DefMethSpec(..),-        SwapFlag(..), flipSwap, unSwap, isSwapped,+        SwapFlag(..), flipSwap, unSwap, notSwapped, isSwapped, pickSwap,          CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase,          Activation(..), isActive, competesWith,-        isNeverActive, isAlwaysActive, activeInFinalPhase,+        isNeverActive, isAlwaysActive, activeInFinalPhase, activeInInitialPhase,         activateAfterInitial, activateDuringFinal, activeAfter,          RuleMatchInfo(..), isConLike, isFunLike,@@ -109,10 +116,14 @@         Levity(..), mightBeLifted, mightBeUnlifted,         TypeOrConstraint(..), +        TyConFlavour(..), TypeOrData(..), NewOrData(..), tyConFlavourAssoc_maybe,+         NonStandardDefaultingStrategy(..),         DefaultingStrategy(..), defaultNonStandardTyVars, -        ForeignSrcLang (..)+        ForeignSrcLang (..),++        ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels    ) where  import GHC.Prelude@@ -124,19 +135,24 @@ import GHC.Utils.Binary import GHC.Types.SourceText import qualified GHC.LanguageExtensions as LangExt-import Data.Data-import qualified Data.Semigroup as Semi 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+{-+************************************************************************ *                                                                      *           Binary choice *                                                                      * ********************************************************************* -}  data LeftOrRight = CLeft | CRight-                 deriving( Eq, Data )+                 deriving( Eq, Data, Ord )  pickLR :: LeftOrRight -> (a,a) -> a pickLR CLeft  (l,_) = l@@ -155,7 +171,12 @@                    0 -> return CLeft                    _ -> return CRight } +instance NFData LeftOrRight where+  rnf CLeft  = ()+  rnf CRight = () ++ {- ************************************************************************ *                                                                      *@@ -171,6 +192,10 @@ -- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" type Arity = Int +-- | Syntactic (visibility) arity, i.e. the number of visible arguments.+-- See Note [Visibility and arity]+type VisArity = Int+ -- | Representation Arity -- -- The number of represented arguments that can be applied to a value before it does@@ -191,6 +216,71 @@ -- both type and value arguments! type FullArgCount = Int +{- Note [Visibility and arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Arity is the number of arguments that a function expects. In a curried language+like Haskell, there is more than one way to count those arguments.++* `Arity` is the classic notion of arity, concerned with evalution, so it counts+  the number of /value/ arguments that need to be supplied before evaluation can+  take place, as described in notes+    Note [Definition of arity]      in GHC.Core.Opt.Arity+    Note [Arity and function types] in GHC.Types.Id.Info++  Examples:+    Int                       has arity == 0+    Int -> Int                has arity <= 1+    Int -> Bool -> Int        has arity <= 2+  We write (<=) rather than (==) as sometimes evaluation can occur before all+  value arguments are supplied, depending on the actual function definition.++  This evaluation-focused notion of arity ignores type arguments, so:+    forall a.   a             has arity == 0+    forall a.   a -> a        has arity <= 1+    forall a b. a -> b -> a   has arity <= 2+  This is true regardless of ForAllTyFlag, so the arity is also unaffected by+  (forall {a}. ty) or (forall a -> ty).++  Class dictionaries count towards the arity, as they are passed at runtime+    forall a.   (Num a)        => a            has arity <= 1+    forall a.   (Num a)        => a -> a       has arity <= 2+    forall a b. (Num a, Ord b) => a -> b -> a  has arity <= 4++* `VisArity` is the syntactic notion of arity. It is the number of /visible/+  arguments, i.e. arguments that occur visibly in the source code.++  In a function call `f x y z`, we can confidently say that f's vis-arity >= 3,+  simply because we see three arguments [x,y,z]. We write (>=) rather than (==)+  as this could be a partial application.++  At definition sites, we can acquire an underapproximation of vis-arity by+  counting the patterns on the LHS, e.g. `f a b = rhs` has vis-arity >= 2.+  The actual vis-arity can be higher if there is a lambda on the RHS,+  e.g. `f a b = \c -> rhs`.++  If we look at the types, we can observe the following+    * function arrows   (a -> b)        add to the vis-arity+    * visible foralls   (forall a -> b) add to the vis-arity+    * constraint arrows (a => b)        do not affect the vis-arity+    * invisible foralls (forall a. b)   do not affect the vis-arity++  This means that ForAllTyFlag matters for VisArity (in contrast to Arity),+  while the type/value distinction is unimportant (again in contrast to Arity).++  Examples:+    Int                         -- vis-arity == 0   (no args)+    Int -> Int                  -- vis-arity == 1   (1 funarg)+    forall a. a -> a            -- vis-arity == 1   (1 funarg)+    forall a. Num a => a -> a   -- vis-arity == 1   (1 funarg)+    forall a -> Num a => a      -- vis-arity == 1   (1 req tyarg, 0 funargs)+    forall a -> a -> a          -- vis-arity == 2   (1 req tyarg, 1 funarg)+    Int -> forall a -> Int      -- vis-arity == 2   (1 funarg, 1 req tyarg)++  Wrinkle: with TypeApplications and TypeAbstractions, it is possible to visibly+  bind and pass invisible arguments, e.g. `f @a x = ...` or `f @Int 42`. Those+  @-prefixed arguments are ignored for the purposes of vis-arity.+-}+ {- ************************************************************************ *                                                                      *@@ -375,6 +465,7 @@ data SwapFlag   = NotSwapped  -- Args are: actual,   expected   | IsSwapped   -- Args are: expected, actual+  deriving( Eq )  instance Outputable SwapFlag where   ppr IsSwapped  = text "Is-swapped"@@ -388,6 +479,14 @@ isSwapped IsSwapped  = True isSwapped NotSwapped = False +notSwapped :: SwapFlag -> Bool+notSwapped NotSwapped = True+notSwapped IsSwapped  = False++pickSwap :: SwapFlag -> a -> a -> a+pickSwap NotSwapped a _ = a+pickSwap IsSwapped  _ b = b+ unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b unSwap NotSwapped f a b = f a b unSwap IsSwapped  f a b = f b a@@ -439,6 +538,10 @@           1 -> return IsData           _ -> panic "Binary FunctionOrData" +instance NFData FunctionOrData where+  rnf IsFunction = ()+  rnf IsData = ()+ {- ************************************************************************ *                                                                      *@@ -522,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@@ -575,18 +683,90 @@ ************************************************************************ -} +-- | Was this piece of code user-written or generated by the compiler?+--+-- See Note [Generated code and pattern-match checking]. data Origin = FromSource-            | Generated+            | Generated GenReason DoPmc             deriving( Eq, Data )  isGenerated :: Origin -> Bool-isGenerated Generated = True-isGenerated FromSource = False+isGenerated Generated{}  = True+isGenerated FromSource   = False +-- | This metadata stores the information as to why was the piece of code generated+--   It is useful for generating the right error context+-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+data GenReason = DoExpansion HsDoFlavour+               | OtherExpansion+               deriving (Eq, Data)++instance Outputable GenReason where+  ppr DoExpansion{}  = text "DoExpansion"+  ppr OtherExpansion = text "OtherExpansion"++doExpansionFlavour :: Origin -> Maybe HsDoFlavour+doExpansionFlavour (Generated (DoExpansion f) _) = Just f+doExpansionFlavour _ = Nothing++-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+isDoExpansionGenerated :: Origin -> Bool+isDoExpansionGenerated = isJust . doExpansionFlavour++-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+doExpansionOrigin :: HsDoFlavour -> Origin+doExpansionOrigin f = Generated (DoExpansion f) DoPmc+                    -- It is important that we perfrom PMC+                    -- on the expressions generated by do statements+                    -- to get the right pattern match checker warnings+                    -- See `GHC.HsToCore.Pmc.pmcMatches`+ instance Outputable Origin where-  ppr FromSource  = text "FromSource"-  ppr Generated   = text "Generated"+  ppr FromSource             = text "FromSource"+  ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc +-- | Whether to run pattern-match checks in generated code.+--+-- See Note [Generated code and pattern-match checking].+data DoPmc = SkipPmc+           | DoPmc+           deriving( Eq, Data )++instance Outputable DoPmc where+  ppr SkipPmc     = text "SkipPmc"+  ppr DoPmc       = text "DoPmc"++-- | Does this 'Origin' require us to run pattern-match checking,+-- or should we skip these checks?+--+-- See Note [Generated code and pattern-match checking].+requiresPMC :: Origin -> Bool+requiresPMC (Generated _ SkipPmc) = False+requiresPMC _ = True++{- Note [Generated code and pattern-match checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some parts of the compiler generate code that is then typechecked. For example:++  - the XXExprGhcRn mechanism described in Note [Rebindable syntax and XXExprGhcRn]+    in GHC.Hs.Expr,+  - the deriving mechanism.++It is usually the case that we want to avoid generating error messages that+refer to generated code. The way this is handled is that we mark certain+parts of the AST as being generated (using the Origin datatype); this is then+used to set the tcl_in_gen_code flag in TcLclEnv, as explained in+Note [Error contexts in generated code] in GHC.Tc.Utils.Monad.++Being in generated code is usually taken to mean we should also skip doing+pattern-match checking, but not always. For example, when desugaring a record+update (as described in Note [Record Updates] in GHC.Tc.Gen.Expr), we still want+to do pattern-match checking, in order to report incomplete record updates+(failing to do so lead to #23250). So, for a 'Generated' 'Origin', we keep track+of whether we should do pattern-match checks; see the calls of the requiresPMC+function (e.g. isMatchContextPmChecked and needToRunPmCheck in GHC.HsToCore.Pmc.Utils).+-}+ {- ************************************************************************ *                                                                      *@@ -599,14 +779,7 @@ -- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a -- explanation of the `isSafeOverlap` field. ----- - 'GHC.Parser.Annotation.AnnKeywordId' :---      'GHC.Parser.Annotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or---                              @'\{-\# OVERLAPPING'@ or---                              @'\{-\# OVERLAPS'@ or---                              @'\{-\# INCOHERENT'@,---      'GHC.Parser.Annotation.AnnClose' @`\#-\}`@, --- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" data OverlapFlag = OverlapFlag   { overlapMode   :: OverlapMode   , isSafeOverlap :: Bool@@ -620,6 +793,7 @@ hasIncoherentFlag mode =   case mode of     Incoherent   _ -> True+    NonCanonical _ -> True     _              -> False  hasOverlappableFlag :: OverlapMode -> Bool@@ -628,6 +802,7 @@     Overlappable _ -> True     Overlaps     _ -> True     Incoherent   _ -> True+    NonCanonical _ -> True     _              -> False  hasOverlappingFlag :: OverlapMode -> Bool@@ -636,8 +811,14 @@     Overlapping  _ -> True     Overlaps     _ -> True     Incoherent   _ -> True+    NonCanonical _ -> True     _              -> False +hasNonCanonicalFlag :: OverlapMode -> Bool+hasNonCanonicalFlag = \case+  NonCanonical{} -> True+  _              -> False+ data OverlapMode  -- See Note [Rules for instance lookup] in GHC.Core.InstEnv   = NoOverlap SourceText                   -- See Note [Pragma source text]@@ -692,25 +873,48 @@     -- instantiating 'b' would change which instance     -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" +  | NonCanonical SourceText+    -- ^ Behave like Incoherent, but the instance choice is observable+    -- by the program behaviour. See Note [Coherence and specialisation: overview].+    --+    -- We don't have surface syntax for the distinction between+    -- Incoherent and NonCanonical instances; instead, the flag+    -- `-f{no-}specialise-incoherents` (on by default) controls+    -- whether `INCOHERENT` instances are regarded as Incoherent or+    -- NonCanonical.+   deriving (Eq, Data)   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]"    ppr (Overlapping  _) = text "[overlapping]"    ppr (Overlaps     _) = text "[overlap ok]"    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     put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s     put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s     put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+    put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s     get bh = do         h <- getByte bh         case h of@@ -719,6 +923,7 @@             2 -> (get bh) >>= \s -> return $ Incoherent s             3 -> (get bh) >>= \s -> return $ Overlapping s             4 -> (get bh) >>= \s -> return $ Overlappable s+            5 -> (get bh) >>= \s -> return $ NonCanonical s             _ -> panic ("get OverlapMode" ++ show h)  @@ -836,7 +1041,7 @@   = BoxedTuple   | UnboxedTuple   | ConstraintTuple-  deriving( Eq, Data )+  deriving( Eq, Data, Ord )  instance Outputable TupleSort where   ppr ts = text $@@ -856,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@@ -955,14 +1165,23 @@ *                                                                      * ************************************************************************ -This data type is used exclusively by the simplifier, but it appears in a+Note [OccInfo]+~~~~~~~~~~~~~+The OccInfo data type is used exclusively by the simplifier, but it appears in a SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty near the base of the module hierarchy.  So it seemed simpler to put the defn of-OccInfo here, safely at the bottom+OccInfo here, safely at the bottom.++Note that `OneOcc` doesn't meant that it occurs /syntactially/ only once; it+means that it is /used/ only once. It might occur syntactically many times.+For example, in (case x of A -> y; B -> y; C -> True),+* `y` is used only once+* but it occurs syntactically twice+ -}  -- | identifier Occurrence Information-data OccInfo+data OccInfo -- See Note [OccInfo]   = ManyOccs        { occ_tail    :: !TailCallInfo }                         -- ^ There are many occurrences, or unknown occurrences @@ -1060,8 +1279,9 @@   mappend = (Semi.<>)  ------------------data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]-                  | NoTailCallInfo+data TailCallInfo+  = AlwaysTailCalled {-# UNPACK #-} !JoinArity -- See Note [TailCallInfo]+  | NoTailCallInfo   deriving (Eq)  tailCallInfo :: OccInfo -> TailCallInfo@@ -1142,7 +1362,7 @@ function is always tail-called. See Note [Invariants on join points].  This info is quite fragile and should not be relied upon unless the occurrence-analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of+analyser has *just* run. Use 'Id.idJoinPointHood' for the permanent state of the join-point-hood of a binder; a join id itself will not be marked AlwaysTailCalled. @@ -1387,7 +1607,7 @@  data InlinePragma            -- Note [InlinePragma]   = InlinePragma-      { inl_src    :: SourceText -- Note [Pragma source text]+      { inl_src    :: SourceText -- See Note [Pragma source text]       , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act]        , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n@@ -1553,7 +1773,7 @@  defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma   :: InlinePragma-defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"+defaultInlinePragma = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"                                    , inl_act = AlwaysActive                                    , inl_rule = FunLike                                    , inl_inline = NoUserInlinePrag@@ -1569,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@@ -1674,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"@@ -1686,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@@ -1720,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 @@ -1739,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.@@ -1831,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"@@ -1949,12 +2195,20 @@ data Levity   = Lifted   | Unlifted-  deriving Eq+  deriving (Data,Eq,Ord,Show)  instance Outputable Levity where   ppr Lifted   = text "Lifted"   ppr Unlifted = text "Unlifted" +instance Binary Levity where+  put_ bh = \case+    Lifted   -> putByte bh 0+    Unlifted -> putByte bh 1+  get bh = getByte bh >>= \case+    0 -> pure Lifted+    _ -> pure Unlifted+ mightBeLifted :: Maybe Levity -> Bool mightBeLifted (Just Unlifted) = False mightBeLifted _               = True@@ -1967,9 +2221,98 @@   = 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+*                                                                      *+********************************************************************* -}++-- | Paints a picture of what a 'TyCon' represents, in broad strokes.+-- This is used towards more informative error messages.+data TyConFlavour tc+  = ClassFlavour+  | TupleFlavour Boxity+  | SumFlavour+  | DataTypeFlavour+  | NewtypeFlavour+  | AbstractTypeFlavour+  | OpenFamilyFlavour TypeOrData (Maybe tc) -- Just tc <=> (tc == associated class)+  | ClosedTypeFamilyFlavour+  | TypeSynonymFlavour+  | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.+  | PromotedDataConFlavour+  deriving (Eq, Data, Functor)++instance Outputable (TyConFlavour tc) where+  ppr = text . go+    where+      go ClassFlavour = "class"+      go (TupleFlavour boxed) | isBoxed boxed = "tuple"+                              | otherwise     = "unboxed tuple"+      go SumFlavour              = "unboxed sum"+      go DataTypeFlavour         = "data type"+      go NewtypeFlavour          = "newtype"+      go AbstractTypeFlavour     = "abstract type"+      go (OpenFamilyFlavour type_or_data mb_par)+        = 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 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"+++-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour+tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc+tyConFlavourAssoc_maybe (OpenFamilyFlavour _ mb_parent) = mb_parent+tyConFlavourAssoc_maybe _                               = Nothing++-- | Whether something is a type or a data declaration,+-- e.g. a type family or a data family.+data TypeOrData+  = 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 newOrData) = ppr newOrData+  ppr IAmType = text "type"++instance Outputable NewOrData where+ ppr = \case+    NewType  -> text "newtype"+    DataType -> text "data"++{- *********************************************************************+*                                                                      *                         Defaulting options *                                                                      * ********************************************************************* -}@@ -2047,7 +2390,7 @@ GHC.Iface.Type.defaultIfaceTyVarsOfKind    This is a built-in defaulting mechanism that only applies when pretty-printing.-  It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-kinds is enabled,+  It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-runtime-reps is enabled,   and 'Multiplicity' variables unless -XLinearTypes is enabled.  -}@@ -2096,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/BreakInfo.hs 
@@ -1,12 +0,0 @@--- | A module for the BreakInfo type. Used by both the GHC.Runtime.Eval and--- GHC.Runtime.Interpreter hierarchy, so put here to have a less deep module--- dependency tree-module GHC.Types.BreakInfo (BreakInfo(..)) where--import GHC.Prelude-import GHC.Unit.Module--data BreakInfo = BreakInfo-  { breakInfo_module :: Module-  , breakInfo_number :: Int-  }
compiler/GHC/Types/CompleteMatch.hs view
@@ -1,40 +1,70 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}  -- | COMPLETE signature-module GHC.Types.CompleteMatch where+module GHC.Types.CompleteMatch+  ( CompleteMatchX(..)+  , CompleteMatch, CompleteMatches+  , DsCompleteMatch, DsCompleteMatches+  , mkCompleteMatch, vanillaCompleteMatch+  , completeMatchAppliesAtType+  ) where  import GHC.Prelude import GHC.Core.TyCo.Rep-import GHC.Types.Unique.DSet+import GHC.Types.Unique import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Type ( splitTyConApp_maybe )+import GHC.Types.Name ( Name )+import GHC.Types.Unique.DSet import GHC.Utils.Outputable +type CompleteMatch   = CompleteMatchX Name+type DsCompleteMatch = CompleteMatchX ConLike++type CompleteMatches   = [CompleteMatch]+type DsCompleteMatches = [DsCompleteMatch]+ -- | A list of conlikes which represents a complete pattern match. -- These arise from @COMPLETE@ signatures. -- See also Note [Implementation of COMPLETE pragmas].-data CompleteMatch = CompleteMatch-  { cmConLikes :: UniqDSet ConLike -- ^ The set of `ConLike` values-  , cmResultTyCon :: Maybe TyCon   -- ^ The optional, concrete result TyCon the set applies to+data CompleteMatchX con = CompleteMatch+  { cmConLikes :: UniqDSet con  -- ^ The set of constructor names+  , cmResultTyCon :: Maybe Name -- ^ The optional, concrete result TyCon name the set applies to   }+  deriving Eq -vanillaCompleteMatch :: UniqDSet ConLike -> CompleteMatch-vanillaCompleteMatch cls = CompleteMatch { cmConLikes = cls, cmResultTyCon = Nothing }+mkCompleteMatch :: UniqDSet con -> Maybe Name -> CompleteMatchX con+mkCompleteMatch nms mb_tc = CompleteMatch { cmConLikes = nms, cmResultTyCon = mb_tc } -instance Outputable CompleteMatch where+vanillaCompleteMatch :: UniqDSet con -> CompleteMatchX con+vanillaCompleteMatch nms = mkCompleteMatch nms Nothing++instance Outputable con => Outputable (CompleteMatchX con) where   ppr (CompleteMatch cls mty) = case mty of     Nothing -> ppr cls     Just ty -> ppr cls <> text "@" <> parens (ppr ty) -type CompleteMatches = [CompleteMatch]--completeMatchAppliesAtType :: Type -> CompleteMatch -> Bool-completeMatchAppliesAtType ty cm = all @Maybe ty_matches (cmResultTyCon cm)+-- | Does this 'COMPLETE' set apply at this type?+--+-- See the part about "result type constructors" in+-- Note [Implementation of COMPLETE pragmas] in GHC.HsToCore.Pmc.Solver.+completeMatchAppliesAtType :: Type -> CompleteMatchX con -> Bool+completeMatchAppliesAtType ty cm = all @Maybe ty_matches (getUnique <$> cmResultTyCon cm)   where+    ty_matches :: Unique -> Bool     ty_matches sig_tc       | Just (tc, _arg_tys) <- splitTyConApp_maybe ty-      , tc == sig_tc+      , tc `hasKey` sig_tc+      || sig_tc `is_family_ty_con_of` tc+         -- #24326: sig_tc might be the data Family TyCon of the representation+         --         TyCon tc -- this CompleteMatch still applies       = True       | otherwise       = False+    fam_tc `is_family_ty_con_of` repr_tc =+      case fst <$> tyConFamInst_maybe repr_tc of+        Just tc -> tc `hasKey` fam_tc+        Nothing -> False
compiler/GHC/Types/CostCentre.hs view
@@ -4,6 +4,7 @@         CostCentre(..), CcName, CCFlavour,         mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour,         mkLateCCFlavour, mkCallerCCFlavour,+        getAllCAFsCC,          pprCostCentre,         CostCentreStack,@@ -35,6 +36,7 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Types.CostCentre.State+import Control.DeepSeq  import Data.Data @@ -281,10 +283,8 @@   ppr = pprCostCentre  pprCostCentre :: IsLine doc => CostCentre -> doc-pprCostCentre cc = docWithContext $ \ sty ->-  if codeStyle (sdocStyle sty)-  then ppCostCentreLbl cc-  else ftext (costCentreUserNameFS cc)+pprCostCentre cc = docWithStyle (ppCostCentreLbl cc)+                                (\_ -> ftext (costCentreUserNameFS cc)) {-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} {-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable @@ -395,3 +395,28 @@     -- 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 =+    let+      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better+      all_cafs_cc  = mkAllCafsCC this_mod span+      all_cafs_ccs = mkSingletonCCS all_cafs_cc+    in+      (all_cafs_cc, all_cafs_ccs)+
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
@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Types.DefaultEnv+   ( ClassDefaults (..)+   , DefaultProvenance (..)+   , DefaultEnv+   , emptyDefaultEnv+   , isEmptyDefaultEnv+   , defaultEnv+   , unitDefaultEnv+   , lookupDefaultEnv+   , filterDefaultEnv+   , defaultList+   , plusDefaultEnv+   , mkDefaultEnv+   , insertDefaultEnv+   , isHaskell2010Default+   )+where++import GHC.Core.Class (Class (className))+import GHC.Prelude+import GHC.Hs.Extension (GhcRn)+import GHC.Tc.Utils.TcType (Type)+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++import Data.Data (Data)+import Data.List (sortBy)+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_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+                  }+  deriving Data++instance Outputable ClassDefaults where+  ppr ClassDefaults {cd_class = cls, cd_types = tys} = text "default" <+> ppr cls+        <+> parens (interpp'SP tys)++emptyDefaultEnv :: DefaultEnv+emptyDefaultEnv = emptyNameEnv++isEmptyDefaultEnv :: DefaultEnv -> Bool+isEmptyDefaultEnv = isEmptyNameEnv++unitDefaultEnv :: ClassDefaults -> DefaultEnv+unitDefaultEnv d = unitNameEnv (className $ cd_class d) d++defaultEnv :: [ClassDefaults] -> DefaultEnv+defaultEnv = mkNameEnvWith (className . cd_class)++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++filterDefaultEnv :: (ClassDefaults -> Bool) -> DefaultEnv -> DefaultEnv+filterDefaultEnv = filterNameEnv++plusDefaultEnv :: DefaultEnv -> DefaultEnv -> DefaultEnv+plusDefaultEnv = plusNameEnv++-- | Create a 'DefaultEnv' from a list of (Name, ClassDefaults) pairs+-- it is useful if we don't want to poke into the 'ClassDefaults' structure+-- to get the 'Name' of the class, it can be problematic, see #25858+mkDefaultEnv :: [(Name, ClassDefaults)] -> DefaultEnv+mkDefaultEnv = mkNameEnv
compiler/GHC/Types/Demand.hs view
@@ -1,3 +1,4 @@+ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-}@@ -22,24 +23,26 @@     absDmd, topDmd, botDmd, seqDmd, topSubDmd,     -- *** Least upper bound     lubCard, lubDmd, lubSubDmd,+    -- *** Greatest lower bound+    glbCard,     -- *** Plus     plusCard, plusDmd, plusSubDmd,     -- *** Multiply     multCard, multDmd, multSubDmd,     -- ** Predicates on @Card@inalities and @Demand@s-    isAbs, isUsedOnce, isStrict,-    isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,+    isAbs, isAtMostOnce, isStrict,+    isAbsDmd, isAtMostOnceDmd, isStrUsedDmd, isStrictDmd,     isTopDmd, isWeakDmd, onlyBoxedArguments,     -- ** Special demands     evalDmd,     -- *** Demands used in PrimOp signatures     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,     -- ** Other @Demand@ operations-    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,-    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,+    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd,+    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity,     mkWorkerDemand, subDemandIfEvaluated,     -- ** Extracting one-shot information-    argOneShots, argsOneShots, saturatedByOneShots,+    callCards, argOneShots, argsOneShots, saturatedByOneShots,     -- ** Manipulating Boxity of a Demand     unboxDeeplyDmd, @@ -48,7 +51,7 @@      -- * Demand environments     DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,-    reuseEnv,+    multDmdEnv, reuseEnv,      -- * Demand types     DmdType(..), dmdTypeDepth,@@ -88,8 +91,7 @@ import GHC.Types.Basic import GHC.Data.Maybe   ( orElse ) -import GHC.Core.Type    ( Type )-import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )+import GHC.Core.Type    ( Type, isTerminatingType ) import GHC.Core.DataCon ( splitDataProductType_maybe, StrictnessMark, isMarkedStrict ) import GHC.Core.Multiplicity    ( scaledThing ) @@ -97,7 +99,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Coerce (coerce) import Data.Function@@ -542,9 +543,9 @@ isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set  -- | True <=> upper bound is 1.-isUsedOnce :: Card -> Bool+isAtMostOnce :: Card -> Bool -- See Note [Bit vector representation for Card]-isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set+isAtMostOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set  -- | Is this a 'CardNonAbs'? isCardNonAbs :: Card -> Bool@@ -552,7 +553,7 @@  -- | Is this a 'CardNonOnce'? isCardNonOnce :: Card -> Bool-isCardNonOnce n = isAbs n || not (isUsedOnce n)+isCardNonOnce n = isAbs n || not (isAtMostOnce n)  -- | Intersect with [0,1]. oneifyCard :: Card -> Card@@ -605,24 +606,10 @@ --   * How many times a variable is evaluated, via a 'Card'inality, and --   * How deep its value was evaluated in turn, via a 'SubDemand'. ----- Examples (using Note [Demand notation]):------   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument---     strictly (@1@), but not any deeper (@A@).---   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument---     pair strictly and the first component strictly, but no nested info---     beyond that (@L@). Its second argument is not used at all.---   * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the---     argument function with one argument, exactly once (@1@). No info---     on how the result of that call is evaluated (@L@).---   * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates---     the argument function at most once ((M)aybe) and calls it once when---     it is evaluated.---   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@---     multiplied by two, so we get @S@ (used at least once, possibly multiple---     times).+-- See also Note [Demand notation]+-- and Note [Demand examples]. ----- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled+-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of -- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and -- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there@@ -929,8 +916,8 @@ isStrUsedDmd (n :* _) = isStrict n && not (isAbs n)  -- | Is the value used at most once?-isUsedOnceDmd :: Demand -> Bool-isUsedOnceDmd (n :* _) = isUsedOnce n+isAtMostOnceDmd :: Demand -> Bool+isAtMostOnceDmd (n :* _) = isAtMostOnce n  -- | We try to avoid tracking weak free variable demands in strictness -- signatures for analysis performance reasons.@@ -964,15 +951,15 @@ strictManyApply1Dmd :: Demand strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd --- | First argument of catch#: @MC(M,L)@.+-- | First argument of catch#: @MC(1,L)@. -- Evaluates its arg lazily, but then applies it exactly once to one argument. lazyApply1Dmd :: Demand-lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd+lazyApply1Dmd = C_01 :* mkCall C_11 topSubDmd --- | Second argument of catch#: @MC(M,C(1,L))@.--- Calls its arg lazily, but then applies it exactly once to an additional argument.+-- | Second argument of catch#: @MC(1,C(1,L))@.+-- Evaluates its arg lazily, but then applies it exactly once to two arguments. lazyApply2Dmd :: Demand-lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)+lazyApply2Dmd = C_01 :* mkCall C_11 (mkCall C_11 topSubDmd)  -- | Make a 'Demand' evaluated at-most-once. oneifyDmd :: Demand -> Demand@@ -984,33 +971,31 @@ strictifyDmd :: Demand -> Demand strictifyDmd = plusDmd seqDmd --- | If the argument is a used non-newtype dictionary, give it strict demand.+-- | If the argument is a guaranteed-terminating type+--   (i.e. a non-newtype dictionary) give it strict demand.+--   This is sound because terminating types can't be bottom:+--         See GHC.Core Note [NON-BOTTOM-DICTS invariant] -- Also split the product type & demand and recur in order to similarly -- strictify the argument's contained used non-newtype superclass dictionaries. -- We use the demand as our recursive measure to guarantee termination. 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-      | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys)-          <- splitDataProductType_maybe ty-      , not (isNewTyCon tycon)-      , isClassTyCon tycon-      = Just inst_con_arg_tys-      | otherwise-      = Nothing strictifyDictDmd _  dmd = dmd  -- | Make a 'Demand' lazy. lazifyDmd :: Demand -> Demand lazifyDmd = multDmd C_01 +-- | Adjust the demand on a binding that may float outwards+-- See Note [Floatifying demand info when floating]+floatifyDmd :: Demand -> Demand+floatifyDmd = multDmd C_0N+ -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd@@ -1036,6 +1021,12 @@     go _ _  _                          = (topCard, topSubDmd) {-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context +strictCallArity :: SubDemand -> Arity+strictCallArity sd = go 0 sd+  where+    go n (Call card sd) | isStrict card = go (n+1) sd+    go n _                              = n+ -- | Extract the 'SubDemand' of a 'Demand'. -- PRECONDITION: The SubDemand must be used in a context where the expression -- denoted by the Demand is under evaluation.@@ -1069,13 +1060,17 @@ argOneShots AbsDmd    = [] -- This defn conflicts with 'saturatedByOneShots', argOneShots BotDmd    = [] -- according to which we should return                            -- @repeat OneShotLam@ here...-argOneShots (_ :* sd) = go sd+argOneShots (_ :* sd) = map go (callCards sd)   where-    go (Call n sd)-      | isUsedOnce n = OneShotLam    : go sd-      | otherwise    = NoOneShotInfo : go sd-    go _    = []+    go n | isAtMostOnce n = OneShotLam+         | otherwise      = NoOneShotInfo +-- | See Note [Computing one-shot info]+callCards :: SubDemand -> [Card]+callCards (Call n sd) = n : callCards sd+callCards (Poly _ _n) = [] -- n is never C_01 or C_11 so we may as well stop here+callCards Prod{}      = []+ -- | -- @saturatedByOneShots n C(M,C(M,...)) = True@ --   <=>@@ -1084,7 +1079,7 @@ saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd    = True saturatedByOneShots _ BotDmd    = True-saturatedByOneShots n (_ :* sd) = isUsedOnce $ fst $ peelManyCalls n sd+saturatedByOneShots n (_ :* sd) = isAtMostOnce $ fst $ peelManyCalls n sd  {- Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1386,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. -}  {- *********************************************************************@@ -1427,7 +1405,7 @@ -- -- [n] nontermination (e.g. loops) -- [i] throws imprecise exception--- [p] throws precise exceTtion+-- [p] throws precise exception -- [c] converges (reduces to WHNF). -- -- The different lattice elements correspond to different subsets, indicated by@@ -1612,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.@@ -1735,7 +1736,7 @@ -- Subject to Note [Default demand on free variables and arguments] -- | Captures the result of an evaluation of an expression, by -----   * Listing how the free variables of that expression have been evaluted+--   * Listing how the free variables of that expression have been evaluated --     ('de_fvs') --   * Saying whether or not evaluation would surely diverge ('de_div') --@@ -1789,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@@ -1833,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@@ -1893,10 +1893,11 @@ splitDmdTy ty@DmdType{dt_env=env}       = (defaultArgDmd (de_div env), ty)  multDmdType :: Card -> DmdType -> DmdType-multDmdType n (DmdType fv args)+multDmdType C_11 dmd_ty = dmd_ty -- a vital optimisation for T25196+multDmdType n    (DmdType fv args)   = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $     DmdType (multDmdEnv n fv)-            (map (multDmd n) args)+            (strictMap (multDmd n) args)  peelFV :: DmdType -> Var -> (DmdType, Demand) peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)@@ -2068,6 +2069,12 @@ *                                                                      * ************************************************************************ +Note [DmdSig: demand signatures, and demand-sig arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also+  * Note [Demand signatures semantically]+  * Note [Understanding DmdType and DmdSig]+ In a let-bound Id we record its demand signature. In principle, this demand signature is a demand transformer, mapping a demand on the Id into a DmdType, which gives@@ -2078,20 +2085,22 @@  However, in fact we store in the Id an extremely emasculated demand transformer, namely--                a single DmdType+        a single DmdType (Nevertheless we dignify DmdSig as a distinct type.) -This DmdType gives the demands unleashed by the Id when it is applied-to as many arguments as are given in by the arg demands in the DmdType.+The DmdSig for an Id is a semantic thing.  Suppose a function `f` has a DmdSig of+  DmdSig (DmdType (fv_dmds,res) [d1..dn])+Here `n` is called the "demand-sig arity" of the DmdSig.  The signature means:+  * If you apply `f` to n arguments (the demand-sig-arity)+  * then you can unleash demands d1..dn on the arguments+  * and demands fv_dmds on the free variables. Also see Note [Demand type Divergence] for the meaning of a Divergence in a-strictness signature.+demand signature. -If an Id is applied to less arguments than its arity, it means that-the demand on the function at a call site is weaker than the vanilla-call demand, used for signature inference. Therefore we place a top-demand on all arguments. Otherwise, the demand is specified by Id's-signature.+If `f` is applied to fewer value arguments than its demand-sig arity, it means+that the demand on the function at a call site is weaker than the vanilla call+demand, used for signature inference. Therefore we place a top demand on all+arguments.  For example, the demand transformer described by the demand signature         DmdSig (DmdType {x -> <1L>} <A><1P(L,L)>)@@ -2102,6 +2111,61 @@ If this same function is applied to one arg, all we can say is that it uses x with 1L, and its arg with demand 1P(L,L). +Note [Demand signatures semantically]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand analysis interprets expressions in the abstract domain of demand+transformers. Given a (sub-)demand that denotes the evaluation context, the+abstract transformer of an expression gives us back a demand type denoting+how other things (like arguments and free vars) were used when the expression+was evaluated. Here's an example:++  f x y =+    if x + expensive+      then \z -> z + y * ...+      else \z -> z * ...++The abstract transformer (let's call it F_e) of the if expression (let's+call it e) would transform an incoming (undersaturated!) head sub-demand A+into a demand type like {x-><1L>,y-><L>}<L>. In pictures:++     SubDemand ---F_e---> DmdType+     <A>                  {x-><1L>,y-><L>}<L>++Let's assume that the demand transformers we compute for an expression are+correct wrt. to some concrete semantics for Core. How do demand signatures fit+in? They are strange beasts, given that they come with strict rules when to+it's sound to unleash them.++Fortunately, we can formalise the rules with Galois connections. Consider+f's strictness signature, {}<1L><L>. It's a single-point approximation of+the actual abstract transformer of f's RHS for arity 2. So, what happens is that+we abstract *once more* from the abstract domain we already are in, replacing+the incoming Demand by a simple lattice with two elements denoting incoming+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom+element). Here's the diagram:++     A_2 -----f_f----> DmdType+      ^                   |+      | α               γ |+      |                   v+  SubDemand --F_f----> DmdType++With+  α(C(1,C(1,_))) = >=2+  α(_)         =  <2+  γ(ty)        =  ty+and F_f being the abstract transformer of f's RHS and f_f being the abstracted+abstract transformer computable from our demand signature simply by++  f_f(>=2) = {}<1L><L>+  f_f(<2)  = multDmdType C_0N {}<1L><L>++where multDmdType makes a proper top element out of the given demand type.++In practice, the A_n domain is not just a simple Bool, but a Card, which is+exactly the Card with which we have to multDmdType. The Card for arity n+is computed by calling @peelManyCalls n@, which corresponds to α above.+ Note [Understanding DmdType and DmdSig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to@@ -2114,10 +2178,10 @@ put that expression under. Note the monotonicity; a stronger incoming demand yields a more precise demand type: -    incoming demand   |  demand type+    incoming sub-demand   |  demand type     ---------------------------------    1A                  |  <L><L>{}-    C(1,C(1,L))           |  <1P(L)><L>{}+    P(A)                  |  <L><L>{}+    C(1,C(1,P(L)))        |  <1P(L)><L>{}     C(1,C(1,1P(1P(L),A))) |  <1P(A)><A>{}  Note that in the first example, the depth of the demand type was *higher* than@@ -2138,11 +2202,11 @@   * A demand type that is sound to unleash when the minimum arity requirement is     met. -Here comes the subtle part: The threshold is encoded in the wrapped demand-type's depth! So in mkDmdSigForArity we make sure to trim the list of-argument demands to the given threshold arity. Call sites will make sure that-this corresponds to the arity of the call demand that elicited the wrapped-demand type. See also Note [What are demand signatures?].+Here comes the subtle part: The threshold is encoded in the demand-sig arity!+So in mkDmdSigForArity we make sure to trim the list of argument demands to the+given threshold arity. Call sites will make sure that this corresponds to the+arity of the call demand that elicited the wrapped demand type. See also+Note [DmdSig: demand signatures, and demand-sig arity] -}  -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe@@ -2155,9 +2219,11 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig-mkDmdSigForArity arity dmd_ty@(DmdType fvs args)-  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args)-  | otherwise                   = DmdSig (etaExpandDmdType arity dmd_ty)+mkDmdSigForArity threshold_arity dmd_ty@(DmdType fvs args)+  | threshold_arity < dmdTypeDepth dmd_ty+  = DmdSig $ DmdType (fvs { de_div = topDiv }) (take threshold_arity args)+  | otherwise+  = DmdSig (etaExpandDmdType threshold_arity dmd_ty)  mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds)@@ -2302,7 +2368,7 @@ -- whether it diverges. -- -- See Note [Understanding DmdType and DmdSig]--- and Note [What are demand signatures?].+-- and Note [DmdSig: demand signatures, and demand-sig arity] type DmdTransformer = SubDemand -> DmdType  -- | Extrapolate a demand signature ('DmdSig') into a 'DmdTransformer'.@@ -2313,7 +2379,7 @@ dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd   = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty     -- see Note [Demands from unsaturated function calls]-    -- and Note [What are demand signatures?]+    -- and Note [DmdSig: demand signatures, and demand-sig arity]  -- | A special 'DmdTransformer' for data constructors that feeds product -- demands into the constructor arguments.@@ -2328,84 +2394,33 @@     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)  {--Note [What are demand signatures?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand analysis interprets expressions in the abstract domain of demand-transformers. Given a (sub-)demand that denotes the evaluation context, the-abstract transformer of an expression gives us back a demand type denoting-how other things (like arguments and free vars) were used when the expression-was evaluated. Here's an example:--  f x y =-    if x + expensive-      then \z -> z + y * ...-      else \z -> z * ...--The abstract transformer (let's call it F_e) of the if expression (let's-call it e) would transform an incoming (undersaturated!) head demand 1A into-a demand type like {x-><1L>,y-><L>}<L>. In pictures:--     Demand ---F_e---> DmdType-     <1A>              {x-><1L>,y-><L>}<L>--Let's assume that the demand transformers we compute for an expression are-correct wrt. to some concrete semantics for Core. How do demand signatures fit-in? They are strange beasts, given that they come with strict rules when to-it's sound to unleash them.--Fortunately, we can formalise the rules with Galois connections. Consider-f's strictness signature, {}<1L><L>. It's a single-point approximation of-the actual abstract transformer of f's RHS for arity 2. So, what happens is that-we abstract *once more* from the abstract domain we already are in, replacing-the incoming Demand by a simple lattice with two elements denoting incoming-arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom-element). Here's the diagram:--     A_2 -----f_f----> DmdType-      ^                   |-      | α               γ |-      |                   v-  SubDemand --F_f----> DmdType--With-  α(C(1,C(1,_))) = >=2-  α(_)         =  <2-  γ(ty)        =  ty-and F_f being the abstract transformer of f's RHS and f_f being the abstracted-abstract transformer computable from our demand signature simply by--  f_f(>=2) = {}<1L><L>-  f_f(<2)  = multDmdType C_0N {}<1L><L>--where multDmdType makes a proper top element out of the given demand type.--In practice, the A_n domain is not just a simple Bool, but a Card, which is-exactly the Card with which we have to multDmdType. The Card for arity n-is computed by calling @peelManyCalls n@, which corresponds to α above.- Note [Demand transformer for a dictionary selector] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have a superclass selector 'sc_sel' and a class method@@ -2445,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@@ -2629,7 +2631,8 @@ but it's always clear from context which "overload" is meant. It's like return-type inference of e.g. 'read'. -Examples are in the haddock for 'Demand'.+An example of the demand syntax is 1!P(1!L,A), the demand of fst's argument.+See Note [Demand examples] for more examples and their semantics.  This is the syntax for demand signatures: @@ -2647,7 +2650,39 @@            (omitted if empty)                     (omitted if                                                 no information) +Note [Demand examples]+~~~~~~~~~~~~~~~~~~~~~~+Here are some examples of the demand notation, specified in Note [Demand notation],+in action. In each case we give the demand on the variable `x`. +Demand on x    Example            Explanation+  1!A           seq x y             Evaluates `x` exactly once (`1`), but not+                                    any deeper (`A`), and discards the box (`!`).+  S!A           seq x (seq x y)     Twice the previous demand; hence eval'd+                                    more than once (`S` for strict).+  1!P(1!L,A)    fst x               Evaluates pair `x` exactly once, first+                                    component exactly once. No info that (`L`).+                                    Second component is absent. Discards boxes (`!`).+  1P(1L,A)      opq_fst x           Like fst, but all boxes are retained.+  SP(1!L,A)     opq_seq x (fst x)   Two evals of x but exactly one of its first component.+                                    Box of x retained, but box of first component discarded.+  1!C(1,L)      x $ 3               Evals x exactly once ( 1 ) and calls it+                                    exactly once ( C(1,_) ). No info on how the+                                    result is evaluated ( L ).+  MC(M,L)       maybe y x           Evals x at most once ( 1 ) and calls it at+                                    most once ( C(1,_) ). No info on how the+                                    result is evaluated ( L ).+  LP(SL,A)      map (+ fst x)       Evals x lazily and multiple times ( L ),+                                    but when it is evaluated, the first+                                    component is evaluated (strictly) as well.++In the examples above, `opq_fst` is an opaque wrapper around `fst`, i.e.++  opq_fst = fst+  {-# OPAQUE opq_fst #-}++Similarly for `seq`. The effect of an OPAQUE pragma is that it discards any+boxity flags in the demand signature, as described in Note [OPAQUE pragma]. -}  -- | See Note [Demand notation]
compiler/GHC/Types/Error.hs view
@@ -7,6 +7,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}  module GHC.Types.Error    ( -- * Messages@@ -19,6 +21,7 @@    , addMessage    , unionMessages    , unionManyMessages+   , filterMessages    , MsgEnvelope (..)     -- * Classifying Messages@@ -27,14 +30,22 @@    , Severity (..)    , Diagnostic (..)    , UnknownDiagnostic (..)+   , UnknownDiagnosticFor+   , mkSimpleUnknownDiagnostic+   , mkUnknownDiagnostic+   , embedUnknownDiagnostic    , DiagnosticMessage (..)-   , DiagnosticReason (..)-   , DiagnosticHint (..)+   , DiagnosticReason (WarningWithFlag, ..)+   , ResolvedDiagnosticReason(..)    , mkPlainDiagnostic    , mkPlainError    , mkDecoratedDiagnostic    , mkDecoratedError +   , pprDiagnostic++   , HasDefaultDiagnosticOpts(..)+   , defaultDiagnosticOpts    , NoDiagnosticOpts(..)     -- * Hints and refactoring actions@@ -89,21 +100,26 @@ import GHC.Types.Hint import GHC.Data.FastString (unpackFS) import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)++import GHC.Types.Hint.Ppr () -- Outputable instance+import GHC.Unit.Module.Warnings (WarningCategory(..))+ import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Version (cProjectVersion) import Data.Bifunctor-import Data.Foldable    ( fold )+import Data.Foldable    ( fold, toList )+import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate )+import Data.Maybe ( maybeToList ) import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Text.Printf ( printf ) -{--Note [Messages]-~~~~~~~~~~~~~~~-+{- Note [Messages]+~~~~~~~~~~~~~~~~~~ We represent the 'Messages' as a single bag of warnings and errors.  The reason behind that is that there is a fluid relationship between errors@@ -150,8 +166,14 @@   ppr msgs = braces (vcat (map ppr_one (bagToList (getMessages msgs))))      where        ppr_one :: MsgEnvelope e -> SDoc-       ppr_one envelope = pprDiagnostic (errMsgDiagnostic envelope)+       ppr_one envelope =+        vcat [ text "Resolved:" <+> ppr (errMsgReason envelope),+               pprDiagnostic (errMsgDiagnostic envelope)+             ] +instance (Diagnostic e) => ToJson (Messages e) where+  json msgs =  JSArray . toList $ json <$> getMessages msgs+ {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -179,6 +201,10 @@ unionManyMessages :: Foldable f => f (Messages e) -> Messages e unionManyMessages = fold +filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e+filterMessages f (Messages msgs) =+  Messages (filterBag f msgs)+ -- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the -- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its -- final form, where the typical case would be adding bullets between each@@ -206,6 +232,16 @@ mapDecoratedSDoc f (Decorated s1) =   Decorated (map f s1) +class HasDefaultDiagnosticOpts opts where+  defaultOpts :: opts+++defaultDiagnosticOpts :: forall opts . HasDefaultDiagnosticOpts (DiagnosticOpts opts) => DiagnosticOpts opts+defaultDiagnosticOpts = defaultOpts @(DiagnosticOpts opts)++++ -- | A class identifying a diagnostic. -- Dictionary.com defines a diagnostic as: --@@ -215,12 +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 Diagnostic a where+class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where    -- | Type of configuration options for the diagnostic.   type DiagnosticOpts a-  defaultDiagnosticOpts :: 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 @@ -230,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:@@ -247,36 +287,57 @@   diagnosticCode    :: a -> Maybe DiagnosticCode  -- | An existential wrapper around an unknown diagnostic.-data UnknownDiagnostic where-  UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a)-                    => a -> UnknownDiagnostic+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 hint -instance Diagnostic UnknownDiagnostic where-  type DiagnosticOpts UnknownDiagnostic = NoDiagnosticOpts-  defaultDiagnosticOpts = NoDiagnosticOpts-  diagnosticMessage _ (UnknownDiagnostic diag) = diagnosticMessage NoDiagnosticOpts 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+-- 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 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 (DiagnosticHint a)+embedUnknownDiagnostic f = UnknownDiagnostic f id++--------------------------------------------------------------------------------+ pprDiagnostic :: forall e . Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e)                        , 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 intepret its payload (as it's just a+-- /where/ it was generated nor how to interpret its payload (as it's just a -- structured document). All we can do is to print it out and look at its -- 'DiagnosticReason'. data DiagnosticMessage = DiagnosticMessage@@ -287,7 +348,6 @@  instance Diagnostic DiagnosticMessage where   type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts-  defaultDiagnosticOpts = NoDiagnosticOpts   diagnosticMessage _ = diagMessage   diagnosticReason  = diagReason   diagnosticHints   = diagHints@@ -328,18 +388,73 @@ data DiagnosticReason   = WarningWithoutFlag   -- ^ Born as a warning.-  | WarningWithFlag !WarningFlag+  | WarningWithFlags !(NE.NonEmpty WarningFlag)   -- ^ Warning was enabled with the flag.+  | WarningWithCategory !WarningCategory+  -- ^ Warning was enabled with a custom category.   | ErrorWithoutFlag   -- ^ Born as an error.   deriving (Eq, Show) +-- | Like a 'DiagnosticReason', but resolved against a specific set of `DynFlags` to+-- work out which warning flag actually enabled this warning.+newtype ResolvedDiagnosticReason+          = ResolvedDiagnosticReason { resolvedDiagnosticReason :: DiagnosticReason }++-- | The single warning case 'DiagnosticReason' is very common.+pattern WarningWithFlag :: WarningFlag -> DiagnosticReason+pattern WarningWithFlag w = WarningWithFlags (w :| [])++{- Note [Warnings controlled by multiple flags]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Diagnostics that started life as flag-controlled warnings have a+'diagnosticReason' of 'WarningWithFlags', giving the flags that control the+warning. Usually there is only one flag, but in a few cases multiple flags+apply. Where there are more than one, they are listed highest-priority first.++For example, the same exported binding may give rise to a warning if either+`-Wmissing-signatures` or `-Wmissing-exported-signatures` is enabled. Here+`-Wmissing-signatures` has higher priority, because we want to mention it if+before are enabled.  See `missingSignatureWarningFlags` for the specific logic+in this case.++When reporting such a warning to the user, it is important to mention the+correct flag (e.g. `-Wmissing-signatures` if it is enabled, or+`-Wmissing-exported-signatures` if only the latter is enabled).  Thus+`diag_reason_severity` filters the `DiagnosticReason` based on the currently+active `DiagOpts`. For a `WarningWithFlags` it returns only the flags that are+enabled; it leaves other `DiagnosticReason`s unchanged. This is then wrapped+in a `ResolvedDiagnosticReason` newtype which records that this filtering has+taken place.++If we have `-Wmissing-signatures -Werror=missing-exported-signatures` we want+the error to mention `-Werror=missing-exported-signatures` (even though+`-Wmissing-signatures` would normally take precedence). Thus if there are any+fatal warnings, `diag_reason_severity` returns those alone.++The `MsgEnvelope` stores the filtered `ResolvedDiagnosticReason` listing only the+relevant flags for subsequent display.+++Side note: we do not treat `-Wmissing-signatures` as a warning group that+includes `-Wmissing-exported-signatures`, because++  (a) this would require us to provide a flag for the complement, and++  (b) currently, in `-Wmissing-exported-signatures -Wno-missing-signatures`, the+      latter option does not switch off the former.+-}+ instance Outputable DiagnosticReason where   ppr = \case     WarningWithoutFlag  -> text "WarningWithoutFlag"-    WarningWithFlag wf  -> text ("WarningWithFlag " ++ show wf)+    WarningWithFlags wf -> text ("WarningWithFlags " ++ show wf)+    WarningWithCategory cat -> text "WarningWithCategory" <+> ppr cat     ErrorWithoutFlag    -> text "ErrorWithoutFlag" +instance Outputable ResolvedDiagnosticReason where+  ppr = ppr . resolvedDiagnosticReason+ -- | An envelope for GHC's facts about a running program, parameterised over the -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. --@@ -354,6 +469,10 @@    , errMsgContext     :: NamePprCtx    , errMsgDiagnostic  :: e    , errMsgSeverity    :: Severity+   , errMsgReason      :: ResolvedDiagnosticReason+      -- ^ The actual reason caused this message+      --+      -- See Note [Warnings controlled by multiple flags]    } deriving (Functor, Foldable, Traversable)  -- | The class for a diagnostic message. The main purpose is to classify a@@ -372,7 +491,7 @@     -- ^ Log messages intended for end users.     -- No file\/line\/column stuff. -  | MCDiagnostic Severity DiagnosticReason (Maybe DiagnosticCode)+  | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode)     -- ^ Diagnostics from the compiler. This constructor is very powerful as     -- it allows the construction of a 'MessageClass' with a completely     -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,@@ -426,7 +545,7 @@   -- don't want to see. See Note [Suppressing Messages]   | SevWarning   | SevError-  deriving (Eq, Show)+  deriving (Eq, Ord, Show)  instance Outputable Severity where   ppr = \case@@ -435,7 +554,9 @@     SevError   -> text "SevError"  instance ToJson Severity where-  json s = JSString (show s)+  json SevIgnore = JSString "Ignore"+  json SevWarning = JSString "Warning"+  json SevError = JSString "Error"  instance ToJson MessageClass where   json MCOutput = JSString "MCOutput"@@ -446,6 +567,67 @@   json (MCDiagnostic sev reason code) =     JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) +instance ToJson DiagnosticCode where+  json c = JSInt (fromIntegral (diagnosticCodeNumber c))++{- Note [Diagnostic Message JSON Schema]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The below instance of ToJson must conform to the JSON schema+specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.+When the schema is altered, please bump the version.+If the content is altered in a backwards compatible way,+update the minor version (e.g. 1.3 ~> 1.4).+If the content is breaking, update the major version (e.g. 1.3 ~> 2.0).+When updating the schema, replace the above file and name it appropriately with+the version appended, and change the documentation of the -fdiagnostics-as-json+flag to reflect the new schema.+To learn more about JSON schemas, check out the below link:+https://json-schema.org+-}++schemaVersion :: String+schemaVersion = "1.1"+-- See Note [Diagnostic Message JSON Schema] before editing!+instance Diagnostic e => ToJson (MsgEnvelope e) where+  json m = JSObject $ [+    ("version", JSString schemaVersion),+    ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),+    ("span", json $ errMsgSpan m),+    ("severity", json $ errMsgSeverity m),+    ("code", maybe JSNull json (diagnosticCode diag)),+    ("message", JSArray $ map renderToJSString diagMsg),+    ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]+    ++ [ ("reason", reasonJson)+       | reasonJson <- maybeToList $ usefulReasonJson_maybe (errMsgReason m) ]+    where+      diag = errMsgDiagnostic m+      opts = defaultDiagnosticOpts @e+      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)++      usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc+      usefulReasonJson_maybe (ResolvedDiagnosticReason rea) =+        case rea of+          WarningWithoutFlag -> Nothing+          ErrorWithoutFlag   -> Nothing+          WarningWithFlags flags ->+            Just $ JSObject+              [ ("flags", JSArray $ map (JSString . NE.head . warnFlagNames) (NE.toList flags))+              ]+          WarningWithCategory (WarningCategory cat) ->+            Just $ JSObject+              [ ("category", JSString $ unpackFS cat)+              ]+ instance Show (MsgEnvelope DiagnosticMessage) where     show = showMsgEnvelope @@ -494,12 +676,22 @@           warning_flag_doc =             case msg_class of               MCDiagnostic sev reason _code-                | Just msg <- flag_msg sev reason -> brackets msg-              _                                   -> empty+                | Just msg <- flag_msg sev (resolvedDiagnosticReason reason)+                  -> brackets msg+              _   -> empty +          ppr_with_hyperlink code =+            -- this is a bit hacky, but we assume that if the terminal supports colors+            -- then it should also support links+            sdocOption (\ ctx -> sdocPrintErrIndexLinks ctx) $+              \ use_hyperlinks ->+                 if use_hyperlinks+                 then ppr $ LinkedDiagCode code+                 else ppr code+           code_doc =             case msg_class of-              MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code)+              MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)               _                            -> empty            flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc@@ -508,26 +700,32 @@             -- in a log file, e.g. with -ddump-tc-trace. It should not             -- happen otherwise, though.           flag_msg SevError WarningWithoutFlag = Just (col "-Werror")-          flag_msg SevError (WarningWithFlag wflag) =+          flag_msg SevError (WarningWithFlags (wflag :| _)) =             let name = NE.head (warnFlagNames wflag) in-            Just $ col ("-W" ++ name) <+> warn_flag_grp wflag+            Just $ col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag)                                       <> comma                                       <+> col ("Werror=" ++ name)+          flag_msg SevError   (WarningWithCategory cat) =+            Just $ coloured msg_colour (text "-W" <> ppr cat)+                       <+> warn_flag_grp smallestWarningGroupsForCategory+                       <> comma+                       <+> coloured msg_colour (text "-Werror=" <> ppr cat)           flag_msg SevError   ErrorWithoutFlag   = Nothing           flag_msg SevWarning WarningWithoutFlag = Nothing-          flag_msg SevWarning (WarningWithFlag wflag) =+          flag_msg SevWarning (WarningWithFlags (wflag :| _)) =             let name = NE.head (warnFlagNames wflag) in-            Just (col ("-W" ++ name) <+> warn_flag_grp wflag)+            Just (col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag))+          flag_msg SevWarning (WarningWithCategory cat) =+            Just (coloured msg_colour (text "-W" <> ppr cat)+                      <+> warn_flag_grp smallestWarningGroupsForCategory)           flag_msg SevWarning ErrorWithoutFlag =             pprPanic "SevWarning with ErrorWithoutFlag" $               vcat [ text "locn:" <+> ppr locn                    , text "msg:" <+> ppr msg ] -          warn_flag_grp flag-              | show_warn_groups =-                    case smallestWarningGroups flag of-                        [] -> empty-                        groups -> text $ "(in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"+          warn_flag_grp groups+              | show_warn_groups, not (null groups)+                          = text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"               | otherwise = empty            -- Add prefixes, like    Foo.hs:34: warning:@@ -645,7 +843,7 @@ -- | Returns 'True' if this is, intrinsically, a failure. See -- Note [Intrinsic And Extrinsic Failures]. isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool-isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic+isIntrinsicErrorMessage = (==) ErrorWithoutFlag . resolvedDiagnosticReason . errMsgReason  isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool isWarningMessage = not . isIntrinsicErrorMessage@@ -695,8 +893,29 @@     , diagnosticCodeNumber    :: Natural         -- ^ the actual diagnostic code     }+  deriving ( Eq, Ord ) -instance Outputable DiagnosticCode where-  ppr (DiagnosticCode prefix c) =-    text prefix <> text "-" <> text (printf "%05d" c)+instance Show DiagnosticCode where+  show (DiagnosticCode prefix c) =+    prefix ++ "-" ++ printf "%05d" c       -- pad the numeric code to have at least 5 digits++instance Outputable DiagnosticCode where+  ppr code = text (show code)++-- | A newtype that is a witness to the `-fprint-error-index-links` flag. It+-- alters the @Outputable@ instance to emit @DiagnosticCode@ as ANSI hyperlinks+-- to the HF error index+newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode++instance Outputable LinkedDiagCode where+  ppr (LinkedDiagCode d@DiagnosticCode{}) = linkEscapeCode d++-- | Wrap the link in terminal escape codes specified by OSC 8.+linkEscapeCode :: DiagnosticCode -> SDoc+linkEscapeCode d = text "\ESC]8;;" <> hfErrorLink d -- make the actual link+                   <> text "\ESC\\" <> ppr d <> text "\ESC]8;;\ESC\\" -- the rest is the visible text++-- | create a link to the HF error index given an error code.+hfErrorLink :: DiagnosticCode -> SDoc+hfErrorLink errorCode = text "https://errors.haskell.org/messages/" <> ppr errorCode
compiler/GHC/Types/Error/Codes.hs view
@@ -16,28 +16,44 @@ -- A diagnostic code is a numeric unique identifier for a diagnostic. -- See Note [Diagnostic codes]. module GHC.Types.Error.Codes-  ( constructorCode )+  ( -- * 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 ) -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.Iface.Errors.Types 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.Tc.Utils.TcType      ( IllegalForeignTypeReason, TypeCannotBeMarshaledReason ) 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-import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) )+import GHC.TypeLits ( Symbol, KnownSymbol, symbolVal'+                    , TypeError, ErrorMessage(..) ) import GHC.TypeNats ( Nat, KnownNat, natVal' ) +import Data.Map.Strict ( Map )+import qualified Data.Map.Strict as Map++ {- Note [Diagnostic codes] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Every time a new diagnostic (error or warning) is introduced to GHC,@@ -51,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,@@ -65,7 +85,7 @@          GhcDiagnosticCode "MyNewErrorConstructor" = 12345         You can obtain new randomly-generated error codes by using-       https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain.+       https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain         You will get a type error if you try to use an error code that is already        used by another constructor.@@ -93,21 +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 'DiagnosticCode' type family.+--+-- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and+-- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get+-- > 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 @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.@@ -129,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@@ -146,7 +236,12 @@   GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys"            = 20185   GhcDiagnosticCode "DsRuleMightInlineFirst"                        = 95396   GhcDiagnosticCode "DsAnotherRuleMightFireFirst"                   = 87502+  GhcDiagnosticCode "DsIncompleteRecordSelector"                    = 17335 +    -- Constructors of 'UselessSpecialisePragmaReason'+  GhcDiagnosticCode "UselessSpecialiseForClassMethodSelector"       = 93315+  GhcDiagnosticCode "UselessSpecialiseForNoInlineFunction"          = 38524+  GhcDiagnosticCode "UselessSpecialiseNoSpecialisation"             = 66582    -- Parser diagnostic codes   GhcDiagnosticCode "PsErrParseLanguagePragma"                      = 68686@@ -165,6 +260,7 @@   GhcDiagnosticCode "PsWarnUnrecognisedPragma"                      = 42044   GhcDiagnosticCode "PsWarnMisplacedPragma"                         = 28007   GhcDiagnosticCode "PsWarnImportPreQualified"                      = 07924+  GhcDiagnosticCode "PsWarnViewPatternSignatures"                   = 00834   GhcDiagnosticCode "PsErrLexer"                                    = 21231   GhcDiagnosticCode "PsErrCmmLexer"                                 = 75725   GhcDiagnosticCode "PsErrCmmParser"                                = 09848@@ -199,6 +295,7 @@   GhcDiagnosticCode "PsErrUnallowedPragma"                          = 85314   GhcDiagnosticCode "PsErrImportPostQualified"                      = 87491   GhcDiagnosticCode "PsErrImportQualifiedTwice"                     = 05661+  GhcDiagnosticCode "PsErrSpliceOrQuoteTwice"                       = 26105   GhcDiagnosticCode "PsErrIllegalImportBundleForm"                  = 81284   GhcDiagnosticCode "PsErrInvalidRuleActivationMarker"              = 50396   GhcDiagnosticCode "PsErrMissingBlock"                             = 16849@@ -220,17 +317,18 @@   GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat"           = 76595   GhcDiagnosticCode "PsErrDoNotationInPat"                          = 06446   GhcDiagnosticCode "PsErrIfThenElseInPat"                          = 45696-  GhcDiagnosticCode "PsErrLambdaCaseInPat"                          = 07636+  GhcDiagnosticCode "PsErrLambdaCaseInPat"                          = Outdated 07636   GhcDiagnosticCode "PsErrCaseInPat"                                = 53786   GhcDiagnosticCode "PsErrLetInPat"                                 = 78892   GhcDiagnosticCode "PsErrLambdaInPat"                              = 00482   GhcDiagnosticCode "PsErrArrowExprInPat"                           = 04584   GhcDiagnosticCode "PsErrArrowCmdInPat"                            = 98980   GhcDiagnosticCode "PsErrArrowCmdInExpr"                           = 66043-  GhcDiagnosticCode "PsErrViewPatInExpr"                            = 66228+  GhcDiagnosticCode "PsErrViewPatInExpr"                            = Outdated 66228+  GhcDiagnosticCode "PsErrOrPatInExpr"                              = 66718   GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd"                     = 12178   GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd"                       = 92971-  GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd"                 = 47171+  GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd"                 = Outdated 47171   GhcDiagnosticCode "PsErrIfCmdInFunAppCmd"                         = 97005   GhcDiagnosticCode "PsErrLetCmdInFunAppCmd"                        = 70526   GhcDiagnosticCode "PsErrDoCmdInFunAppCmd"                         = 77808@@ -238,7 +336,7 @@   GhcDiagnosticCode "PsErrMDoInFunAppExpr"                          = 67630   GhcDiagnosticCode "PsErrLambdaInFunAppExpr"                       = 06074   GhcDiagnosticCode "PsErrCaseInFunAppExpr"                         = 25037-  GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr"                   = 77182+  GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr"                   = Outdated 77182   GhcDiagnosticCode "PsErrLetInFunAppExpr"                          = 90355   GhcDiagnosticCode "PsErrIfInFunAppExpr"                           = 01239   GhcDiagnosticCode "PsErrProcInFunAppExpr"                         = 04807@@ -253,7 +351,6 @@   GhcDiagnosticCode "PsErrAtInPatPos"                               = 08382   GhcDiagnosticCode "PsErrParseErrorOnInput"                        = 66418   GhcDiagnosticCode "PsErrMalformedDecl"                            = 85316-  GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl"                  = 45054   GhcDiagnosticCode "PsErrNotADataCon"                              = 25742   GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed"                = 57342   GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax"           = 65719@@ -268,6 +365,12 @@   GhcDiagnosticCode "PsErrInvalidCApiImport"                        = 72744   GhcDiagnosticCode "PsErrMultipleConForNewtype"                    = 05380   GhcDiagnosticCode "PsErrUnicodeCharLooksLike"                     = 31623+  GhcDiagnosticCode "PsErrInvalidPun"                               = 52943+  GhcDiagnosticCode "PsErrIllegalOrPat"                             = 29847+  GhcDiagnosticCode "PsErrTypeSyntaxInPat"                          = 32181+  GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription"           = 62037+  GhcDiagnosticCode "PsWarnSpecMultipleTypeAscription"              = 73026+  GhcDiagnosticCode "PsWarnPatternNamespaceSpecifier"               = 68383    -- Driver diagnostic codes   GhcDiagnosticCode "DriverMissingHomeModules"                      = 32850@@ -294,24 +397,30 @@   GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage"        = 75165   GhcDiagnosticCode "DriverRedirectedNoMain"                        = 95379   GhcDiagnosticCode "DriverHomePackagesNotClosed"                   = 03271+  GhcDiagnosticCode "DriverInconsistentDynFlags"                    = 74335+  GhcDiagnosticCode "DriverSafeHaskellIgnoredExtension"             = 98887+  GhcDiagnosticCode "DriverPackageTrustIgnored"                     = 83552+  GhcDiagnosticCode "DriverUnrecognisedFlag"                        = 93741+  GhcDiagnosticCode "DriverDeprecatedFlag"                          = 53692+  GhcDiagnosticCode "DriverModuleGraphCycle"                        = 92213+  GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284+  GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain"               = 66599    -- Constraint solver diagnostic codes   GhcDiagnosticCode "BadTelescope"                                  = 97739   GhcDiagnosticCode "UserTypeError"                                 = 64725+  GhcDiagnosticCode "UnsatisfiableError"                            = 22250   GhcDiagnosticCode "ReportHoleError"                               = 88464-  GhcDiagnosticCode "UntouchableVariable"                           = 34699   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 @@ -323,12 +432,13 @@   GhcDiagnosticCode "RepresentationalEq"                            = 10283    -- Typechecker/renamer diagnostic codes+  GhcDiagnosticCode "TcRnSolverDepthError"                          = 40404   GhcDiagnosticCode "TcRnRedundantConstraints"                      = 30606   GhcDiagnosticCode "TcRnInaccessibleCode"                          = 40564+  GhcDiagnosticCode "TcRnInaccessibleCoAxBranch"                    = 28129   GhcDiagnosticCode "TcRnTypeDoesNotHaveFixedRuntimeRep"            = 18478   GhcDiagnosticCode "TcRnImplicitLift"                              = 00846   GhcDiagnosticCode "TcRnUnusedPatternBinds"                        = 61367-  GhcDiagnosticCode "TcRnDodgyImports"                              = 99623   GhcDiagnosticCode "TcRnDodgyExports"                              = 75356   GhcDiagnosticCode "TcRnMissingImportList"                         = 77037   GhcDiagnosticCode "TcRnUnsafeDueToPlugin"                         = 01687@@ -336,6 +446,7 @@   GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig"                = 44188   GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig"                 = 50058   GhcDiagnosticCode "TcRnShadowedName"                              = 63397+  GhcDiagnosticCode "TcRnInvalidWarningCategory"                    = 53573   GhcDiagnosticCode "TcRnDuplicateWarningDecls"                     = 00711   GhcDiagnosticCode "TcRnSimplifierTooManyIterations"               = 95822   GhcDiagnosticCode "TcRnIllegalPatSynDecl"                         = 82077@@ -344,6 +455,9 @@   GhcDiagnosticCode "TcRnIllegalFieldPunning"                       = 44287   GhcDiagnosticCode "TcRnIllegalWildcardsInRecord"                  = 37132   GhcDiagnosticCode "TcRnIllegalWildcardInType"                     = 65507+  GhcDiagnosticCode "TcRnIllegalNamedWildcardInTypeArgument"        = 93411+  GhcDiagnosticCode "TcRnIllegalImplicitTyVarInTypeArgument"        = 80557+  GhcDiagnosticCode "TcRnIllegalPunnedVarOccInTypeArgument"         = 09591   GhcDiagnosticCode "TcRnDuplicateFieldName"                        = 85524   GhcDiagnosticCode "TcRnIllegalViewPattern"                        = 22406   GhcDiagnosticCode "TcRnCharLiteralOutOfRange"                     = 17268@@ -356,7 +470,7 @@   GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum"                   = 49356   GhcDiagnosticCode "TcRnTagToEnumResTyTypeData"                    = 96189   GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy"      = 55868-  GhcDiagnosticCode "TcRnIllegalHsBootFileDecl"                     = 58195+  GhcDiagnosticCode "TcRnIllegalHsBootOrSigDecl"                    = 58195   GhcDiagnosticCode "TcRnRecursivePatternSynonym"                   = 72489   GhcDiagnosticCode "TcRnPartialTypeSigTyVarMismatch"               = 88793   GhcDiagnosticCode "TcRnPartialTypeSigBadQuantifier"               = 94185@@ -364,8 +478,6 @@   GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig"               = 64414   GhcDiagnosticCode "TcRnOverloadedSig"                             = 16675   GhcDiagnosticCode "TcRnTupleConstraintInst"                       = 69012-  GhcDiagnosticCode "TcRnAbstractClassInst"                         = 51758-  GhcDiagnosticCode "TcRnNoClassInstHead"                           = 56538   GhcDiagnosticCode "TcRnUserTypeError"                             = 47403   GhcDiagnosticCode "TcRnConstraintInKind"                          = 01259   GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg"              = 19590@@ -377,9 +489,7 @@   GhcDiagnosticCode "TcRnNonTypeVarArgInConstraint"                 = 80003   GhcDiagnosticCode "TcRnIllegalImplicitParam"                      = 75863   GhcDiagnosticCode "TcRnIllegalConstraintSynonymOfKind"            = 75844-  GhcDiagnosticCode "TcRnIllegalClassInst"                          = 53946   GhcDiagnosticCode "TcRnOversaturatedVisibleKindArg"               = 45474-  GhcDiagnosticCode "TcRnBadAssociatedType"                         = 38351   GhcDiagnosticCode "TcRnForAllRankErr"                             = 91510   GhcDiagnosticCode "TcRnMonomorphicBindings"                       = 55524   GhcDiagnosticCode "TcRnOrphanInstance"                            = 90177@@ -389,8 +499,6 @@   GhcDiagnosticCode "TcRnFamInstNotInjective"                       = 05175   GhcDiagnosticCode "TcRnBangOnUnliftedType"                        = 55666   GhcDiagnosticCode "TcRnLazyBangOnUnliftedType"                    = 71444-  GhcDiagnosticCode "TcRnMultipleDefaultDeclarations"               = 99565-  GhcDiagnosticCode "TcRnBadDefaultType"                            = 88933   GhcDiagnosticCode "TcRnPatSynBundledWithNonDataCon"               = 66775   GhcDiagnosticCode "TcRnPatSynBundledWithWrongType"                = 66025   GhcDiagnosticCode "TcRnDupeModuleExport"                          = 51876@@ -398,26 +506,25 @@   GhcDiagnosticCode "TcRnNullExportedModule"                        = 64649   GhcDiagnosticCode "TcRnMissingExportList"                         = 85401   GhcDiagnosticCode "TcRnExportHiddenComponents"                    = 94558+  GhcDiagnosticCode "TcRnExportHiddenDefault"                       = 74775   GhcDiagnosticCode "TcRnDuplicateExport"                           = 47854+  GhcDiagnosticCode "TcRnDuplicateNamedDefaultExport"               = 31584   GhcDiagnosticCode "TcRnExportedParentChildMismatch"               = 88993   GhcDiagnosticCode "TcRnConflictingExports"                        = 69158-  GhcDiagnosticCode "TcRnAmbiguousField"                            = 02256+  GhcDiagnosticCode "TcRnDuplicateFieldExport"                      = 97219+  GhcDiagnosticCode "TcRnAmbiguousFieldInUpdate"                    = 56428+  GhcDiagnosticCode "TcRnAmbiguousRecordUpdate"                     = 02256   GhcDiagnosticCode "TcRnMissingFields"                             = 20125   GhcDiagnosticCode "TcRnFieldUpdateInvalidType"                    = 63055-  GhcDiagnosticCode "TcRnNoConstructorHasAllFields"                 = 14392-  GhcDiagnosticCode "TcRnMixedSelectors"                            = 40887   GhcDiagnosticCode "TcRnMissingStrictFields"                       = 95909-  GhcDiagnosticCode "TcRnNoPossibleParentForFields"                 = 33238-  GhcDiagnosticCode "TcRnBadOverloadedRecordUpdate"                 = 99339   GhcDiagnosticCode "TcRnStaticFormNotClosed"                       = 88431+  GhcDiagnosticCode "TcRnIllegalStaticExpression"                   = 23800   GhcDiagnosticCode "TcRnUselessTypeable"                           = 90584   GhcDiagnosticCode "TcRnDerivingDefaults"                          = 20042   GhcDiagnosticCode "TcRnNonUnaryTypeclassConstraint"               = 73993   GhcDiagnosticCode "TcRnPartialTypeSignatures"                     = 60661   GhcDiagnosticCode "TcRnLazyGADTPattern"                           = 87005   GhcDiagnosticCode "TcRnArrowProcGADTPattern"                      = 64525-  GhcDiagnosticCode "TcRnSpecialClassInst"                          = 97044-  GhcDiagnosticCode "TcRnForallIdentifier"                          = 64088   GhcDiagnosticCode "TcRnTypeEqualityOutOfScope"                    = 12003   GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators"             = 58520   GhcDiagnosticCode "TcRnIllegalTypeOperator"                       = 62547@@ -425,18 +532,20 @@   GhcDiagnosticCode "TcRnIncorrectNameSpace"                        = 31891   GhcDiagnosticCode "TcRnNoRebindableSyntaxRecordDot"               = 65945   GhcDiagnosticCode "TcRnNoFieldPunsRecordDot"                      = 57365-  GhcDiagnosticCode "TcRnIllegalStaticExpression"                   = 23800-  GhcDiagnosticCode "TcRnIllegalStaticFormInSplice"                 = 12219   GhcDiagnosticCode "TcRnListComprehensionDuplicateBinding"         = 81232   GhcDiagnosticCode "TcRnLastStmtNotExpr"                           = 55814   GhcDiagnosticCode "TcRnUnexpectedStatementInContext"              = 42026   GhcDiagnosticCode "TcRnSectionWithoutParentheses"                 = 95880   GhcDiagnosticCode "TcRnIllegalImplicitParameterBindings"          = 50730   GhcDiagnosticCode "TcRnIllegalTupleSection"                       = 59155+  GhcDiagnosticCode "TcRnTermNameInType"                            = 37479+  GhcDiagnosticCode "TcRnUnexpectedKindVar"                         = 12875+  GhcDiagnosticCode "TcRnNegativeNumTypeLiteral"                    = 93632+  GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar"                   = 54180+  GhcDiagnosticCode "TcRnMissingRoleAnnotation"                     = 65490    GhcDiagnosticCode "TcRnUntickedPromotedThing"                     = 49957   GhcDiagnosticCode "TcRnIllegalBuiltinSyntax"                      = 39716-  GhcDiagnosticCode "TcRnWarnDefaulting"                            = 18042   GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet"                = 49692   GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn"                  = 26133   GhcDiagnosticCode "TcRnForeignFunctionImportAsValue"              = 76251@@ -445,65 +554,192 @@   GhcDiagnosticCode "TcRnUnsupportedCallConv"                       = 01245   GhcDiagnosticCode "TcRnInvalidCIdentifier"                        = 95774   GhcDiagnosticCode "TcRnExpectedValueId"                           = 01570-  GhcDiagnosticCode "TcRnNotARecordSelector"                        = 47535   GhcDiagnosticCode "TcRnRecSelectorEscapedTyVar"                   = 55876   GhcDiagnosticCode "TcRnPatSynNotBidirectional"                    = 16444-  GhcDiagnosticCode "TcRnSplicePolymorphicLocalVar"                 = 06568   GhcDiagnosticCode "TcRnIllegalDerivingItem"                       = 11913   GhcDiagnosticCode "TcRnUnexpectedAnnotation"                      = 18932   GhcDiagnosticCode "TcRnIllegalRecordSyntax"                       = 89246-  GhcDiagnosticCode "TcRnUnexpectedTypeSplice"                      = 39180   GhcDiagnosticCode "TcRnInvalidVisibleKindArgument"                = 20967   GhcDiagnosticCode "TcRnTooManyBinders"                            = 05989   GhcDiagnosticCode "TcRnDifferentNamesForTyVar"                    = 17370   GhcDiagnosticCode "TcRnDisconnectedTyVar"                         = 59738   GhcDiagnosticCode "TcRnInvalidReturnKind"                         = 55233   GhcDiagnosticCode "TcRnClassKindNotConstraint"                    = 80768-  GhcDiagnosticCode "TcRnUnpromotableThing"                         = 88634   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   GhcDiagnosticCode "TcRnSpecialiseNotVisible"                      = 85337+  GhcDiagnosticCode "TcRnDifferentExportWarnings"                   = 92878+  GhcDiagnosticCode "TcRnIncompleteExportWarnings"                  = 94721   GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl"                   = 50649-  GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = 40027-  GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = 69639+  GhcDiagnosticCode "TcRnOrPatBindsVariables"                       = 81303+  GhcDiagnosticCode "TcRnIllegalKind"                               = 64861+  GhcDiagnosticCode "TcRnUnexpectedPatSigType"                      = 74097+  GhcDiagnosticCode "TcRnIllegalKindSignature"                      = 91382+  GhcDiagnosticCode "TcRnDataKindsError"                            = 68567    GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods"                 = 93006+  GhcDiagnosticCode "TcRnHsigFixityMismatch"                        = 93007+  GhcDiagnosticCode "TcRnHsigMissingModuleExport"                   = 93011   GhcDiagnosticCode "TcRnBadGenericMethod"                          = 59794   GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete"               = 13511   GhcDiagnosticCode "TcRnDefaultMethodForPragmaLacksBinding"        = 28587   GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod"         = 72520   GhcDiagnosticCode "TcRnBadMethodErr"                              = 46284-  GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration"   = 08585   GhcDiagnosticCode "TcRnIllegalTypeData"                           = 15013   GhcDiagnosticCode "TcRnTypeDataForbids"                           = 67297-  GhcDiagnosticCode "TcRnTypedTHWithPolyType"                       = 94642-  GhcDiagnosticCode "TcRnSpliceThrewException"                      = 87897-  GhcDiagnosticCode "TcRnInvalidTopDecl"                            = 52886-  GhcDiagnosticCode "TcRnNonExactName"                              = 77923-  GhcDiagnosticCode "TcRnAddInvalidCorePlugin"                      = 86463-  GhcDiagnosticCode "TcRnAddDocToNonLocalDefn"                      = 67760-  GhcDiagnosticCode "TcRnFailedToLookupThInstName"                  = 49530-  GhcDiagnosticCode "TcRnCannotReifyInstance"                       = 30384-  GhcDiagnosticCode "TcRnCannotReifyOutOfScopeThing"                = 24922-  GhcDiagnosticCode "TcRnCannotReifyThingNotInTypeEnv"              = 79890-  GhcDiagnosticCode "TcRnNoRolesAssociatedWithThing"                = 65923-  GhcDiagnosticCode "TcRnCannotRepresentType"                       = 75721-  GhcDiagnosticCode "TcRnReportCustomQuasiError"                    = 39584-  GhcDiagnosticCode "TcRnInterfaceLookupError"                      = 52243   GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef"                     = 06201   GhcDiagnosticCode "TcRnMisplacedInstSig"                          = 06202-  GhcDiagnosticCode "TcRnBadBootFamInstDecl"                        = 06203-  GhcDiagnosticCode "TcRnIllegalFamilyInstance"                     = 06204-  GhcDiagnosticCode "TcRnMissingClassAssoc"                         = 06205-  GhcDiagnosticCode "TcRnBadFamInstDecl"                            = 06206-  GhcDiagnosticCode "TcRnNotOpenFamily"                             = 06207-  GhcDiagnosticCode "TcRnLoopySuperclassSolve"                      = 36038+  GhcDiagnosticCode "TcRnCapturedTermName"                          = 54201+  GhcDiagnosticCode "TcRnBindingOfExistingName"                     = 58805+  GhcDiagnosticCode "TcRnMultipleFixityDecls"                       = 50419+  GhcDiagnosticCode "TcRnIllegalPatternSynonymDecl"                 = 41507+  GhcDiagnosticCode "TcRnIllegalClassBinding"                       = 69248+  GhcDiagnosticCode "TcRnOrphanCompletePragma"                      = 93961+  GhcDiagnosticCode "TcRnEmptyCase"                                 = 48010+  GhcDiagnosticCode "TcRnNonStdGuards"                              = 59119+  GhcDiagnosticCode "TcRnDuplicateSigDecl"                          = 31744+  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+  GhcDiagnosticCode "TcRnIllegalMultipleDerivClauses"               = 30281+  GhcDiagnosticCode "TcRnNoDerivStratSpecified"                     = 55631+  GhcDiagnosticCode "TcRnStupidThetaInGadt"                         = 18403+  GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult"              = 99412+  GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond"              = 88333+  GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond"               = 48254+  GhcDiagnosticCode "TcRnBadlyLevelled"                             = 28914+  GhcDiagnosticCode "TcRnBadlyLevelledType"                         = 86357+  GhcDiagnosticCode "TcRnStageRestriction"                          = Outdated 18157+  GhcDiagnosticCode "TcRnTyThingUsedWrong"                          = 10969+  GhcDiagnosticCode "TcRnCannotDefaultKindVar"                      = 79924+  GhcDiagnosticCode "TcRnUninferrableTyVar"                         = 16220+  GhcDiagnosticCode "TcRnSkolemEscape"                              = 71451+  GhcDiagnosticCode "TcRnPatSynEscapedCoercion"                     = 88986+  GhcDiagnosticCode "TcRnPatSynExistentialInResult"                 = 33973+  GhcDiagnosticCode "TcRnPatSynArityMismatch"                       = 18365+  GhcDiagnosticCode "TcRnTyFamDepsDisabled"                         = 43991+  GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl"                   = 60012+  GhcDiagnosticCode "TcRnPartialFieldSelector"                      = 82712+  GhcDiagnosticCode "TcRnHasFieldResolvedIncomplete"                = 86894+  GhcDiagnosticCode "TcRnSuperclassCycle"                           = 29210+  GhcDiagnosticCode "TcRnDefaultSigMismatch"                        = 72771+  GhcDiagnosticCode "TcRnTyFamResultDisabled"                       = 44012+  GhcDiagnosticCode "TcRnCommonFieldResultTypeMismatch"             = 31004+  GhcDiagnosticCode "TcRnCommonFieldTypeMismatch"                   = 91827+  GhcDiagnosticCode "TcRnDataConParentTypeMismatch"                 = 45219+  GhcDiagnosticCode "TcRnGADTsDisabled"                             = 23894+  GhcDiagnosticCode "TcRnExistentialQuantificationDisabled"         = 25709+  GhcDiagnosticCode "TcRnGADTDataContext"                           = 61072+  GhcDiagnosticCode "TcRnMultipleConForNewtype"                     = 16409+  GhcDiagnosticCode "TcRnKindSignaturesDisabled"                    = 49378+  GhcDiagnosticCode "TcRnEmptyDataDeclsDisabled"                    = 32478+  GhcDiagnosticCode "TcRnRoleMismatch"                              = 29178+  GhcDiagnosticCode "TcRnRoleCountMismatch"                         = 54298+  GhcDiagnosticCode "TcRnIllegalRoleAnnotation"                     = 77192+  GhcDiagnosticCode "TcRnRoleAnnotationsDisabled"                   = 17779+  GhcDiagnosticCode "TcRnIncoherentRoles"                           = 18273+  GhcDiagnosticCode "TcRnTypeSynonymCycle"                          = 97522+  GhcDiagnosticCode "TcRnSelfImport"                                = 43281+  GhcDiagnosticCode "TcRnNoExplicitImportList"                      = 16029+  GhcDiagnosticCode "TcRnSafeImportsDisabled"                       = 26971+  GhcDiagnosticCode "TcRnDeprecatedModule"                          = 15328+  GhcDiagnosticCode "TcRnCompatUnqualifiedImport"                   = Outdated 82347+  GhcDiagnosticCode "TcRnRedundantSourceImport"                     = 54478+  GhcDiagnosticCode "TcRnDuplicateDecls"                            = 29916+  GhcDiagnosticCode "TcRnPackageImportsDisabled"                    = 10032+  GhcDiagnosticCode "TcRnIllegalDataCon"                            = 78448+  GhcDiagnosticCode "TcRnNestedForallsContexts"                     = 71492+  GhcDiagnosticCode "TcRnRedundantRecordWildcard"                   = 15932+  GhcDiagnosticCode "TcRnUnusedRecordWildcard"                      = 83475+  GhcDiagnosticCode "TcRnUnusedName"                                = 40910+  GhcDiagnosticCode "TcRnQualifiedBinder"                           = 28329+  GhcDiagnosticCode "TcRnInvalidRecordField"                        = 53822+  GhcDiagnosticCode "TcRnTupleTooLarge"                             = 94803+  GhcDiagnosticCode "TcRnCTupleTooLarge"                            = 89347+  GhcDiagnosticCode "TcRnIllegalInferredTyVars"                     = 54832+  GhcDiagnosticCode "TcRnAmbiguousName"                             = 87543+  GhcDiagnosticCode "TcRnBindingNameConflict"                       = 10498+  GhcDiagnosticCode "NonCanonicalMonoid"                            = 50928+  GhcDiagnosticCode "NonCanonicalMonad"                             = 22705+  GhcDiagnosticCode "TcRnDefaultedExceptionContext"                 = 46235+  GhcDiagnosticCode "TcRnImplicitImportOfPrelude"                   = 20540+  GhcDiagnosticCode "TcRnMissingMain"                               = 67120+  GhcDiagnosticCode "TcRnGhciUnliftedBind"                          = 17999+  GhcDiagnosticCode "TcRnGhciMonadLookupFail"                       = 44990+  GhcDiagnosticCode "TcRnArityMismatch"                             = 27346+  GhcDiagnosticCode "TcRnSimplifiableConstraint"                    = 62412+  GhcDiagnosticCode "TcRnIllegalQuasiQuotes"                        = 77343+  GhcDiagnosticCode "TcRnImplicitRhsQuantification"                 = 16382+  GhcDiagnosticCode "TcRnBadTyConTelescope"                         = 87279+  GhcDiagnosticCode "TcRnPatersonCondFailure"                       = 22979+  GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat"              = Outdated 69797+  GhcDiagnosticCode "TcRnInvalidDefaultedTyVar"                     = 45625+  GhcDiagnosticCode "TcRnIllegalTermLevelUse"                       = 01928+  GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag"        = 14995+  GhcDiagnosticCode "TcRnNamespacedFixitySigWithoutFlag"            = 78534+  GhcDiagnosticCode "TcRnOutOfArityTyVar"                           = 84925+  GhcDiagnosticCode "TcRnIllformedTypePattern"                      = 88754+  GhcDiagnosticCode "TcRnIllegalTypePattern"                        = 70206+  GhcDiagnosticCode "TcRnIllformedTypeArgument"                     = 29092+  GhcDiagnosticCode "TcRnIllegalTypeExpr"                           = 35499+  GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms"               = 31244+  GhcDiagnosticCode "TcRnTypeApplicationsDisabled"                  = 23482 +  -- TcRnIllegalInvisibleTypePattern+  GhcDiagnosticCode "InvisPatWithoutFlag"                           = 78249+  GhcDiagnosticCode "InvisPatNoForall"                              = 14964+  GhcDiagnosticCode "InvisPatMisplaced"                             = 11983++  -- PatSynInvalidRhsReason+  GhcDiagnosticCode "PatSynNotInvertible"                           = 69317+  GhcDiagnosticCode "PatSynUnboundVar"                              = 28572++  -- TcRnBadFieldAnnotation/BadFieldAnnotationReason+  GhcDiagnosticCode "LazyFieldsDisabled"                            = 81601+  GhcDiagnosticCode "UnpackWithoutStrictness"                       = 10107+  GhcDiagnosticCode "UnusableUnpackPragma"                          = 40091++  -- TcRnRoleValidationFailed/RoleInferenceFailedReason+  GhcDiagnosticCode "TyVarRoleMismatch"                             = 22221+  GhcDiagnosticCode "TyVarMissingInEnv"                             = 99991+  GhcDiagnosticCode "BadCoercionRole"                               = 92834++  -- TcRnClassExtensionDisabled/DisabledClassExtension+  GhcDiagnosticCode "MultiParamDisabled"                            = 28349+  GhcDiagnosticCode "FunDepsDisabled"                               = 15708+  GhcDiagnosticCode "ConstrainedClassMethodsDisabled"               = 25079++  -- TcRnTyFamsDisabled/TyFamsDisabledReason+  GhcDiagnosticCode "TyFamsDisabledFamily"                          = 39191+  GhcDiagnosticCode "TyFamsDisabledInstance"                        = 06206+  GhcDiagnosticCode "TcRnPrecedenceParsingError"                    = 88747+  GhcDiagnosticCode "TcRnSectionPrecedenceError"                    = 46878++  -- HsigShapeMismatchReason+  GhcDiagnosticCode "HsigShapeSortMismatch"                         = 93008+  GhcDiagnosticCode "HsigShapeNotUnifiable"                         = 93009++  -- Invisible binders+  GhcDiagnosticCode "TcRnIllegalInvisTyVarBndr"                     = 58589+  GhcDiagnosticCode "TcRnIllegalWildcardTyVarBndr"                  = 12211+  GhcDiagnosticCode "TcRnInvalidInvisTyVarBndr"                     = 57916+  GhcDiagnosticCode "TcRnInvisBndrWithoutSig"                       = 92337+   -- IllegalNewtypeReason   GhcDiagnosticCode "DoesNotHaveSingleField"                        = 23517   GhcDiagnosticCode "IsNonLinear"                                   = 38291@@ -512,6 +748,20 @@   GhcDiagnosticCode "HasExistentialTyVar"                           = 07525   GhcDiagnosticCode "HasStrictnessAnnotation"                       = 04049 +  -- TcRnBadRecordUpdate+  GhcDiagnosticCode "NoConstructorHasAllFields"                     = 14392+  GhcDiagnosticCode "MultiplePossibleParents"                       = 99339+  GhcDiagnosticCode "InvalidTyConParent"                            = 33238++  -- BadImport+  GhcDiagnosticCode "BadImportNotExported"                          = 61689+  GhcDiagnosticCode "BadImportAvailDataCon"                         = 35373+  GhcDiagnosticCode "BadImportNotExportedSubordinates"              = 10237+  GhcDiagnosticCode "BadImportNonTypeSubordinates"                  = 51433+  GhcDiagnosticCode "BadImportNonDataSubordinates"                  = 46557+  GhcDiagnosticCode "BadImportAvailTyCon"                           = 56449+  GhcDiagnosticCode "BadImportAvailVar"                             = 12112+   -- TcRnPragmaWarning   GhcDiagnosticCode "WarningTxt"                                    = 63394   GhcDiagnosticCode "DeprecatedTxt"                                 = 68441@@ -539,7 +789,65 @@   GhcDiagnosticCode "InvalidImplicitParamBinding"                   = 51603   GhcDiagnosticCode "DefaultDataInstDecl"                           = 39639   GhcDiagnosticCode "FunBindLacksEquations"                         = 52078+  GhcDiagnosticCode "EmptyGuard"                                    = 45149+  GhcDiagnosticCode "EmptyParStmt"                                  = 95595 +  -- TcRnDodgyImports/DodgyImportsReason+  GhcDiagnosticCode "DodgyImportsEmptyParent"                       = 99623++  -- TcRnImportLookup/ImportLookupReason+  GhcDiagnosticCode "ImportLookupQualified"                         = 48795+  GhcDiagnosticCode "ImportLookupIllegal"                           = 14752+  GhcDiagnosticCode "ImportLookupAmbiguous"                         = 92057++  -- TcRnUnusedImport/UnusedImportReason+  GhcDiagnosticCode "UnusedImportNone"                              = 66111+  GhcDiagnosticCode "UnusedImportSome"                              = 38856++  -- TcRnIllegalInstance+  GhcDiagnosticCode "IllegalFamilyApplicationInInstance"            = 73138++  -- TcRnIllegalClassInstance/IllegalClassInstanceReason+  GhcDiagnosticCode "IllegalSpecialClassInstance"                   = 97044+  GhcDiagnosticCode "IllegalInstanceFailsCoverageCondition"         = 21572++    -- IllegalInstanceHead+  GhcDiagnosticCode "InstHeadAbstractClass"                         = 51758+  GhcDiagnosticCode "InstHeadNonClassHead"                          = 53946+  GhcDiagnosticCode "InstHeadTySynArgs"                             = 93557+  GhcDiagnosticCode "InstHeadNonTyVarArgs"                          = 48406+  GhcDiagnosticCode "InstHeadMultiParam"                            = 91901++    -- IllegalHasFieldInstance+  GhcDiagnosticCode "IllegalHasFieldInstanceNotATyCon"              = 88994+  GhcDiagnosticCode "IllegalHasFieldInstanceFamilyTyCon"            = 70743+  GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasFields"         = 43406+  GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasField"          = 30836++  -- TcRnIllegalFamilyInstance/IllegalFamilyInstanceReason+  GhcDiagnosticCode "NotAFamilyTyCon"                               = 06204+  GhcDiagnosticCode "NotAnOpenFamilyTyCon"                          = 06207+  GhcDiagnosticCode "FamilyCategoryMismatch"                        = 52347+  GhcDiagnosticCode "FamilyArityMismatch"                           = 12985+  GhcDiagnosticCode "TyFamNameMismatch"                             = 88221+  GhcDiagnosticCode "FamInstRHSOutOfScopeTyVars"                    = 53634+  GhcDiagnosticCode "FamInstLHSUnusedBoundTyVars"                   = 30337++    -- InvalidAssocInstance+  GhcDiagnosticCode "AssocInstanceMissing"                          = 08585+  GhcDiagnosticCode "AssocInstanceNotInAClass"                      = 06205+  GhcDiagnosticCode "AssocNotInThisClass"                           = 38351+  GhcDiagnosticCode "AssocNoClassTyVar"                             = 55912+  GhcDiagnosticCode "AssocTyVarsDontMatch"                          = 95424++    -- InvalidAssocDefault+  GhcDiagnosticCode "AssocDefaultNotAssoc"                          = 78822+  GhcDiagnosticCode "AssocMultipleDefaults"                         = 59128++    -- AssocDefaultBadArgs+  GhcDiagnosticCode "AssocDefaultNonTyVarArg"                       = 41522+  GhcDiagnosticCode "AssocDefaultDuplicateTyVars"                   = 48178+   -- Diagnostic codes for the foreign function interface   GhcDiagnosticCode "NotADataType"                                  = 31136   GhcDiagnosticCode "NewtypeDataConNotInScope"                      = 72317@@ -556,13 +864,32 @@   GhcDiagnosticCode "OneArgExpected"                                = 91490   GhcDiagnosticCode "AtLeastOneArgExpected"                         = 07641 +  -- Interface errors+  GhcDiagnosticCode "BadSourceImport"                               = 64852+  GhcDiagnosticCode "HomeModError"                                  = 58427+  GhcDiagnosticCode "DynamicHashMismatchError"                      = 54709+  GhcDiagnosticCode "CouldntFindInFiles"                            = 94559+  GhcDiagnosticCode "GenericMissing"                                = 87110+  GhcDiagnosticCode "MissingPackageFiles"                           = 22211+  GhcDiagnosticCode "MissingPackageWayFiles"                        = 88719+  GhcDiagnosticCode "ModuleSuggestion"                              = 61948+  GhcDiagnosticCode "MultiplePackages"                              = 45102+  GhcDiagnosticCode "NoUnitIdMatching"                              = 51294+  GhcDiagnosticCode "NotAModule"                                    = 35235+  GhcDiagnosticCode "Can'tFindNameInInterface"                      = 83249+  GhcDiagnosticCode "CircularImport"                                = 75429+  GhcDiagnosticCode "HiModuleNameMismatchWarn"                      = 53693+  GhcDiagnosticCode "ExceptionOccurred"                             = 47808+   -- Out of scope errors   GhcDiagnosticCode "NotInScope"                                    = 76037+  GhcDiagnosticCode "NotARecordField"                               = 22385   GhcDiagnosticCode "NoExactName"                                   = 97784   GhcDiagnosticCode "SameName"                                      = 81573   GhcDiagnosticCode "MissingBinding"                                = 44432   GhcDiagnosticCode "NoTopLevelBinding"                             = 10173   GhcDiagnosticCode "UnknownSubordinate"                            = 54721+  GhcDiagnosticCode "NotInScopeTc"                                  = 76329    -- Diagnostic codes for deriving   GhcDiagnosticCode "DerivErrNotWellKinded"                         = 62016@@ -593,24 +920,100 @@   GhcDiagnosticCode "DerivErrGenerics"                              = 30367   GhcDiagnosticCode "DerivErrEnumOrProduct"                         = 58291 +  -- Diagnostic codes for instance lookup+  GhcDiagnosticCode "LookupInstErrNotExact"                         = 10372+  GhcDiagnosticCode "LookupInstErrFlexiVar"                         = 10373+  GhcDiagnosticCode "LookupInstErrNotFound"                         = 10374++  -- Diagnostic codes for default declarations and type defaulting+  GhcDiagnosticCode "TcRnMultipleDefaultDeclarations"               = 99565+  GhcDiagnosticCode "TcRnIllegalDefaultClass"                       = 26555+  GhcDiagnosticCode "TcRnIllegalNamedDefault"                       = 55756+  GhcDiagnosticCode "TcRnBadDefaultType"                            = 88933+  GhcDiagnosticCode "TcRnWarnDefaulting"                            = 18042+  GhcDiagnosticCode "TcRnWarnClashingDefaultImports"                = 77007+   -- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason   GhcDiagnosticCode "EmptyStmtsGroupInParallelComp"                 = 41242   GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp"            = 92693   GhcDiagnosticCode "EmptyStmtsGroupInDoNotation"                   = 82311   GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation"                = 19442 -  GhcDiagnosticCode "TcRnCannotDefaultConcrete"                     = 52083+  -- HsBoot and Hsig errors+  GhcDiagnosticCode "MissingBootDefinition"                         = 63610+  GhcDiagnosticCode "MissingBootExport"                             = 91999+  GhcDiagnosticCode "MissingBootInstance"                           = 79857+  GhcDiagnosticCode "BadReexportedBootThing"                        = 12424+  GhcDiagnosticCode "BootMismatchedIdTypes"                         = 11890+  GhcDiagnosticCode "BootMismatchedTyCons"                          = 15843 +  -- TH errors+  GhcDiagnosticCode "TypedTHWithPolyType"                           = 94642+  GhcDiagnosticCode "SplicePolymorphicLocalVar"                     = 06568+  GhcDiagnosticCode "SpliceThrewException"                          = 87897+  GhcDiagnosticCode "InvalidTopDecl"                                = 52886+  GhcDiagnosticCode "NonExactName"                                  = 77923+  GhcDiagnosticCode "AddInvalidCorePlugin"                          = 86463+  GhcDiagnosticCode "AddDocToNonLocalDefn"                          = 67760+  GhcDiagnosticCode "FailedToLookupThInstName"                      = 49530+  GhcDiagnosticCode "CannotReifyInstance"                           = 30384+  GhcDiagnosticCode "CannotReifyOutOfScopeThing"                    = 24922+  GhcDiagnosticCode "CannotReifyThingNotInTypeEnv"                  = 79890+  GhcDiagnosticCode "NoRolesAssociatedWithThing"                    = 65923+  GhcDiagnosticCode "CannotRepresentType"                           = 75721+  GhcDiagnosticCode "ReportCustomQuasiError"                        = 39584+  GhcDiagnosticCode "MismatchedSpliceType"                          = 45108+  GhcDiagnosticCode "IllegalTHQuotes"                               = 62558+  GhcDiagnosticCode "IllegalTHSplice"                               = 26759+  GhcDiagnosticCode "NestedTHBrackets"                              = 59185+  GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice"        = 17599+  GhcDiagnosticCode "BadImplicitSplice"                             = 25277+  GhcDiagnosticCode "QuotedNameWrongStage"                          = Outdated 57695+  GhcDiagnosticCode "IllegalStaticFormInSplice"                     = 12219++  -- Zonker messages+  GhcDiagnosticCode "ZonkerCannotDefaultConcrete"                   = 52083++  -- Promotion errors+  GhcDiagnosticCode "ClassPE"                                       = 86934+  GhcDiagnosticCode "TyConPE"                                       = 85413+  GhcDiagnosticCode "PatSynPE"                                      = 70349+  GhcDiagnosticCode "FamDataConPE"                                  = 64578+  GhcDiagnosticCode "ConstrainedDataConPE"                          = 28374+  GhcDiagnosticCode "RecDataConPE"                                  = 56753+  GhcDiagnosticCode "TermVariablePE"                                = 45510+  GhcDiagnosticCode "TypeVariablePE"                                = 47557+   -- To generate new random numbers:   --  https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain   --   -- 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 "Example outdated error"                        = 00000+  GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = Outdated 12222+  GhcDiagnosticCode "TcRnNoClassInstHead"                           = Outdated 56538+    -- The above two are subsumed by InstHeadNonClassHead [GHC-53946] +  GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = Outdated 40027+  GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = Outdated 69639+  GhcDiagnosticCode "TcRnMixedSelectors"                            = Outdated 40887+  GhcDiagnosticCode "TcRnBadBootFamInstDecl"                        = Outdated 06203+  GhcDiagnosticCode "TcRnBindInBootFile"                            = Outdated 11247+  GhcDiagnosticCode "TcRnUnexpectedTypeSplice"                      = Outdated 39180+  GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl"                  = Outdated 45054+  GhcDiagnosticCode "TcRnUnpromotableThing"                         = Outdated 88634+  GhcDiagnosticCode "UntouchableVariable"                           = Outdated 34699+  GhcDiagnosticCode "TcRnBindVarAlreadyInScope"                     = Outdated 69710+  GhcDiagnosticCode "TcRnBindMultipleVariables"                     = Outdated 92957+  GhcDiagnosticCode "TcRnHsigNoIface"                               = Outdated 93010+  GhcDiagnosticCode "TcRnInterfaceLookupError"                      = Outdated 52243+  GhcDiagnosticCode "TcRnForallIdentifier"                          = Outdated 64088+  GhcDiagnosticCode "TypeApplicationInPattern"                      = Outdated 17916+ {- ********************************************************************* *                                                                      *                  Recurring into an argument@@ -636,24 +1039,38 @@   ConRecursInto "GhcPsMessage"             = 'Just PsMessage   ConRecursInto "GhcTcRnMessage"           = 'Just TcRnMessage   ConRecursInto "GhcDsMessage"             = 'Just DsMessage-  ConRecursInto "GhcUnknownMessage"        = 'Just UnknownDiagnostic+  ConRecursInto "GhcUnknownMessage"        = 'Just (UnknownDiagnosticFor GhcMessage)    ----------------------------------   -- Constructors of DriverMessage -  ConRecursInto "DriverUnknownMessage"     = 'Just UnknownDiagnostic+  ConRecursInto "DriverUnknownMessage"     = 'Just (UnknownDiagnosticFor DriverMessage)   ConRecursInto "DriverPsHeaderMessage"    = 'Just PsMessage+  ConRecursInto "DriverInterfaceError"     = 'Just IfaceMessage +  ConRecursInto "CantFindErr"              = 'Just CantFindInstalled+  ConRecursInto "CantFindInstalledErr"     = 'Just CantFindInstalled++  ConRecursInto "CantFindInstalled"        = 'Just CantFindInstalledReason++  ConRecursInto "BadIfaceFile"                 = 'Just ReadInterfaceError+  ConRecursInto "FailedToLoadDynamicInterface" = 'Just ReadInterfaceError+   ----------------------------------   -- Constructors of PsMessage -  ConRecursInto "PsUnknownMessage"         = 'Just UnknownDiagnostic+  ConRecursInto "PsUnknownMessage"         = 'Just (UnknownDiagnosticFor PsMessage)   ConRecursInto "PsHeaderMessage"          = 'Just PsHeaderMessage    ----------------------------------+  -- Constructors of DsMessage++  ConRecursInto "DsUselessSpecialisePragma" = 'Just UselessSpecialisePragmaReason++  ----------------------------------   -- Constructors of TcRnMessage -  ConRecursInto "TcRnUnknownMessage"       = 'Just UnknownDiagnostic+  ConRecursInto "TcRnUnknownMessage"       = 'Just (UnknownDiagnosticFor TcRnMessage)      -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage   ConRecursInto "TcRnMessageWithInfo"      = 'Just TcRnMessageDetailed@@ -661,16 +1078,67 @@   ConRecursInto "TcRnWithHsDocContext"     = 'Just TcRnMessage    ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason+  ConRecursInto "TcRnLookupInstance"       = 'Just LookupInstanceErrReason   ConRecursInto "TcRnPragmaWarning"        = 'Just (WarningTxt GhcRn)   ConRecursInto "TcRnNotInScope"           = 'Just NotInScopeError   ConRecursInto "TcRnIllegalNewtype"       = 'Just IllegalNewtypeReason+  ConRecursInto "TcRnHsigShapeMismatch"    = 'Just HsigShapeMismatchReason+  ConRecursInto "TcRnPatSynInvalidRhs"     = 'Just PatSynInvalidRhsReason+  ConRecursInto "TcRnBadRecordUpdate"      = 'Just BadRecordUpdateReason+  ConRecursInto "TcRnBadFieldAnnotation"   = 'Just BadFieldAnnotationReason+  ConRecursInto "TcRnRoleValidationFailed" = 'Just RoleValidationFailedReason+  ConRecursInto "TcRnClassExtensionDisabled" = 'Just DisabledClassExtension+  ConRecursInto "TcRnTyFamsDisabled"       = 'Just TyFamsDisabledReason+  ConRecursInto "TcRnDodgyImports"         = 'Just DodgyImportsReason+  ConRecursInto "DodgyImportsHiding"       = 'Just ImportLookupReason+  ConRecursInto "TcRnImportLookup"         = 'Just ImportLookupReason+  ConRecursInto "TcRnUnusedImport"         = 'Just UnusedImportReason+  ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition+  ConRecursInto "TcRnIllegalInstance"        = 'Just IllegalInstanceReason+  ConRecursInto "TcRnIllegalInvisibleTypePattern" = 'Just BadInvisPatReason +    -- Illegal instance reasons+  ConRecursInto "IllegalClassInstance"        = 'Just IllegalClassInstanceReason+  ConRecursInto "IllegalFamilyInstance"       = 'Just IllegalFamilyInstanceReason++      -- Illegal class instance reasons++  ConRecursInto "IllegalInstanceHead"         = 'Just IllegalInstanceHeadReason+  ConRecursInto "IllegalHasFieldInstance"     = 'Just IllegalHasFieldInstance++      -- Illegal family instance reasons++  ConRecursInto "InvalidAssoc"                = 'Just InvalidAssoc+  ConRecursInto "InvalidAssocInstance"        = 'Just InvalidAssocInstance+  ConRecursInto "InvalidAssocDefault"         = 'Just InvalidAssocDefault+  ConRecursInto "AssocDefaultBadArgs"         = 'Just AssocDefaultBadArgs+     --     -- TH errors+  ConRecursInto "TcRnTHError"                 = 'Just THError+  ConRecursInto "THSyntaxError"               = 'Just THSyntaxError+  ConRecursInto "THNameError"                 = 'Just THNameError+  ConRecursInto "THReifyError"                = 'Just THReifyError+  ConRecursInto "TypedTHError"                = 'Just TypedTHError+  ConRecursInto "THSpliceFailed"              = 'Just SpliceFailReason+  ConRecursInto "RunSpliceFailure"            = 'Just RunSpliceFailReason+  ConRecursInto "ConversionFail"              = 'Just ConversionFailReason+  ConRecursInto "AddTopDeclsError"            = 'Just AddTopDeclsError+  ConRecursInto "AddTopDeclsRunSpliceFailure" = 'Just RunSpliceFailReason -  ConRecursInto "TcRnRunSpliceFailure"     = 'Just RunSpliceFailReason-  ConRecursInto "ConversionFail"           = 'Just ConversionFailReason+    -- Interface file errors +  ConRecursInto "TcRnInterfaceError"       = 'Just IfaceMessage+  ConRecursInto "Can'tFindInterface"       = 'Just MissingInterfaceError++    -- HsBoot and Hsig errors+  ConRecursInto "TcRnBootMismatch"         = 'Just BootMismatch+  ConRecursInto "MissingBootThing"         = 'Just MissingBootThing+  ConRecursInto "BootMismatch"             = 'Just BootMismatchWhat++    -- Zonker errors+  ConRecursInto "TcRnZonkerMessage"        = 'Just ZonkerMessage+     ------------------     -- FFI errors @@ -697,9 +1165,14 @@   ----------------------------------   -- Constructors of DsMessage -  ConRecursInto "DsUnknownMessage"         = 'Just UnknownDiagnostic+  ConRecursInto "DsUnknownMessage"         = 'Just (UnknownDiagnosticFor DsMessage)    ----------------------------------+  -- Constructors of ImportLookupBad+  ConRecursInto "ImportLookupBad"          = 'Just BadImportKind++  ConRecursInto "TcRnUnpromotableThing"    = 'Just PromotionErr+  ----------------------------------   -- Any other constructors: don't recur, instead directly   -- use the constructor name for the error code. @@ -713,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). @@ -750,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 (**).-    - (*) recurs 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 @@ -758,59 +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 -> 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-instance KnownConstructor con => ConstructorCode con f 'Nothing where-  gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#+type ConstructorCodes :: Type -> Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint+class ConstructorCodes namespace con f seen recur where+  gconstructorCodes :: Map DiagnosticCode String  -- If we recur into the 'UnknownDiagnostic' existential datatype, -- unwrap the existential and obtain the error code. instance {-# OVERLAPPING #-}-         ( ConRecursInto con ~ 'Just UnknownDiagnostic-         , HasType UnknownDiagnostic con f )-      => ConstructorCode con f ('Just UnknownDiagnostic) where-  gconstructorCode diag = case getType @UnknownDiagnostic @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 #-}+         ( 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 = constructorCode (getType @ty @con @f diag)+-- | (*) 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#) --- (**) 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)-      => GDiagnosticCode (M1 i ('MetaCons con x y) f) where-  gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x+-- | (**) 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 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 @namespace @(Insert ty seen) @(Rep ty) +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 (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 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.@@ -837,31 +1343,75 @@   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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When traversing through the Generic representation of a datatype to compute all+of the corresponding error codes, we need to keep track of types we have already+seen in order to avoid a runtime loop.++For example, TcRnMessage is defined recursively in terms of itself:++  data TcRnMessage where+    ...+    TcRnMessageWithInfo :: !UnitState+                        -> !TcRnMessageDetailed -- contains a TcRnMessage+                        -> TcRnMessage++If we naively computed the collection of error codes, we would get a computation+of the form++  diagnosticCodes @TcRnMessage = ... `Map.union` constructorCodes "TcRnMessageWithInfo"+  constructorCodes "TcRnMessageWithInfo" = diagnosticCodes @TcRnMessage++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 (**)).++Note that 'constructorCodes' starts by marking the initial type itself as "seen",+which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'.+-}++type Seen :: [Type] -> Type -> Constraint+class Seen seen ty where+  wasSeen :: Bool+instance Seen '[] ty where+  wasSeen = False+instance {-# OVERLAPPING #-} Seen (ty ': tys) ty where+  wasSeen = True+instance Seen tys ty => Seen (ty' ': tys) ty where+  wasSeen = wasSeen @tys @ty++type Insert :: Type -> [Type] -> [Type]+type family Insert ty tys where+  Insert ty '[] = '[ty]+  Insert ty (ty ': tys) = ty ': tys+  Insert ty (ty' ': tys) = ty' ': Insert ty tys+ {- ********************************************************************* *                                                                      *                Custom type errors for diagnostic codes@@ -875,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/FieldLabel.hs view
@@ -10,7 +10,6 @@  Note [FieldLabel] ~~~~~~~~~~~~~~~~~- This module defines the representation of FieldLabels as stored in TyCons.  As well as a selector name, these have some extra structure to support the DuplicateRecordFields and NoFieldSelectors extensions.@@ -22,60 +21,25 @@  has -    FieldLabel { flLabel                    = "foo"-               , flHasDuplicateRecordFields = NoDuplicateRecordFields+    FieldLabel { flHasDuplicateRecordFields = NoDuplicateRecordFields                , flHasFieldSelector         = FieldSelectors                , flSelector                 = foo }. -In particular, the Name of the selector has the same string-representation as the label.  If DuplicateRecordFields-is enabled, however, the same declaration instead gives+If DuplicateRecordFields is enabled, however, the same declaration instead gives -    FieldLabel { flLabel                    = "foo"-               , flHasDuplicateRecordFields = DuplicateRecordFields+    FieldLabel { flHasDuplicateRecordFields = DuplicateRecordFields                , flHasFieldSelector         = FieldSelectors-               , flSelector                 = $sel:foo:MkT }.--Similarly, the selector name will be mangled if NoFieldSelectors is used-(whether or not DuplicateRecordFields is enabled).  See Note [NoFieldSelectors]-in GHC.Rename.Env.--Now the name of the selector ($sel:foo:MkT) does not match the label of-the field (foo).  We must be careful not to show the selector name to-the user!  The point of mangling the selector name is to allow a-module to define the same field label in different datatypes:--    data T = MkT { foo :: Int }-    data U = MkU { foo :: Bool }--Now there will be two FieldLabel values for 'foo', one in T and one in-U.  They share the same label (FieldLabelString), but the selector-functions differ.--See also Note [Representing fields in AvailInfo] in GHC.Types.Avail.--Note [Why selector names include data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--As explained above, a selector name includes the name of the first-data constructor in the type, so that the same label can appear-multiple times in the same module.  (This is irrespective of whether-the first constructor has that field, for simplicity.)--We use a data constructor name, rather than the type constructor name,-because data family instances do not have a representation type-constructor name generated until relatively late in the typechecking-process.--Of course, datatypes with no constructors cannot have any fields.+               , flSelector                 = foo }. +We need to keep track of whether FieldSelectors or DuplicateRecordFields were+enabled when a record field was defined, as they affect name resolution and+shadowing of record fields, as explained in Note [NoFieldSelectors] in GHC.Types.Name.Reader+and Note [Reporting duplicate local declarations] in GHC.Rename.Names. -}  module GHC.Types.FieldLabel    ( FieldLabelEnv-   , FieldLabel(..)-   , fieldSelectorOccName-   , fieldLabelPrintableName+   , FieldLabel(..), flLabel    , DuplicateRecordFields(..)    , FieldSelectors(..)    , flIsOverloaded@@ -84,10 +48,8 @@  import GHC.Prelude -import {-# SOURCE #-} GHC.Types.Name.Occurrence import {-# SOURCE #-} GHC.Types.Name -import GHC.Data.FastString import GHC.Data.FastString.Env import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable@@ -104,20 +66,23 @@  -- | Fields in an algebraic record type; see Note [FieldLabel]. data FieldLabel = FieldLabel {-      flLabel :: FieldLabelString,-      -- ^ User-visible label of the field       flHasDuplicateRecordFields :: DuplicateRecordFields,       -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype?       flHasFieldSelector :: FieldSelectors,       -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype?       -- See Note [NoFieldSelectors] in GHC.Rename.Env       flSelector :: Name-      -- ^ Record selector function+      -- ^ The 'Name' of the selector function, which uniquely identifies+      -- the field label.     }   deriving (Data, Eq) +-- | User-visible label of a field.+flLabel :: FieldLabel -> FieldLabelString+flLabel = FieldLabelString . occNameFS . nameOccName . flSelector+ instance HasOccName FieldLabel where-  occName = mkVarOccFS . field_label . flLabel+  occName = nameOccName . flSelector  instance Outputable FieldLabel where     ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))@@ -130,14 +95,11 @@ instance Uniquable FieldLabelString where   getUnique (FieldLabelString fs) = getUnique fs -instance NFData FieldLabel where-  rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d- -- | Flag to indicate whether the DuplicateRecordFields extension is enabled. data DuplicateRecordFields     = DuplicateRecordFields   -- ^ Fields may be duplicated in a single module     | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default)-  deriving (Show, Eq, Typeable, Data)+  deriving (Show, Eq, Data)  instance Binary DuplicateRecordFields where     put_ bh f = put_ bh (f == DuplicateRecordFields)@@ -148,13 +110,15 @@     ppr NoDuplicateRecordFields = text "-dup"  instance NFData DuplicateRecordFields where-  rnf x = x `seq` ()+  rnf DuplicateRecordFields   = ()+  rnf NoDuplicateRecordFields = () + -- | Flag to indicate whether the FieldSelectors extension is enabled. data FieldSelectors     = FieldSelectors   -- ^ Selector functions are available (the default)     | NoFieldSelectors -- ^ Selector functions are not available-  deriving (Show, Eq, Typeable, Data)+  deriving (Show, Eq, Data)  instance Binary FieldSelectors where     put_ bh f = put_ bh (f == FieldSelectors)@@ -165,55 +129,25 @@     ppr NoFieldSelectors = text "-sel"  instance NFData FieldSelectors where-  rnf x = x `seq` ()+  rnf FieldSelectors   = ()+  rnf NoFieldSelectors = ()  -- | We need the @Binary Name@ constraint here even though there is an instance -- defined in "GHC.Types.Name", because the we have a SOURCE import, so the -- instance is not in scope.  And the instance cannot be added to Name.hs-boot -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". instance Binary Name => Binary FieldLabel where-    put_ bh (FieldLabel aa ab ac ad) = do-        put_ bh (field_label aa)+    put_ bh (FieldLabel aa ab ac) = do+        put_ bh aa         put_ bh ab         put_ bh ac-        put_ bh ad     get bh = do         aa <- get bh         ab <- get bh         ac <- get bh-        ad <- get bh-        return (FieldLabel (FieldLabelString aa) ab ac ad)----- | Record selector OccNames are built from the underlying field name--- and the name of the first data constructor of the type, to support--- duplicate record field names.--- See Note [Why selector names include data constructors].-fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName-fieldSelectorOccName lbl dc dup_fields_ok has_sel-  | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str-  | otherwise     = mkVarOccFS fl-  where-    fl      = field_label lbl-    str     = concatFS [fsLit ":", fl, fsLit ":", occNameFS dc]---- | Undo the name mangling described in Note [FieldLabel] to produce a Name--- that has the user-visible OccName (but the selector's unique).  This should--- be used only when generating output, when we want to show the label, but may--- need to qualify it with a module prefix.-fieldLabelPrintableName :: FieldLabel -> Name-fieldLabelPrintableName fl-  | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (field_label $ flLabel fl))-  | otherwise         = flSelector fl---- | Selector name mangling should be used if either DuplicateRecordFields or--- NoFieldSelectors is enabled, so that the OccName of the field can be used for--- something else.  See Note [FieldLabel], and Note [NoFieldSelectors] in--- GHC.Rename.Env.-shouldMangleSelectorNames :: DuplicateRecordFields -> FieldSelectors -> Bool-shouldMangleSelectorNames dup_fields_ok has_sel-    = dup_fields_ok == DuplicateRecordFields || has_sel == NoFieldSelectors+        return (FieldLabel aa ab ac)  flIsOverloaded :: FieldLabel -> Bool flIsOverloaded fl =-    shouldMangleSelectorNames (flHasDuplicateRecordFields fl) (flHasFieldSelector fl)+ flHasDuplicateRecordFields fl == DuplicateRecordFields+ || flHasFieldSelector fl == NoFieldSelectors
compiler/GHC/Types/Fixity.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances  -- | Fixity module GHC.Types.Fixity@@ -11,77 +12,28 @@    , negateFixity    , funTyFixity    , compareFixity+   , module GHC.Hs.Basic    ) where  import GHC.Prelude -import GHC.Types.SourceText--import GHC.Utils.Outputable-import GHC.Utils.Binary--import Data.Data hiding (Fixity, Prefix, Infix)--data Fixity = Fixity SourceText Int FixityDirection-  -- Note [Pragma source text]-  deriving Data--instance Outputable Fixity where-    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]--instance Eq Fixity where -- Used to determine if two fixities conflict-  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2--instance Binary Fixity where-    put_ bh (Fixity src aa ab) = do-            put_ bh src-            put_ bh aa-            put_ bh ab-    get bh = do-          src <- get bh-          aa <- get bh-          ab <- get bh-          return (Fixity src aa ab)+import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) )+import GHC.Hs.Basic () -- For instances only  -------------------------data FixityDirection-   = InfixL-   | InfixR-   | InfixN-   deriving (Eq, Data) -instance Outputable FixityDirection where-    ppr InfixL = text "infixl"-    ppr InfixR = text "infixr"-    ppr InfixN = text "infix"--instance Binary FixityDirection where-    put_ bh InfixL =-            putByte bh 0-    put_ bh InfixR =-            putByte bh 1-    put_ bh InfixN =-            putByte bh 2-    get bh = do-            h <- getByte bh-            case h of-              0 -> return InfixL-              1 -> return InfixR-              _ -> return InfixN-------------------------- maxPrecedence, minPrecedence :: Int maxPrecedence = 9 minPrecedence = 0  defaultFixity :: Fixity-defaultFixity = Fixity NoSourceText maxPrecedence InfixL+defaultFixity = Fixity maxPrecedence InfixL  negateFixity, funTyFixity :: Fixity -- Wired-in fixities-negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate-funTyFixity  = Fixity NoSourceText (-1) InfixR  -- Fixity of '->', see #15235+negateFixity = Fixity 6 InfixL  -- Fixity of unary negate+funTyFixity  = Fixity (-1) InfixR  -- Fixity of '->', see #15235  {- Consider@@ -96,7 +48,7 @@ compareFixity :: Fixity -> Fixity               -> (Bool,         -- Error please                   Bool)         -- Associate to the right: a op1 (b op2 c)-compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)+compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)   = case prec1 `compare` prec2 of         GT -> left         LT -> right@@ -108,12 +60,3 @@     right        = (False, True)     left         = (False, False)     error_please = (True,  False)---- |Captures the fixity of declarations as they are parsed. This is not--- necessarily the same as the fixity declaration, as the normal fixity may be--- overridden using parens or backticks.-data LexicalFixity = Prefix | Infix deriving (Data,Eq)--instance Outputable LexicalFixity where-  ppr Prefix = text "Prefix"-  ppr Infix  = text "Infix"
compiler/GHC/Types/Fixity/Env.hs view
@@ -43,4 +43,3 @@  emptyIfaceFixCache :: OccName -> Maybe Fixity emptyIfaceFixCache _ = Nothing-
compiler/GHC/Types/ForeignCall.hs view
@@ -13,7 +13,7 @@         CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,         CCallSpec(..),         CCallTarget(..), isDynamicTarget,-        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,+        CCallConv(..), defaultCCallConv, ccallConvAttribute,          Header(..), CType(..),     ) where@@ -30,6 +30,8 @@ import Data.Char import Data.Data +import Control.DeepSeq (NFData(..))+ {- ************************************************************************ *                                                                      *@@ -99,7 +101,7 @@ data CExportSpec   = CExportStatic               -- foreign export ccall foo :: ty         SourceText              -- of the CLabelString.-                                -- See Note [Pragma source text] in GHC.Types.SourceText+                                -- See Note [Pragma source text] in "GHC.Types.SourceText"         CLabelString            -- C Name of exported function         CCallConv   deriving Data@@ -117,7 +119,7 @@   -- An "unboxed" ccall# to named function in a particular package.   = StaticTarget         SourceText                -- of the CLabelString.-                                  -- See Note [Pragma source text] in GHC.Types.SourceText+                                  -- See Note [Pragma source text] in "GHC.Types.SourceText"         CLabelString                    -- C-land name of label.          (Maybe Unit)                    -- What package the function is in.@@ -146,10 +148,6 @@  ccall:          Caller allocates parameters, *and* deallocates them. -stdcall:        Caller allocates parameters, callee deallocates.-                Function name has @N after it, where N is number of arg bytes-                e.g.  _Foo@8. This convention is x86 (win32) specific.- See: http://www.programmersheaven.com/2/Calling-conventions -} @@ -160,7 +158,7 @@   | StdCallConv   | PrimCallConv   | JavaScriptCallConv-  deriving (Eq, Data, Enum)+  deriving (Show, Eq, Data, Enum)  instance Outputable CCallConv where   ppr StdCallConv = text "stdcall"@@ -172,24 +170,17 @@ defaultCCallConv :: CCallConv defaultCCallConv = CCallConv -ccallConvToInt :: CCallConv -> Int-ccallConvToInt StdCallConv = 0-ccallConvToInt CCallConv   = 1-ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"-ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"-ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"- {- Generate the gcc attribute corresponding to the given calling convention (used by PprAbsC): -}  ccallConvAttribute :: CCallConv -> SDoc-ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"+ccallConvAttribute StdCallConv       = panic "ccallConvAttribute StdCallConv" ccallConvAttribute CCallConv         = empty ccallConvAttribute CApiConv          = empty ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"-ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"+ccallConvAttribute JavaScriptCallConv = empty  type CLabelString = FastString          -- A C label, completely unencoded @@ -200,7 +191,7 @@ isCLabelString lbl   = all ok (unpackFS lbl)   where-    ok c = isAlphaNum c || c == '_' || c == '.'+    ok c = isAlphaNum c || c == '_' || c == '.' || c == '@'         -- The '.' appears in e.g. "foo.so" in the         -- module part of a ExtName.  Maybe it should be separate @@ -233,7 +224,7 @@         = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""  -- The filename for a C header file--- Note [Pragma source text] in GHC.Types.SourceText+-- See Note [Pragma source text] in "GHC.Types.SourceText" data Header = Header SourceText FastString     deriving (Eq, Data) @@ -241,13 +232,7 @@     ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)  -- | A C type, used in CAPI FFI calls------  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{-\# CTYPE'@,---        'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal',---        'GHC.Parser.Annotation.AnnClose' @'\#-}'@,---- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation"-data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.SourceText+data CType = CType SourceText -- See Note [Pragma source text] in "GHC.Types.SourceText"                    (Maybe Header) -- header to include for this type                    (SourceText,FastString) -- the type itself     deriving (Eq, Data)@@ -361,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
@@ -0,0 +1,346 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Renamer-level information about 'Name's.+--+-- Renamer equivalent of 'TyThing'.+module GHC.Types.GREInfo where++import GHC.Prelude++import GHC.Types.Basic+import GHC.Types.FieldLabel+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.DeepSeq ( NFData(..), deepseq )++import Data.Data ( Data )+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NonEmpty++{-**********************************************************************+*                                                                      *+                           GREInfo+*                                                                      *+************************************************************************++Note [GREInfo]+~~~~~~~~~~~~~~+In the renamer, we sometimes need a bit more information about a 'Name', e.g.+whether it is a type constructor, class, data constructor, record field, etc.++For example, when typechecking record construction, the renamer needs to look+up the fields of the data constructor being used (see e.g. GHC.Rename.Pat.rnHsRecFields).+Extra information also allows us to provide better error messages when a fatal+error occurs in the renamer, as it allows us to distinguish classes, type families,+type synonyms, etc.++For imported Names, we have access to the full type information in the form of+a TyThing (although see Note [Retrieving the GREInfo from interfaces]).+However, for Names in the module currently being renamed, we don't+yet have full information. Instead of using TyThing, we use the GREInfo type,+and this information gets affixed to each element in the GlobalRdrEnv.++This allows us to treat imported and local Names in a consistent manner:+always look at the GREInfo.++Note [Retrieving the GREInfo from interfaces]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a TyThing, we can easily compute the corresponding GREInfo: this is+done in GHC.Types.TyThing.tyThingGREInfo.++However, one often needs to produce GlobalRdrElts (and thus their GREInfos)+directly after loading interface files, before they are typechecked. For example:++  - GHC.Tc.Module.tcRnModuleTcRnM first calls tcRnImports, which starts off+    calling rnImports which transitively calls filterImports. That function+    is responsible for coughing up GlobalRdrElts (and their GREInfos) obtained+    from interfaces, but we will only typecheck the interfaces after we have+    finished processing the imports (see e.g. the logic at the start of tcRnImports+    which sets eps_is_boot, which decides whether we should look in the boot+    or non-boot interface for any particular module).+  - GHC.Tc.Utils.Backpack.mergeSignatures first loads the relevant signature+    interfaces to merge them, but only later on does it typecheck them.++In both of these examples, what's important is that we **lazily** produce the+GREInfo: it should only be consulted once the interfaces have been typechecked,+which will add the necessary information to the type-level environment.+In particular, the respective functions 'filterImports' and 'mergeSignatures'+should NOT force the gre_info field.++We delay the loading of interfaces by making the gre_info field of 'GlobalRdrElt'+a thunk which, when forced, loads the interface, looks up the 'Name' in the type+environment to get its associated TyThing, and computes the GREInfo from that.+See 'GHC.Rename.Env.lookupGREInfo'.++A possible alternative design would be to change the AvailInfo datatype to also+store GREInfo. We currently don't do that, as this would mean that every time+an interface re-exports something it has to also provide its GREInfo, which+could lead to bloat.++Note [Forcing GREInfo]+~~~~~~~~~~~~~~~~~~~~~~+The GREInfo field of a GlobalRdrElt needs to be lazy, as explained in+Note [Retrieving the GREInfo from interfaces]. For imported things, this field+is usually a thunk which looks up the GREInfo in a type environment+(see GHC.Rename.Env.lookupGREInfo).++We thus need to be careful not to introduce space leaks: such thunks could end+up retaining old type environments, which would violate invariant (5) of+Note [GHC Heap Invariants] in GHC.Driver.Make. This can happen, for example,+when reloading in GHCi (see e.g. test T15369, which can trigger the ghci leak check+if we're not careful).++A naive approach is to simply deeply force the whole GlobalRdrEnv. However,+forcing the GREInfo thunks can force the loading of interface files which we+otherwise might not need to load, so it leads to wasted work.++Instead, whenever we are about to store the GlobalRdrEnv somewhere (such as+in ModDetails), we dehydrate it by stripping away the GREInfo field, turning it+into (). See 'forceGlobalRdrEnv' and its cousin 'hydrateGlobalRdrEnv',+as well as Note [IfGlobalRdrEnv] in GHC.Types.Name.Reader.++Search for references to this note in the code for illustration.+-}++-- | Information about a 'Name' that is pertinent to the renamer.+--+-- See Note [GREInfo]+data GREInfo+      -- | A variable (an 'Id' or a 'TyVar')+    = Vanilla+      -- | An unbound GRE... could be anything+    | UnboundGRE+      -- | 'TyCon'+    | IAmTyCon    !(TyConFlavour Name)+      -- | 'ConLike'+    | IAmConLike  !ConInfo+      -- ^ The constructor fields.+      -- See Note [Local constructor info in the renamer].+      -- | Record field+    | IAmRecField !RecFieldInfo++    deriving Data+++plusGREInfo :: GREInfo -> GREInfo -> GREInfo+plusGREInfo Vanilla Vanilla = Vanilla+plusGREInfo UnboundGRE UnboundGRE = UnboundGRE+plusGREInfo (IAmTyCon {})    info2@(IAmTyCon {}) = info2+plusGREInfo (IAmConLike {})  info2@(IAmConLike {}) = info2+plusGREInfo (IAmRecField {}) info2@(IAmRecField {}) = info2+plusGREInfo info1 info2 = pprPanic "plusInfo" $+  vcat [ text "info1:" <+> ppr info1+       , text "info2:" <+> ppr info2 ]++instance Outputable GREInfo where+  ppr Vanilla = text "Vanilla"+  ppr UnboundGRE = text "UnboundGRE"+  ppr (IAmTyCon flav)+    = text "TyCon" <+> ppr flav+  ppr (IAmConLike info)+    = text "ConLike" <+> ppr info+  ppr (IAmRecField info)+    = text "RecField" <+> ppr info++{-**********************************************************************+*                                                                      *+                      Constructor info+*                                                                      *+************************************************************************++Note [Local constructor info in the renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [GREInfo], information pertinent to the renamer is+stored using the GREInfo datatype. What information do we need about constructors?++Consider the following example:++  data T = T1 { x, y :: Int }+         | T2 { x :: Int }+         | T3+         | T4 Int Bool++We need to know:+* The fields of the data constructor, so that+  - We can complain if you say `T1 { v = 3 }`, where `v` is not a field of `T1`+    See the following call stack+    * GHC.Rename.Expr.rnExpr (RecordCon case)+    * GHC.Rename.Pat.rnHsRecFields+    * GHC.Rename.Env.lookupRecFieldOcc+  - Ditto if you pattern match on `T1 { v = x }`.+    See the following call stack+    * GHC.Rename.Pat.rnHsRecPatsAndThen+    * GHC.Rename.Pat.rnHsRecFields+    * GHC.Rename.Env.lookupRecFieldOcc+  - We can fill in the dots if you say `T1 {..}` in construction or pattern matching+    See GHC.Rename.Pat.rnHsRecFields.rn_dotdot++  This information is stored in ConFieldInfo.++* Whether the constructor is nullary.+  We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`,+  in both construction and pattern matching.+  See GHC.Rename.Pat.rnHsRecFields.rn_dotdot+  and Note [Nullary constructors and empty record wildcards]++  This information is stored in ConFieldInfo.++* Whether the constructor is a data constructor or a pattern synonym, and,+  if it is a data constructor, what are the other data constructors of the+  parent type. This is used for computing irrefutability of pattern matches+  when deciding how to desugar do blocks (whether to use a fail operation).+  See GHC.Hs.Pat.isIrrefutableHsPat.++  This information is stored in ConLikeInfo.++Note [Nullary constructors and empty record wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A nullary constructor is one with no arguments.+For example, both `data T = MkT` and `data T = MkT {}` are nullary.++For consistency and TH convenience, it was agreed that a `{..}`+match or usage on nullary constructors would be accepted.+This is done as as per https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst+-}++-- | Information known to the renamer about a data constructor or pattern synonym.+--+-- See Note [Local constructor info in the renamer].+data ConInfo+  = ConInfo+  { conLikeInfo  :: !ConLikeInfo+  , conFieldInfo :: !ConFieldInfo+  }+  deriving stock Eq+  deriving Data++-- | Whether a constructor is a data constructor or a pattern synonym.+--+-- See Note [Local constructor info in the renamer].+data ConLikeInfo+  = ConIsData+    { conLikeDataCons :: [Name]+      -- ^ All the 'DataCon's of the parent 'TyCon',+      -- including the 'ConLike' itself.+      --+      -- Used in 'GHC.Hs.Pat.isIrrefutableHsPat'.+    }+  | ConIsPatSyn+  deriving stock Eq+  deriving Data++instance NFData ConInfo where+  rnf (ConInfo a b) = rnf a `seq` rnf b++instance NFData ConLikeInfo where+  rnf (ConIsData a) = rnf a+  rnf ConIsPatSyn = ()+++-- | Information about the record fields of a constructor.+--+-- See Note [Local constructor info in the renamer]+data ConFieldInfo+  = ConHasRecordFields (NonEmpty FieldLabel)+  | ConHasPositionalArgs+  | ConIsNullary+  deriving stock Eq+  deriving Data++instance NFData ConFieldInfo where+  rnf ConIsNullary = ()+  rnf ConHasPositionalArgs = ()+  rnf (ConHasRecordFields flds) = rnf flds++mkConInfo :: ConLikeInfo -> VisArity -> [FieldLabel] -> ConInfo+mkConInfo con_ty n flds =+  ConInfo { conLikeInfo  = con_ty+          , conFieldInfo = mkConFieldInfo n flds }++mkConFieldInfo :: Arity -> [FieldLabel] -> ConFieldInfo+mkConFieldInfo 0 _ = ConIsNullary+mkConFieldInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields+                   $ NonEmpty.nonEmpty fields++conInfoFields :: ConInfo -> [FieldLabel]+conInfoFields = conFieldInfoFields . conFieldInfo++conFieldInfoFields :: ConFieldInfo -> [FieldLabel]+conFieldInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields+conFieldInfoFields ConHasPositionalArgs = []+conFieldInfoFields ConIsNullary = []++instance Outputable ConInfo where+  ppr (ConInfo { conLikeInfo = con_ty, conFieldInfo = fld_info })+    = text "ConInfo" <+> braces+    (text "con_ty:" <+> ppr con_ty <> comma+    <+> text "fields:" <+> ppr fld_info)++instance Outputable ConLikeInfo where+  ppr (ConIsData cons) = text "ConIsData" <+> parens (ppr cons)+  ppr ConIsPatSyn      = text "ConIsPatSyn"++instance Outputable ConFieldInfo where+  ppr ConIsNullary = text "ConIsNullary"+  ppr ConHasPositionalArgs = text "ConHasPositionalArgs"+  ppr (ConHasRecordFields fieldLabels) =+    text "ConHasRecordFields" <+> braces (ppr fieldLabels)++-- | The 'Name' of a 'ConLike'.+--+-- Useful when we are in the renamer and don't yet have a full 'DataCon' or+-- 'PatSyn' to hand.+data ConLikeName+  = 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++instance OutputableBndr ConLikeName where+    pprInfixOcc con = pprInfixName (conLikeName_Name con)+    pprPrefixOcc con = pprPrefixName (conLikeName_Name con)++instance Uniquable ConLikeName where+  getUnique = getUnique . conLikeName_Name++instance NFData ConLikeName where+  rnf = rnf . conLikeName_Name++{-**********************************************************************+*                                                                      *+                      Record field info+*                                                                      *+**********************************************************************-}++data RecFieldInfo+  = RecFieldInfo+      { recFieldLabel :: !FieldLabel+      , recFieldCons  :: !(UniqSet ConLikeName)+         -- ^ The constructors which have this field label.+         -- Always non-empty.+         --+         -- NB: these constructors will always share a single parent,+         -- as the field label disambiguates between parents in the presence+         -- of duplicate record fields.+      }+  deriving (Eq, Data)++instance NFData RecFieldInfo where+  rnf (RecFieldInfo lbl cons)+    = rnf lbl `seq` nonDetStrictFoldUniqSet deepseq () cons++instance Outputable RecFieldInfo where+  ppr (RecFieldInfo { recFieldLabel = fl, recFieldCons = cons })+    = text "RecFieldInfo" <+> braces+      (text "recFieldLabel:" <+> ppr fl <> comma+      <+> text "recFieldCons:" <+> pprWithCommas ppr (nonDetEltsUniqSet cons))
compiler/GHC/Types/Hint.hs view
@@ -5,11 +5,14 @@   , AvailableBindings(..)   , InstantiationSuggestion(..)   , LanguageExtensionHint(..)+  , ImportItemSuggestion(..)   , ImportSuggestion(..)   , HowInScope(..)   , SimilarName(..)   , StarIsType(..)   , UntickedPromotedThing(..)+  , AssumedDerivingStrategy(..)+  , SigLike(..)   , pprUntickedConstructor, isBareSymbol   , suggestExtension   , suggestExtensionWithInfo@@ -21,30 +24,34 @@   , noStarIsTypeHints   ) where +import Language.Haskell.Syntax.Expr (LHsExpr)+import Language.Haskell.Syntax (LPat, LIdP, LHsSigType, LHsSigWcType, Sig)+ import GHC.Prelude  import qualified Data.List.NonEmpty as NE -import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt-import Data.Typeable import GHC.Unit.Module (ModuleName, Module)-import GHC.Hs.Extension (GhcTc)+import GHC.Unit.Module.Imported (ImportedModsVal)+import GHC.Hs.Extension (GhcTc, GhcRn, GhcPs)+import GHC.Core.Class (Class) import GHC.Core.Coercion-import GHC.Core.Type (PredType)+import GHC.Core.FamInstEnv (FamFlavor)+import GHC.Core.TyCon (TyCon)+import GHC.Core.Type (Type) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec) import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Activation, RuleName)-import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Parser.Errors.Basic-import {-# SOURCE #-} Language.Haskell.Syntax.Expr-import GHC.Unit.Module.Imported (ImportedModsVal)-import GHC.Data.FastString (fsLit)-  -- This {-# SOURCE #-} import should be removable once-  -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'.+import GHC.Utils.Outputable+import GHC.Data.FastString (fsLit, FastString) +import Data.Typeable ( Typeable )+import Data.Map.Strict (Map)+ -- | The bindings we have available in scope when -- suggesting an explicit type signature. data AvailableBindings@@ -52,6 +59,7 @@   | UnnamedBinding   -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') + data LanguageExtensionHint   = -- | Suggest to enable the input extension. This is the hint that     -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving@@ -247,7 +255,6 @@     -}   | SuggestAddToHSigExportList !Name !(Maybe Module)     {-| Suggests increasing the limit for the number of iterations in the simplifier.-     -}   | SuggestIncreaseSimplifierIterations     {-| Suggests to explicitly import 'Type' from the 'Data.Kind' module, because@@ -296,21 +303,26 @@     -}   | SuggestQualifyStarOperator -    {-| Suggests that a type signature should have form <variable> :: <type>+    {-| Suggests that for a type signature 'M.x :: ...' the qualifier should be omitted         in order to be accepted by GHC.          Triggered by: 'GHC.Parser.Errors.Types.PsErrInvalidTypeSignature'-        Test case(s): parser/should_fail/T3811+        Test case(s): module/mod98     -}-  | SuggestTypeSignatureForm+  | SuggestTypeSignatureRemoveQualifier -    {-| Suggests to move an orphan instance or to newtype-wrap it.+    {-| Suggests to move an orphan instance (for a typeclass or a type or data+        family), or to newtype-wrap it.          Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance'         Test cases(s): warnings/should_compile/T9178                        typecheck/should_compile/T4912+                       indexed-types/should_compile/T22717_fam_orph     -}-  | SuggestFixOrphanInstance+  | SuggestFixOrphanInst+    { isFamilyInstance :: Maybe FamFlavor }+      -- ^ Whether this is a family instance (of the given 'FamFlavor'),+      -- or a class instance ('Nothing').      {-| Suggests to use a standalone deriving declaration when GHC         can't derive a typeclass instance in a trivial way.@@ -320,6 +332,14 @@     -}   | SuggestAddStandaloneDerivation +    {-| Suggests to add a standalone kind signature when GHC+        can't perform kind inference.++        Triggered by: 'GHC.Tc.Errors.Types.TcRnInvisBndrWithoutSig'+        Test case(s): typecheck/should_fail/T22560_fail_d+    -}+  | SuggestAddStandaloneKindSignature Name+     {-| Suggests the user to fill in the wildcard constraint to         disambiguate which constraint that is. @@ -331,11 +351,6 @@     -}   | SuggestFillInWildcardConstraint -  {-| Suggests to use an identifier other than 'forall'-      Triggered by: 'GHC.Tc.Errors.Types.TcRnForallIdentifier'-  -}-  | SuggestRenameForall-     {-| Suggests to use the appropriate Template Haskell tick:         a single tick for a term-level 'NameSpace', or a double tick         for a type-level 'NameSpace'.@@ -369,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,@@ -395,16 +409,9 @@        Test cases: mod28, mod36, mod87, mod114, ...   -}-  | ImportSuggestion ImportSuggestion--    {-| Suggest importing a data constructor to bring it into scope-        Triggered by: 'GHC.Tc.Errors.Types.TcRnTypeCannotBeMarshaled'+  | ImportSuggestion OccName ImportSuggestion -        Test cases: ccfail004-    -}-  | SuggestImportingDataCon-  {- Found a pragma in the body of a module, suggest-     placing it in the header+  {-| Found a pragma in the body of a module, suggest placing it in the header.   -}   | SuggestPlacePragmaInHeader     {-| Suggest using pattern matching syntax for a non-bidirectional pattern synonym@@ -420,11 +427,107 @@     -}   | SuggestSpecialiseVisibilityHints Name -  | LoopySuperclassSolveHint PredType ClsInstOrQC+    {-| Suggest renaming implicitly quantified type variable in case it+        captures a term's name.+    -}+  | SuggestRenameTypeVariable +  | SuggestExplicitBidiPatSyn Name (LPat GhcRn) [LIdP GhcRn]++    {-| Suggest enabling one of the SafeHaskell modes Safe, Unsafe or+        Trustworthy.+    -}+  | SuggestSafeHaskell++    {-| Suggest removing a record wildcard from a pattern when it doesn't+        bind anything useful.+    -}+  | SuggestRemoveRecordWildcard+    {-| Suggest moving a method implementation to a different instance to its+      superclass that defines the canonical version of the method.+    -}+  | SuggestMoveNonCanonicalDefinition+    Name -- ^ move the implementation from this method+    Name -- ^ ... to this method+    String -- ^ Documentation URL++    {-| Suggest to increase the solver maximum reduction depth -}+  | SuggestIncreaseReductionDepth++    {-| Suggest removing a method implementation when a superclass defines the+      canonical version of that method.+    -}+  | SuggestRemoveNonCanonicalDefinition+    Name -- ^ method with non-canonical implementation+    Name -- ^ possible other method to use as the RHS instead+    String -- ^ Documentation URL+  {-| Suggest eta-reducing a type synonym used in the implementation+      of abstract data. -}+  | SuggestEtaReduceAbsDataTySyn TyCon+  {-| Remind the user that there is no field of a type and name in the record,+      constructors are in the usual order $x$, $r$, $a$ -}+  | RemindRecordMissingField FastString Type Type+  {-| Suggest binding the type variable on the LHS of the type declaration+  -}+  | SuggestBindTyVarOnLhs RdrName++  {-| Suggest using an anonymous wildcard instead of a named wildcard -}+  | SuggestAnonymousWildcard++  {-| Suggest explicitly quantifying a type variable instead of relying on implicit quantification -}+  | SuggestExplicitQuantification RdrName+   {-| Suggest binding explicitly; e.g   data T @k (a :: F k) = .... -}   | SuggestBindTyVarExplicitly Name +  {-| Suggest a default declaration; e.g @default Cls (Ty1, Ty2)@ -}+  | SuggestDefaultDeclaration Class [Type]++  {-| Suggest using explicit deriving strategies for a deriving clause.++      Triggered by: 'GHC.Tc.Errors.Types.TcRnNoDerivingClauseStrategySpecified'.++      See comment of 'TcRnNoDerivingClauseStrategySpecified' for context.+  -}+  | SuggestExplicitDerivingClauseStrategies+    (Map AssumedDerivingStrategy [LHsSigType GhcRn])+    -- ^ Those deriving clauses that we assumed a particular strategy for.++  {-| Suggest using an explicit deriving strategy for a standalone deriving instance.++      Triggered by: 'GHC.Tc.Errors.Types.TcRnNoStandaloneDerivingStrategySpecified'.++      See comment of 'TcRnNoStandaloneDerivingStrategySpecified' for context.+  -}+  | SuggestExplicitStandaloneDerivingStrategy+    AssumedDerivingStrategy -- ^ The deriving strategy we assumed+    (LHsSigWcType GhcRn) -- ^ The instance signature (e.g 'Show a => Show (T a)')++  {-| 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.+data AssumedDerivingStrategy+  = AssumedStockStrategy+  | AssumedAnyclassStrategy+  | AssumedNewtypeStrategy+  deriving (Eq, Ord)++instance Outputable AssumedDerivingStrategy where+  ppr AssumedStockStrategy = text "stock"+  ppr AssumedAnyclassStrategy = text "anyclass"+  ppr AssumedNewtypeStrategy = text "newtype"+ -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way -- to instantiate a particular signature, where the first argument is@@ -438,12 +541,34 @@ --      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)) OccName+  = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal))   -- | Some module exports what we want, but we are explicitly hiding it.-  | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) OccName+  | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal))+  -- | 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.+      { 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 }  -- | Explain how something is in scope. data HowInScope@@ -454,7 +579,16 @@  data SimilarName   = SimilarName Name-  | SimilarRdrName RdrName HowInScope+  | 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
@@ -1,9 +1,10 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-}   -- instance Outputable GhcHint+{-# OPTIONS_GHC -Wno-orphans #-}   {- instance Outputable GhcHint -}  module GHC.Types.Hint.Ppr (-  perhapsAsPat+  perhapsAsPat, pprSigLike   -- also, and more interesting: instance Outputable GhcHint   ) where @@ -12,19 +13,26 @@ import GHC.Parser.Errors.Basic import GHC.Types.Hint +import GHC.Core.FamInstEnv (FamFlavor(..))+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep     ( mkVisFunTyMany ) import GHC.Hs.Expr ()   -- instance Outputable-import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Types.Id-import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace, nameModule)+import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) import GHC.Unit.Module.Imported (ImportedModsVal(..)) import GHC.Unit.Types import GHC.Utils.Outputable -import Data.List (intersperse)+import GHC.Driver.Flags+ import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map +import qualified GHC.LanguageExtensions as LangExt+import GHC.Hs.Binds (hsSigDoc)+ instance Outputable GhcHint where   ppr = \case     UnknownHint m@@ -32,15 +40,20 @@     SuggestExtension extHint       -> case extHint of           SuggestSingleExtension extraUserInfo ext ->-            (text "Perhaps you intended to use" <+> ppr ext) $$ extraUserInfo+            ("Perhaps you intended to use" <+> extension_with_implied ext)+            $$ extraUserInfo           SuggestAnyExtension extraUserInfo exts ->-            let header = text "Enable any of the following extensions:"-            in  header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo+            (enable "any" <+> unquotedListWith "or" (map implied exts))+            $$ extraUserInfo           SuggestExtensions extraUserInfo exts ->-            let header = text "Enable all of the following extensions:"-            in  header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo+            (enable "all" <+> unquotedListWith "and" (map implied exts))+            $$ extraUserInfo           SuggestExtensionInOrderTo extraUserInfo ext ->-            (text "Use" <+> ppr ext) $$ extraUserInfo+            ("Use" <+> extension_with_implied ext)+            $$ extraUserInfo+      where extension_with_implied ext = "the" <+> quotes (ppr ext) <+> "extension" <+> pprImpliedExtensions ext+            implied ext = quotes (ppr ext) <+> pprImpliedExtensions ext+            enable any_or_all = "Enable" <+> any_or_all <+> "of the following extensions" <> colon     SuggestCorrectPragmaName suggestions       -> text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)     SuggestMissingDo@@ -125,26 +138,28 @@       -> text "To use (or export) this operator in"             <+> text "modules with StarIsType,"          $$ text "    including the definition module, you must qualify it."-    SuggestTypeSignatureForm-      -> text "A type signature should be of form <variables> :: <type>"+    SuggestTypeSignatureRemoveQualifier+      -> text "Perhaps you meant to omit the qualifier"     SuggestAddToHSigExportList _name mb_mod       -> let header = text "Try adding it to the export list of"          in case mb_mod of               Nothing -> header <+> text "the hsig file."               Just mod -> header <+> ppr (moduleName mod) <> text "'s hsig file."-    SuggestFixOrphanInstance-      -> vcat [ text "Move the instance declaration to the module of the class or of the type, or"+    SuggestFixOrphanInst { isFamilyInstance = mbFamFlavor }+      -> vcat [ text "Move the instance declaration to the module of the" <+> what <+> text "or of the type, or"               , text "wrap the type with a newtype and declare the instance on the new type."               ]+      where+        what = case mbFamFlavor of+          Nothing                  -> text "class"+          Just  SynFamilyInst      -> text "type family"+          Just (DataFamilyInst {}) -> text "data family"     SuggestAddStandaloneDerivation       -> text "Use a standalone deriving declaration instead"+    SuggestAddStandaloneKindSignature name+      -> text "Add a standalone kind signature for" <+> quotes (ppr name)     SuggestFillInWildcardConstraint       -> text "Fill in the wildcard constraint yourself"-    SuggestRenameForall-      -> vcat [ text "Consider using another name, such as"-              , quotes (text "forAll") <> comma <+>-                quotes (text "for_all") <> comma <+> text "or" <+>-                quotes (text "forall_") <> dot ]     SuggestAppropriateTHTick ns       -> text "Perhaps use a" <+> how_many <+> text "tick"         where@@ -173,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@@ -193,10 +208,8 @@         whose | null parents = empty               | otherwise    = text "belonging to the type" <> plural parents                                  <+> pprQuotedList parents-    ImportSuggestion import_suggestion-      -> pprImportSuggestion import_suggestion-    SuggestImportingDataCon-      -> text "Import the data constructor to bring it into scope"+    ImportSuggestion occ_name import_suggestion+      -> pprImportSuggestion occ_name import_suggestion     SuggestPlacePragmaInHeader       -> text "Perhaps you meant to place it in the module header?"       $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword"@@ -207,85 +220,232 @@            <+> quotes (ppr name) <+> text "has an INLINABLE pragma"          where            mod = nameModule name-    LoopySuperclassSolveHint pty cls_or_qc-      -> vcat [ text "Add the constraint" <+> quotes (ppr pty) <+> text "to the" <+> what <> comma-              , text "even though it seems logically implied by other constraints in the context." ]-        where-          what :: SDoc-          what = case cls_or_qc of-            IsClsInst -> text "instance context"-            IsQC {}   -> text "context of the quantified constraint"+    SuggestRenameTypeVariable+      -> text "Consider renaming the type variable."+    SuggestExplicitBidiPatSyn name pat args+      -> hang (text "Instead use an explicitly bidirectional"+               <+> text "pattern synonym, e.g.")+            2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow+                     <+> ppr pat <+> text "where")+                  2 (pp_name <+> pp_args <+> equals <+> text "..."))+         where+           pp_name = ppr name+           pp_args = hsep (map ppr args)+    SuggestSafeHaskell+      -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe."+    SuggestRemoveRecordWildcard+      -> text "Omit the" <+> quotes (text "..")+    SuggestIncreaseReductionDepth ->+      vcat+        [ text "Use -freduction-depth=0 to disable this check"+        , text "(any upper bound you could choose might fail unpredictably with"+        , text " minor updates to GHC, so disabling the check is recommended if"+        , text " you're sure that type checking should terminate)" ]+    SuggestMoveNonCanonicalDefinition lhs rhs refURL ->+      text "Move definition from" <+>+      quotes (pprPrefixUnqual rhs) <+>+      text "to" <+> quotes (pprPrefixUnqual lhs) $$+      text "See also:" <+> text refURL+    SuggestRemoveNonCanonicalDefinition lhs rhs refURL ->+      text "Either remove definition for" <+>+      quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+>+      text "or define as" <+>+      quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$+      text "See also:" <+> text refURL+    SuggestEtaReduceAbsDataTySyn tc+      -> text "If possible, eta-reduce the type synonym" <+> ppr_tc <+> text "so that it is nullary."+        where ppr_tc = quotes (ppr $ tyConName tc)+    RemindRecordMissingField x r a ->+      text "NB: There is no field selector" <+> ppr_sel+        <+> text "in scope for record type" <+> ppr_r+      where ppr_sel = quotes (ftext x <+> dcolon <+> ppr_arr_r_a)+            ppr_arr_r_a = ppr $ mkVisFunTyMany r a+            ppr_r = quotes $ ppr r+    SuggestBindTyVarOnLhs tv+      -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration"+    SuggestAnonymousWildcard+      -> text "Use an anonymous wildcard" <+> quotes (text "_")+    SuggestExplicitQuantification tv+      -> hsep [ text "Use an explicit", quotes (text "forall")+              , text "to quantify over", quotes (ppr tv) ]     SuggestBindTyVarExplicitly tv       -> text "bind" <+> quotes (ppr tv)          <+> text "explicitly with" <+> quotes (char '@' <> ppr tv)+    SuggestDefaultDeclaration cls tys+      -> hang (text "Consider declaring")+            2 (text "default" <+> ppr cls <+> parens (pprWithCommas ppr tys))+    SuggestExplicitDerivingClauseStrategies assumed_derivings ->+      hang+        (text "Use explicit deriving strategies:")+        2+        (vcat $ map pp_derivings (Map.toList assumed_derivings))+      where+        pp_derivings (strat, preds) =+          hsep [text "deriving", ppr strat, parens (pprWithCommas ppr preds)]+    SuggestExplicitStandaloneDerivingStrategy strat deriv_sig ->+      hang+        (text "Use an explicit deriving strategy:")+        2+        (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"  -- | Pretty-print an 'ImportSuggestion'.-pprImportSuggestion :: ImportSuggestion -> SDoc-pprImportSuggestion (CouldImportFrom mods occ_name)+pprImportSuggestion :: OccName -> ImportSuggestion -> SDoc+pprImportSuggestion occ_name (CouldImportFrom mods)   | (mod, imv) NE.:| [] <- mods   = fsep-      [ text "Perhaps you want to add"+      [ text "Add"       , quotes (ppr occ_name)       , text "to the import list"       , text "in the import of"       , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot+      , parens (text "at" <+> ppr (imv_span imv)) <> dot       ]   | otherwise   = fsep-      [ text "Perhaps you want to add"+      [ text "Add"       , quotes (ppr occ_name)       , text "to one of these import lists:"       ]     $$     nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv))         | (mod,imv) <- NE.toList mods         ])-pprImportSuggestion (CouldUnhideFrom mods occ_name)+pprImportSuggestion occ_name (CouldUnhideFrom mods)   | (mod, imv) NE.:| [] <- mods   = fsep-      [ text "Perhaps you want to remove"+      [ text "Remove"       , quotes (ppr occ_name)       , text "from the explicit hiding list"       , text "in the import of"       , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot+      , parens (text "at" <+> ppr (imv_span imv)) <> dot       ]   | otherwise   = fsep-      [ text "Perhaps you want to remove"+      [ text "Remove"       , quotes (ppr occ_name)       , text "from the hiding clauses"       , text "in one of these imports:"       ]     $$     nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv))         | (mod,imv) <- NE.toList mods         ])+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)+    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 { 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'. pprSimilarName :: NameSpace -> SimilarName -> SDoc pprSimilarName _ (SimilarName name)   = quotes (ppr name) <+> parens (pprDefinedAt name) pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)-  = case how_in_scope of-      LocallyBoundAt loc ->-        pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc'-          where-            loc' = case loc of-              UnhelpfulSpan l -> parens (ppr l)-              RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))-      ImportedBy is ->-        pp_ns rdr_name <+> quotes (ppr rdr_name) <+>-        parens (text "imported from" <+> ppr (is_mod is))-+  = pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc   where+    loc = case how_in_scope of+      Nothing -> empty+      Just scope -> case scope of+        LocallyBoundAt loc ->+          case loc of+            UnhelpfulSpan l -> parens (ppr l)+            RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))+        ImportedBy is ->+          parens (text "imported from" <+> ppr (moduleName $ is_mod is))     pp_ns :: RdrName -> SDoc     pp_ns rdr | ns /= tried_ns = pprNameSpace ns               | otherwise      = empty       where ns = rdrNameSpace rdr++pprImpliedExtensions :: LangExt.Extension -> SDoc+pprImpliedExtensions extension = case implied of+    [] -> empty+    xs -> parens $ "implied by" <+> unquotedListWith "and" xs+  where implied = map (quotes . ppr)+                . filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated)+                $ [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/IPE.hs view
@@ -9,10 +9,11 @@ import GHC.Prelude  import GHC.Types.Name+import GHC.Data.FastString import GHC.Types.SrcLoc import GHC.Core.DataCon -import GHC.Types.Unique.Map+import GHC.Types.Unique.DFM import GHC.Core.Type import Data.List.NonEmpty import GHC.Cmm.CLabel (CLabel)@@ -20,12 +21,12 @@  -- | Position and information about an info table. -- For return frames these are the contents of a 'CoreSyn.SourceNote'.-type IpeSourceLocation = (RealSrcSpan, String)+type IpeSourceLocation = (RealSrcSpan, LexicalFastString)  -- | A map from a 'Name' to the best approximate source position that -- name arose from.-type ClosureMap = UniqMap Name  -- The binding-                          (Type, Maybe IpeSourceLocation)+type ClosureMap = UniqDFM Name  -- The binding+                          (Name, (Type, Maybe IpeSourceLocation))                           -- The best approximate source position.                           -- (rendered type, source position, source note                           -- label)@@ -37,7 +38,7 @@ -- the constructor was used at, if possible and a string which names -- the source location. This is the same information as is the payload -- for the 'GHC.Core.SourceNote' constructor.-type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))+type DCMap = UniqDFM DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))  type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation) @@ -48,4 +49,4 @@                           }  emptyInfoTableProvMap :: InfoTableProvMap-emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty+emptyInfoTableProvMap = InfoTableProvMap emptyUDFM emptyUDFM Map.empty
compiler/GHC/Types/Id.hs view
@@ -54,7 +54,7 @@         setIdExported, setIdNotExported,         globaliseId, localiseId,         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,-        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,+        zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,         zapIdUsedOnceInfo, zapIdTailCallInfo,         zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding,         transferPolyIdInfo, scaleIdBy, scaleVarBy,@@ -71,14 +71,15 @@         isPrimOpId, isPrimOpId_maybe,         isFCallId, isFCallId_maybe,         isDataConWorkId, isDataConWorkId_maybe,-        isDataConWrapId, isDataConWrapId_maybe,-        isDataConId_maybe,+        isDataConWrapId, isDataConWrapId_maybe, dataConWrapUnfolding_maybe,+        isDataConId, isDataConId_maybe,         idDataCon,         isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom,         hasNoBinding,          -- ** Join variables-        JoinId, isJoinId, isJoinId_maybe, idJoinArity,+        JoinId, JoinPointHood,+        isJoinId, idJoinPointHood, idJoinArity,         asJoinId, asJoinId_maybe, zapJoinId,          -- ** Inline pragma stuff@@ -128,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 @@ -139,34 +136,41 @@ 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.Types.RepType+import GHC.Core.Predicate( isCoVarType ) import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Core.Multiplicity++import GHC.Types.RepType import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Name-import GHC.Unit.Module-import GHC.Core.Class-import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Types.ForeignCall-import GHC.Data.Maybe import GHC.Types.SrcLoc import GHC.Types.Unique-import GHC.Builtin.Uniques (mkBuiltinUnique) import GHC.Types.Unique.Supply++import GHC.Stg.EnforceEpt.TagSig++import GHC.Unit.Module+import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp)+import GHC.Builtin.Uniques (mkBuiltinUnique)++import GHC.Data.Maybe import GHC.Data.FastString-import GHC.Core.Multiplicity  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Stg.InferTags.TagSig  -- infixl so you can say (id `set` a `set` b) infixl  1 `setIdUnfolding`,@@ -205,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) @@ -245,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 @@ -296,26 +297,28 @@ mkGlobalId = Var.mkGlobalVar  -- | Make a global 'Id' without any extra information at all-mkVanillaGlobal :: Name -> Type -> Id+mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo  -- | Make a global 'Id' with no global information but some generic 'IdInfo'-mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id-mkVanillaGlobalWithInfo = mkGlobalId VanillaId-+mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id+mkVanillaGlobalWithInfo nm =+  assertPpr (not $ isFieldNameSpace $ nameNameSpace nm)+    (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $+    mkGlobalId VanillaId nm  -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo  -- | Make a local CoVar-mkLocalCoVar :: Name -> Type -> CoVar+mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar mkLocalCoVar name ty   = assert (isCoVarType ty) $     Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo  -- | Like 'mkLocalId', but checks the type to see if it should make a covar-mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id+mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty   -- We should assert (eqType w Many) in the isCoVarType case.   -- However, currently this assertion does not hold.@@ -339,7 +342,10 @@         -- Note [Free type variables]  mkExportedVanillaId :: Name -> Type -> Id-mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo+mkExportedVanillaId name ty =+  assertPpr (not $ isFieldNameSpace $ nameNameSpace name)+    (text "mkExportedVanillaId called on record field:" <+> ppr name) $+    Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo         -- Note [Free type variables]  @@ -480,23 +486,23 @@  isDataConRecordSelector id = case Var.idDetails id of                         RecSelId {sel_tycon = RecSelData _} -> True-                        _               -> False+                        _                                   -> False  isPatSynRecordSelector id = case Var.idDetails id of                         RecSelId {sel_tycon = RecSelPatSyn _} -> True-                        _               -> False+                        _                                     -> False  isNaughtyRecordSelector id = case Var.idDetails id of                         RecSelId { sel_naughty = n } -> n-                        _                               -> False+                        _                            -> False  isClassOpId id = case Var.idDetails id of-                        ClassOpId _   -> True-                        _other        -> False+                        ClassOpId {} -> True+                        _other       -> False  isClassOpId_maybe id = case Var.idDetails id of-                        ClassOpId cls -> Just cls-                        _other        -> Nothing+                        ClassOpId cls _ -> Just cls+                        _other          -> Nothing  isPrimOpId id = case Var.idDetails id of                         PrimOpId {} -> True@@ -527,19 +533,33 @@                         _                 -> Nothing  isDataConWrapId id = case Var.idDetails id of-                       DataConWrapId _ -> True-                       _               -> False+                        DataConWrapId _ -> True+                        _               -> False  isDataConWrapId_maybe id = case Var.idDetails id of                         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                          DataConWrapId con -> Just con                          _                 -> Nothing +isDataConId :: Id -> Bool+isDataConId id = case Var.idDetails id of+                         DataConWorkId {} -> True+                         DataConWrapId {} -> True+                         _                 -> False+ -- | An Id for which we might require all callers to pass strict arguments properly tagged + evaluated. -- -- See Note [CBV Function Ids]@@ -560,13 +580,12 @@   | otherwise = False  -- | Doesn't return strictness marks-isJoinId_maybe :: Var -> Maybe JoinArity-isJoinId_maybe id- | isId id  = assertPpr (isId id) (ppr id) $-              case Var.idDetails id of-                JoinId arity _marks -> Just arity-                _            -> Nothing- | otherwise = Nothing+idJoinPointHood :: Var -> JoinPointHood+idJoinPointHood id+ | isId id  = case Var.idDetails id of+                JoinId arity _marks -> JoinPoint arity+                _                   -> NotJoinPoint+ | otherwise = NotJoinPoint  idDataCon :: Id -> DataCon -- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.@@ -590,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@@ -639,7 +662,9 @@ -}  idJoinArity :: JoinId -> JoinArity-idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)+idJoinArity id = case idJoinPointHood id of+                   JoinPoint ar -> ar+                   NotJoinPoint -> pprPanic "idJoinArity" (ppr id)  asJoinId :: Id -> JoinArity -> JoinId asJoinId id arity = warnPprTrace (not (isLocalId id))@@ -671,9 +696,9 @@                   _                     -> panic "zapJoinId: newIdDetails can only be used if Id was a join Id."  -asJoinId_maybe :: Id -> Maybe JoinArity -> Id-asJoinId_maybe id (Just arity) = asJoinId id arity-asJoinId_maybe id Nothing      = zapJoinId id+asJoinId_maybe :: Id -> JoinPointHood -> Id+asJoinId_maybe id (JoinPoint arity) = asJoinId id arity+asJoinId_maybe id NotJoinPoint      = zapJoinId id  {- ************************************************************************@@ -834,15 +859,15 @@ asNonWorkerLikeId id =   let details = case idDetails id of         WorkerLikeId{}      -> Just $ VanillaId-        JoinId arity Just{}   -> Just $ JoinId arity Nothing-        _                     -> Nothing+        JoinId arity Just{} -> Just $ JoinId arity Nothing+        _                   -> Nothing   in maybeModifyIdDetails details id  -- | Turn this id into a WorkerLikeId if possible. asWorkerLikeId :: Id -> Id asWorkerLikeId id =   let details = case idDetails id of-        WorkerLikeId{}      -> Nothing+        WorkerLikeId{}        -> Nothing         JoinId _arity Just{}  -> Nothing         JoinId arity Nothing  -> Just (JoinId arity (Just []))         VanillaId             -> Just $ WorkerLikeId []@@ -957,12 +982,11 @@ updOneShotInfo :: Id -> OneShotInfo -> Id -- Combine the info in the Id with new info updOneShotInfo id one_shot-  | do_upd    = setIdOneShotInfo id one_shot-  | otherwise = id-  where-    do_upd = case (idOneShotInfo id, one_shot) of-                (NoOneShotInfo, _) -> True-                (OneShotLam,    _) -> False+  | OneShotLam <- one_shot+  , NoOneShotInfo <- idOneShotInfo id+  = setIdOneShotInfo id OneShotLam+  | otherwise+  = id  -- The OneShotLambda functions simply fiddle with the IdInfo flag -- But watch out: this may change the type of something else@@ -979,8 +1003,9 @@ zapFragileIdInfo :: Id -> Id zapFragileIdInfo = zapInfo zapFragileInfo -zapIdDemandInfo :: Id -> Id-zapIdDemandInfo = zapInfo zapDemandInfo+floatifyIdDemandInfo :: Id -> Id+-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels+floatifyIdDemandInfo = zapInfo floatifyDemandInfo  zapIdUsageInfo :: Id -> Id zapIdUsageInfo = zapInfo zapUsageInfo
compiler/GHC/Types/Id.hs-boot view
@@ -1,6 +1,5 @@ module GHC.Types.Id where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name import {-# SOURCE #-} GHC.Types.Var
compiler/GHC/Types/Id/Info.hs view
@@ -8,9 +8,12 @@ Haskell. [WDP 94/11]) -} --{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,8 +21,11 @@         -- * The IdDetails type         IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,         JoinArity, isJoinIdDetails_maybe,-        RecSelParent(..), +        RecSelParent(..), recSelParentName, recSelFirstConName,+        recSelParentCons, idDetailsConcreteTvs,+        RecSelInfo(..), conLikesRecSelInfo,+         -- * The IdInfo type         IdInfo,         -- Abstract         vanillaIdInfo, noCafIdInfo,@@ -31,7 +37,8 @@          -- ** Zapping various forms of Info         zapLamInfo, zapFragileInfo,-        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,+        lazifyDemandInfo, floatifyDemandInfo,+        zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,         zapTailCallInfo, zapCallArityInfo, trimUnfolding,          -- ** The ArityInfo type@@ -95,20 +102,23 @@ import GHC.Types.Basic import GHC.Core.DataCon import GHC.Core.TyCon+import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn+import GHC.Core.ConLike import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars )  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Stg.InferTags.TagSig+import GHC.Stg.EnforceEpt.TagSig+import GHC.StgToCmm.Types (LambdaFormInfo) +import Data.Data ( Data ) import Data.Word--import GHC.StgToCmm.Types (LambdaFormInfo)+import Data.List as List( partition )  -- infixl so you can say (id `set` a `set` b) infixl  1 `setRuleInfo`,@@ -120,7 +130,8 @@           `setCafInfo`,           `setDmdSigInfo`,           `setCprSigInfo`,-          `setDemandInfo`+          `setDemandInfo`,+          `setLFInfo` {- ************************************************************************ *                                                                      *@@ -138,10 +149,14 @@    -- | The 'Id' for a record selector   | RecSelId-    { sel_tycon   :: RecSelParent-    , sel_naughty :: Bool       -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:+    { sel_tycon      :: RecSelParent+    , sel_fieldLabel :: FieldLabel+    , 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+                                -- See Note [Naughty record selectors] in GHC.Tc.TyCl+    , 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/@@ -150,14 +165,36 @@                                 --  a) to support isImplicitId                                 --  b) when desugaring a RecordCon we can get                                 --     from the Id back to the data con]-  | ClassOpId Class             -- ^ The 'Id' is a superclass selector,-                                -- or class operation of a class -  | PrimOpId PrimOp Bool        -- ^ The 'Id' is for a primitive operator-                                -- True <=> is representation-polymorphic,-                                --          and hence has no binding-                                -- This lev-poly flag is used only in GHC.Types.Id.hasNoBinding+  | ClassOpId                   -- ^ The 'Id' is a superclass selector or class operation+      Class                     --    for this class+      Bool                      --   True <=> given a non-bottom dictionary, the class op will+                                --            definitely return a non-bottom result+                                --   and Note [exprOkForSpeculation and type classes]+                                --       in GHC.Core.Utils +  -- | A representation-polymorphic pseudo-op.+  | RepPolyId+      { id_concrete_tvs :: ConcreteTyVars }+        -- ^ Which type variables of this representation-polymorphic 'Id+        -- should be instantiated to concrete type variables?+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Utils.Concrete.++  -- | The 'Id' is for a primitive operator.+  | PrimOpId+     { id_primop :: PrimOp+     , id_concrete_tvs :: ConcreteTyVars }+        -- ^ Which type variables of this primop should be instantiated+        -- to concrete type variables?+        --+        -- Only ever non-empty when the PrimOp has representation-polymorphic+        -- type variables.+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Utils.Concrete.+   | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.                                 -- Type will be simple: no type families, newtypes, etc @@ -183,19 +220,43 @@         -- 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+    RepPolyId  conc_tvs -> conc_tvs+    DataConWorkId dc    -> dataConConcreteTyVars dc+    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@@ -215,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@@ -268,17 +329,49 @@ if there are unapplied occurrences like `map f xs`. -} --- | Recursive Selector Parent-data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq-  -- Either `TyCon` or `PatSyn` depending-  -- on the origin of the record selector.-  -- For a data type family, this is the-  -- /instance/ 'TyCon' not the family 'TyCon'+-- | Parent of a record selector function.+--+-- Either the parent 'TyCon' or 'PatSyn' depending+-- on the origin of the record selector.+--+-- For a data family, this is the /instance/ 'TyCon',+-- **not** the family 'TyCon'.+data RecSelParent+  -- | Parent of a data constructor record field.+  --+  -- For a data family, this is the /instance/ 'TyCon'.+  = RecSelData TyCon+  -- | Parent of a pattern synonym record field:+  -- the 'PatSyn' itself.+  | RecSelPatSyn PatSyn+  deriving (Eq, Data) +recSelParentName :: RecSelParent -> Name+recSelParentName (RecSelData   tc) = tyConName tc+recSelParentName (RecSelPatSyn ps) = patSynName ps++recSelFirstConName :: RecSelParent -> Name+recSelFirstConName (RecSelData   tc) = dataConName $ head $ tyConDataCons tc+recSelFirstConName (RecSelPatSyn ps) = patSynName ps++recSelParentCons :: RecSelParent -> [ConLike]+recSelParentCons (RecSelData tc)+  | isAlgTyCon tc+      = map RealDataCon $ visibleDataCons+      $ algTyConRhs tc+  | otherwise+      = []+recSelParentCons (RecSelPatSyn ps) = [PatSynCon ps]+ instance Outputable RecSelParent where   ppr p = case p of-            RecSelData ty_con -> ppr ty_con-            RecSelPatSyn ps   -> ppr ps+    RecSelData tc+      | Just (parent_tc, tys) <- tyConFamInst_maybe tc+      -> ppr (mkTyConApp parent_tc tys)+      | otherwise+      -> ppr tc+    RecSelPatSyn ps+      -> ppr ps  -- | Just a synonym for 'CoVarId'. Written separately so it can be -- exported in the hs-boot file.@@ -302,10 +395,11 @@ pprIdDetails other     = brackets (pp other)  where    pp VanillaId               = panic "pprIdDetails"-   pp (WorkerLikeId dmds)   = text "StrictWorker" <> parens (ppr dmds)+   pp (WorkerLikeId dmds)     = text "StrictWorker" <> parens (ppr dmds)    pp (DataConWorkId _)       = text "DataCon"    pp (DataConWrapId _)       = text "DataConWrapper"    pp (ClassOpId {})          = text "ClassOp"+   pp (RepPolyId {})          = text "RepPolyId"    pp (PrimOpId {})           = text "PrimOp"    pp (FCallId _)             = text "ForeignCall"    pp (TickBoxOpId _)         = text "TickBoxOp"@@ -369,7 +463,12 @@         --         -- See documentation of the getters for what these packed fields mean.         lfInfo          :: !(Maybe LambdaFormInfo),-        -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure+        -- ^ If lfInfo = Just info, then the `info` is guaranteed /correct/.+        --   If lfInfo = Nothing, then we do not have a `LambdaFormInfo` for this Id,+        --                so (for imported Ids) we make a conservative version.+        --                See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure+        -- For locally-defined Ids other than DataCons, the `lfInfo` field is always Nothing.+        -- See also Note [LFInfo of DataCon workers and wrappers]          -- See documentation of the getters for what these packed fields mean.         tagSig          :: !(Maybe TagSig)@@ -772,11 +871,21 @@      is_safe_dmd dmd = not (isStrUsedDmd dmd) --- | Remove all demand info on the 'IdInfo'-zapDemandInfo :: IdInfo -> Maybe IdInfo-zapDemandInfo info = Just (info {demandInfo = topDmd})+-- | Lazify (remove the top-level demand, only) the demand in `IdInfo`+-- Keep nested demands; see Note [Floatifying demand info when floating]+-- in GHC.Core.Opt.SetLevels+lazifyDemandInfo :: IdInfo -> Maybe IdInfo+lazifyDemandInfo info@(IdInfo { demandInfo = dmd })+  = Just (info {demandInfo = lazifyDmd dmd }) --- | Remove usage (but not strictness) info on the 'IdInfo'+-- | Floatify the demand in `IdInfo`+-- But keep /nested/ demands; see Note [Floatifying demand info when floating]+-- in GHC.Core.Opt.SetLevels+floatifyDemandInfo :: IdInfo -> Maybe IdInfo+floatifyDemandInfo info@(IdInfo { demandInfo = dmd })+  = Just (info {demandInfo = floatifyDmd dmd })++-- | Remove usage (but not strictness) info on the `IdInfo` zapUsageInfo :: IdInfo -> Maybe IdInfo zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
compiler/GHC/Types/Id/Make.hs view
@@ -12,16 +12,15 @@ - primitive operations -} -- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE DataKinds #-}  module GHC.Types.Id.Make (         mkDictFunId, mkDictSelId, mkDictSelRhs,          mkFCallId, -        unwrapNewTypeBody, wrapFamInstBody,+        wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody,         DataConBoxer(..), vanillaDataConBoxer,         mkDataConRep, mkDataConWorkId,         DataConBangOpts (..), BangOpts (..),@@ -38,6 +37,9 @@         noinlineId, noinlineIdName,         noinlineConstraintId, noinlineConstraintIdName,         coerceName, leftSectionName, rightSectionName,+        pcRepPolyId,++        mkRepPolyIdConcreteTyVars,     ) where  import GHC.Prelude@@ -52,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@@ -65,8 +68,10 @@  import GHC.Types.Literal import GHC.Types.SourceText+import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) import GHC.Types.Name.Set import GHC.Types.Name+import GHC.Types.Name.Env import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Types.Id.Info@@ -74,19 +79,23 @@ import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Basic       hiding ( SuccessFlag(..) )-import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike)+import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName) +import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import GHC.Data.FastString import GHC.Data.List.SetOps import Data.List        ( zipWith4 ) +-- A bit of a shame we must import these here+import GHC.StgToCmm.Types (LambdaFormInfo(..))+import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown))+ {- ************************************************************************ *                                                                      *@@ -149,12 +158,15 @@   * May have IdInfo that differs from what would be imported from GHC.Magic.hi.     For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic]. -  The two remaining identifiers in GHC.Magic, runRW# and inline, are not listed-  in magicIds: they have special behavior but they can be known-key and+  The two remaining identifiers in GHC.Magic, runRW# and inline, are not+  listed in magicIds: they have special behavior but they can be known-key and   not wired-in.-  runRW#: see Note [Simplification of runRW#] in Prep, runRW# code in-  Simplifier, Note [Linting of runRW#].-  inline: see Note [inlineId magic]+  Similarly for GHC.Internal.IO.seq# and GHC.Internal.Exts.considerAccessible.+  runRW#:             see Note [Simplification of runRW#] in Prep,+                      runRW# code in Simplifier, Note [Linting of runRW#].+  seq#:               see Note [seq# magic]+  inline:             see Note [inlineId magic]+  considerAccessible: see Note [considerAccessible] -}  wiredInIds :: [Id]@@ -374,7 +386,7 @@ Note [Representation polymorphism invariants] in GHC.Core), and it's saturated, no representation-polymorphic code ends up in the code generator. The saturation condition is effectively checked in-GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs.+GHC.Tc.Gen.Head.rejectRepPolyNewtypes.  However, if we make a *wrapper* for a newtype, we get into trouble. In that case, we generate a forbidden representation-polymorphic@@ -464,45 +476,36 @@ 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) name sel_ty info+  = 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     arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses     val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name -    sel_ty = mkInvisForAllTys tyvars $-             mkFunctionType ManyTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $-             scaledThing (getNth arg_tys val_index)-               -- See Note [Type classes and linear types]+    pred_ty = mkClassPred clas (mkTyVarTys (binderVars tyvars))+    res_ty  = scaledThing (getNth arg_tys val_index)+    sel_ty  = mkForAllTys tyvars $+              mkFunctionType ManyTy pred_ty res_ty+             -- See Note [Type classes and linear types] +    terminating = isTerminatingType res_ty || definitelyUnliftedType res_ty+                  -- If the field is unlifted, it can't be bottom+                  -- Ditto if it's a terminating type+     base_info = noCafIdInfo                 `setArityInfo`  1                 `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@@ -515,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@@ -529,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 } @@ -556,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@@ -573,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@@ -590,29 +602,124 @@                    `setInlinePragInfo`     wkr_inline_prag                    `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,                                                            -- even if arity = 0-          -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon+                   `setDmdSigInfo`         wkr_sig+                      -- Workers eval their strict fields+                      -- See Note [Strict fields in Core]+                   `setLFInfo`             wkr_lf_info      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+      | otherwise      = LFReEntrant TopLevel (countFunRepArgs wkr_arity wkr_ty) True ArgUnknown+                                            -- 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-    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)  {-+Note [LFInfo of DataCon workers and wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's+crucial that saturated data con applications are given an LFInfo of `LFCon`.++Since for data constructors we never serialise the worker and the wrapper (only+the data type declaration), we never serialise their lambda form info either.++Therefore, when making data constructors workers and wrappers, we construct a+correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the+worker/wrapper Id, ensuring that:++  The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo.++How do we construct a /correct/ LFInfo for workers and wrappers?+(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`,+       `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`.++(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`.++For example, consider the following data constructors:++  data T1 a where+    TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a++  data T2 a where+    TCon2 :: {-# UNPACK #-} !() -> T2 a++  data T3 a where+    TCon3 :: T3 '[]++`TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the+worker has an unlifted equality argument, which is zero-width.++`TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the+worker has no arguments.++Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an+`LFCon` even though the /worker/ is not. Consider `T3` above. Here is the+Core representation of the worker and wrapper:++  $WTCon3 :: T3 '[]             -- Wrapper+  $WTCon3 = TCon3 @[] <Refl>    -- A saturated constructor application: LFCon++  TCon3 :: forall (a :: * -> *). (a ~# []) => T a   -- Worker+  TCon3 = /\a. \(co :: a~#[]). TCon3 co             -- A function: LFReEntrant++For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they+both have arity == 1.++For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1+while the worker is `LFCon` since its arity == 0++For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the+worker `LFReEntrant` since its arity == 1++One might think we could give *workers* with only zero-width-args the `LFCon`+LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`.+However, these workers are unambiguously functions+-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct.+See also the discussion in #23158.++Wrinkles:++(W1) Why do we panic when generating `LFInfo` for newtype workers and wrappers?++  We don't generate code for newtype workers/wrappers, so we should never have to+  look at their LFInfo (and in general we can't; they may be representation-polymorphic).++See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]+in GHC.StgToCmm.Types.+ ------------------------------------------------- --         Data constructor representation --@@ -681,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@@ -704,11 +811,20 @@                              -- We need to get the CAF info right here because GHC.Iface.Tidy                              -- does not tidy the IdInfo of implicit bindings (like the wrapper)                              -- so it not make sure that the CAF info is sane+                         `setLFInfo`            wrap_lf_info               -- The signature is purely for passes like the Simplifier, not for              -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers].              wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv +             -- See Note [LFInfo of DataCon workers and wrappers]+             wrap_lf_info+               | wrap_arity == 0  = LFCon data_con+               -- See W1 in Note [LFInfo of DataCon workers and wrappers]+               | isNewTyCon tycon = panic "mkDataConRep: we shouldn't look at LFInfo for newtype wrapper ids"+               | otherwise        = LFReEntrant TopLevel (countFunRepArgs wrap_arity wrap_ty) True ArgUnknown+                                                      -- LFInfo stores post-unarisation arity+              wrap_arg_dmds =                replicate (length theta) topDmd ++ map mk_dmd arg_ibangs                -- Don't forget the dictionary arguments when building@@ -732,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)@@ -796,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@@ -830,8 +946,7 @@     mk_boxer boxers = DCB (\ ty_args src_vars ->                       do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars                                subst1 = zipTvSubst univ_tvs ty_args-                               subst2 = extendTCvSubstList subst1 ex_tvs-                                                           (mkTyCoVarTys ex_vars)+                               subst2 = foldl2 extendTvSubstWithClone subst1 ex_tvs ex_vars                          ; (rep_ids, binds) <- go subst2 boxers term_vars                          ; return (ex_vars ++ rep_ids, binds) } ) @@ -1069,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@@ -1099,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) @@ -1401,50 +1513,109 @@           | otherwise   -- Wrinkle (W4) of Note [Recursive unboxing]           -> bang_opt_unbox_strict bang_opts              || (bang_opt_unbox_small bang_opts-                 && rep_tys `lengthAtMost` 1)  -- See Note [Unpack one-wide fields]+                 && is_small_rep)  -- See Note [Unpack one-wide fields]       where         (rep_tys, _) = dataConArgUnpack arg_ty +        -- Takes in the list of reps used to represent the dataCon after it's unpacked+        -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]+        is_small_rep =+          let -- Neccesary to look through unboxed tuples.+              prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys+              -- And then get the actual size of the unpacked constructor.+              rep_size = sum $ map primRepSizeW64_B prim_reps+          in rep_size <= 8+     is_sum :: [DataCon] -> Bool     -- We never unpack sum types automatically     -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)     is_sum (_:_:_) = True     is_sum _       = False --- Given a type already assumed to have been normalized by topNormaliseType,--- unpackable_type_datacons ty = Just datacons--- iff ty is of the form---     T ty1 .. tyn--- and T is an algebraic data type (not newtype), in which no data--- constructors have existentials, and datacons is the list of data--- constructors of T.++ unpackable_type_datacons :: Type -> Maybe [DataCon]+-- Given a type already assumed to have been normalized by topNormaliseType,+--    unpackable_type_datacons (T ty1 .. tyn) = Just datacons+-- iff the type can be unpacked (see Note [Unpacking GADTs and existentials])+-- and `datacons` are the data constructors of T unpackable_type_datacons ty   | Just (tc, _) <- splitTyConApp_maybe ty-  , not (isNewTyCon tc)  -- Even though `ty` has been normalised, it could still-                         -- be a /recursive/ newtype, so we must check for that+  , not (isNewTyCon tc)+      -- isNewTyCon: even though `ty` has been normalised, whic includes looking+      -- through newtypes, it could still be a /recursive/ newtype, so we must+      -- check for that case   , Just cons <- tyConDataCons_maybe tc-  , not (null cons)      -- Don't upack nullary sums; no need.-                         -- They already take zero bits-  , all (null . dataConExTyCoVars) cons-  = Just cons -- See Note [Unpacking GADTs and existentials]+  , unpackable_cons cons+  = Just cons   | otherwise   = Nothing+  where+    unpackable_cons :: [DataCon] -> Bool+    -- True if we can unpack a value of type (T t1 .. tn),+    -- where T is an algebraic data type with these constructors+    -- See Note [Unpacking GADTs and existentials]+    unpackable_cons []   -- Don't unpack nullary sums; no need.+      = False            -- They already take zero bits; see (UC0) +    unpackable_cons [con]   -- Exactly one data constructor; see (UC1)+      = null (dataConExTyCoVars con)++    unpackable_cons cons  -- More than one data constructor; see (UC2)+      = all isVanillaDataCon cons+ {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is nothing stopping us unpacking a data type with equality-components, like-  data Equal a b where-    Equal :: Equal a a+Can we unpack a value of an algebraic data type T? For example+   data D a = MkD {-# UNPACK #-} (T a)+Can we unpack that (T a) field? -And it'd be fine to unpack a product type with existential components-too, but that would require a bit more plumbing, so currently we don't.+Three cases to consider in `unpackable_cons` -So for now we require: null (dataConExTyCoVars data_con)-See #14978+(UC0) No data constructors; a nullary sum type.  This already takes zero+      bits so there is no point in unpacking it. +(UC1) Single-constructor types (products).  We can just represent it by+   its fields. For example, if `T` is defined as:+      data T a = MkT a a Int+   then we can unpack it as follows.  The worker for MkD takes three unpacked fields:+       data D a = MkD a a Int+       $MkD :: T a -> D a+       $MkD (MkT a1 a2 i) = MkD a1 a2 i++   We currently /can't/ do this if T has existentially-bound type variables,+   hence:   null (dataConExTyCoVars con)   in `unpackable_cons`.+   But see also (UC3) below.++   But we /can/ do it for (some) GADTs, such as:+      data Equal a b where { Equal :: Equal a a }+      data Wom a where { Wom1 :: Int -> Wom Bool }+   We will get a MkD constructor that includes some coercion arguments,+   but that is fine.   See #14978.  We still can't accommodate existentials,+   but these particular examples don't use existentials.++(UC2) Multi-constructor types, e.g.+        data T a = T1 a | T2 Int a+  Here we unpack the field to an unboxed sum type, thus:+    data D a = MkD (# a | (# Int, a #) #)++  However, now we can't deal with GADTs at all, because we'd need an+  unboxed sum whose component was a unboxed tuple, whose component(s)+  have kind (CONSTRAINT r); and that's not well-kinded.  Hence the+    all isVanillaDataCon+  condition in `unpackable_cons`. See #25672.++(UC3)  For single-constructor types, with some more plumbing we could+   allow existentials. e.g.+       data T a = forall b. MkT a (b->Int) b+   could unpack to+       data D a = forall b. MkD a (b->Int) b+       $MkD :: T a -> D a+       $MkD (MkT @b x f y) = MkD @b x f y+   Eminently possible, but more plumbing needed.++ Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The flag UnboxSmallStrictFields ensures that any field that can@@ -1469,6 +1640,14 @@  Here we can represent T with an Int#. +Special care has to be taken to make sure we don't mistake fields with unboxed+tuple/sum rep or very large reps. See #22309++For consistency we unpack anything that fits into 8 bytes on a 64-bit platform,+even when compiling for 32bit platforms. This way unpacking decisions will be the+same for 32bit and 64bit systems. To do so we use primRepSizeW64_B instead of+primRepSizeB. See also the tests in test case T22309.+ Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1666,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)  {- ************************************************************************@@ -1692,6 +1871,7 @@ failure when trying.) -} + nullAddrName, seqName,    realWorldName, voidPrimIdName, coercionTokenName,    coerceName, proxyName,@@ -1739,7 +1919,7 @@  ------------------------------------------------ seqId :: Id     -- See Note [seqId magic]-seqId = pcMiscPrelId seqName ty info+seqId = pcRepPolyId seqName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` inline_prag                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -1763,6 +1943,9 @@     rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $           Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] +    concs = mkRepPolyIdConcreteTyVars+        [ ((openBetaTy, mkArgPos 2 Top), runtimeRep2TyVar)]+     arity = 2  ------------------------------------------------@@ -1800,12 +1983,13 @@     info = noCafIdInfo     ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) -oneShotId :: Id -- See Note [The oneShot function]-oneShotId = pcMiscPrelId oneShotName ty info+oneShotId :: Id -- See Note [oneShot magic]+oneShotId = pcRepPolyId oneShotName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs                        `setArityInfo`      arity+    -- oneShot :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). (a -> b) -> (a -> b)     ty  = mkInfForAllTys  [ runtimeRep1TyVar, runtimeRep2TyVar ] $           mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ]      $           mkVisFunTyMany fun_ty fun_ty@@ -1818,6 +2002,9 @@           Var body `App` Var x'     arity = 2 +    concs = mkRepPolyIdConcreteTyVars+        [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)]+ ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1842,7 +2029,7 @@ --   is () and not undefined -- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList) leftSectionId :: Id-leftSectionId = pcMiscPrelId leftSectionName ty info+leftSectionId = pcRepPolyId leftSectionName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -1860,6 +2047,9 @@     body = mkLams [f,xmult] $ App (Var f) (Var xmult)     arity = 2 +    concs = mkRepPolyIdConcreteTyVars+            [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)]+ -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax] --   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).@@ -1867,7 +2057,7 @@ --   rightSection f y x = f x y -- Again, multiplicity polymorphism is important rightSectionId :: Id-rightSectionId = pcMiscPrelId rightSectionName ty info+rightSectionId = pcRepPolyId rightSectionName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -1890,10 +2080,15 @@     body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult]     arity = 3 +    concs =+      mkRepPolyIdConcreteTyVars+        [ ((openAlphaTy, mkArgPos 3 Top), runtimeRep1TyVar)+        , ((openBetaTy , mkArgPos 2 Top), runtimeRep2TyVar)]+ --------------------------------------------------------------------------------  coerceId :: Id-coerceId = pcMiscPrelId coerceName ty info+coerceId = pcRepPolyId coerceName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -1917,6 +2112,9 @@           mkWildCase (Var eqR) (unrestricted eqRTy) b $           [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))] +    concs = mkRepPolyIdConcreteTyVars+            [((mkTyVarTy av, mkArgPos 1 Top), rv)]+ {- Note [seqId magic] ~~~~~~~~~~~~~~~~~~@@ -2045,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. @@ -2074,13 +2272,116 @@ This is crucial: otherwise, we could import an unfolding in which 'nospec' has been inlined (= erased), and we would lose the benefit. -'nospec' is used in the implementation of 'withDict': we insert 'nospec'-so that the typeclass specialiser doesn't assume any two evidence terms-of the same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,-and see test case T21575b for an example.+'nospec' is used: -Note [The oneShot function]-~~~~~~~~~~~~~~~~~~~~~~~~~~~+* In the implementation of 'withDict': we insert 'nospec' so that the+  typeclass specialiser doesn't assume any two evidence terms of the+  same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,+  and see test case T21575b for an example.++* To defeat the specialiser when we have incoherent instances.+  See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv.++Note [seq# magic]+~~~~~~~~~~~~~~~~~+The purpose of the magic Id (See Note [magicIds])++  seq# :: forall a s . a -> State# s -> (# State# s, a #)++is to elevate evaluation of its argument `a` into an observable side effect.+This implies that GHC's optimisations must preserve the evaluation "exactly+here", in the state thread.++The main use of seq# is to implement `evaluate`++   evaluate :: a -> IO a+   evaluate a = IO $ \s -> seq# a s++Its (NOINLINE) definition in GHC.Magic is simply++   seq# a s = let !a' = lazy a in (# s, a' #)++Things to note++(SEQ1)+  It must be NOINLINE, because otherwise the eval !a' would be decoupled from+  the state token s, and GHC's optimisations, in particular strictness analysis,+  would happily move the eval around.++  However, we *do* inline saturated applications of seq# in CorePrep, where+  evaluation order is fixed; see the implementation notes below.+  This is one reason why we need seq# to be known-key.++(SEQ2)+  The use of `lazy` ensures that strictness analysis does not see the eval+  that takes place, so the final demand signature is <L><L>, not <1L><L>.+  This is important for a definition like++    foo x y = evaluate y >> evaluate x++  Although both y and x are ultimately evaluated, the user made it clear+  they want to evaluate y *before* x.+  But if strictness analysis sees the evals, it infers foo as strict in+  both parameters. This strictness would be exploited in the backend by+  picking a call-by-value calling convention for foo, one that would evaluate+  x *before* y. Nononono!++  Because the definition of seq# uses `lazy`, it must live in a different module+  (GHC.Internal.IO); otherwise strictness analysis uses its own strictness+  signature for the definition of `lazy` instead of the one we wire in.++(SEQ3)+  Why does seq# return the value? Consider+     let x = e in+     case seq# x s of (# _, x' #) -> ... x' ... case x' of __DEFAULT -> ...+  Here, we could simply use x instead of x', but doing so would+  introduce an unnecessary indirection and tag check at runtime;+  also we can attach an evaldUnfolding to x' to discard any+  subsequent evals such as the `case x' of __DEFAULT`.++(SEQ4)+  T15226 demonstrates that we want to discard ok-for-discard seq#s. That is,+  simplify `case seq# <ok-to-discard> s of (# s', _ #) -> rhs[s']` to `rhs[s]`.+  You might wonder whether the Simplifier could do this. But see the excellent+  example in #24334 (immortalised as test T24334) for why it should be done in+  CorePrep.++Implementing seq#.  The compiler has magic for `seq#` in++- GHC.CoreToStg.Prep.cpeRhsE: Implement (SEQ4).++- Simplify.addEvals records evaluated-ness for the result (cf. (SEQ3)); see+  Note [Adding evaluatedness info to pattern-bound variables]+  in GHC.Core.Opt.Simplify.Iteration++- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException:+  Historically, seq# used to be a primop, and the majority of primops+  should return False in exprMayThrowPreciseException, so we do the same+  for seq# for back compat.++- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g.,++    seq# (f 13) s+    ==>+    case f 13 of sat of __DEFAULT -> (# s, sat #)++  This is implemented in `cpeApp`, not unlike Note [runRW magic].+  We are only inlining seq#, leaving opportunities for case-of-known-con+  behind that are easily picked up by Unarise:++    case seq# f 13 s of (# s', r #) -> rhs+    ==> {Prep}+    case f 13 of sat of __DEFAULT -> case (# s, sat #) of (# s', r #) -> rhs+    ==> {Unarise}+    case f 13 of sat of __DEFAULT -> rhs[s/s',sat/r]++  Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`.+  That's OK, because the telescope of Floats always stays in the same order+  and won't be floated out of binders, so all guarantees of evaluation order+  provided by seq# are upheld.++Note [oneShot magic]+~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 and Note [Left folds via right fold]) it was determined that it would be useful if library authors could explicitly tell the compiler that a certain lambda is@@ -2104,13 +2405,19 @@  --> \x[oneshot] e[x/y] which is what we want. -It is only effective if the one-shot info survives as long as possible; in-particular it must make it into the interface in unfoldings. See Note [Preserve-OneShotInfo] in GHC.Core.Tidy.- Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. +Wrinkles:+(OS1)  It is only effective if the one-shot info survives as long as possible; in+       particular it must make it into the interface in unfoldings. See Note [Preserve+       OneShotInfo] in GHC.Core.Tidy. +(OS2) (oneShot (error "urk")) rewrites to+           \x[oneshot]. error "urk" x+      thereby hiding the `error` under a lambda, which might be surprising,+      particularly if you have `-fpedantic-bottoms` on.  See #24296.++ ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}.  If things get nasty as-is, change it back to a literal (@Literal@).@@ -2161,3 +2468,28 @@ pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info   = mkVanillaGlobalWithInfo name ty info++pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id+pcRepPolyId name ty conc_tvs info =+  mkGlobalId (RepPolyId $ conc_tvs name) name ty info++-- | Directly specify which outer forall'd type variables of a+-- representation-polymorphic 'Id' such become concrete metavariables when+-- instantiated.+mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)]+                               -- ^ ((ty, pos), tv)+                               -- 'ty' is the type on which the representation-polymorphism+                               -- check is done+                               -- 'tv' is the type variable we are checking for concreteness+                               -- (usually the kind of 'ty')+                               -- 'pos' is the position of 'ty' in the+                               -- type of the 'Id'+                          -> Name -- ^ 'Name' of the rep-poly 'Id'+                          -> ConcreteTyVars+mkRepPolyIdConcreteTyVars vars nm =+  mkNameEnv [ (tyVarName tv, mk_conc_frr ty pos)+            | ((ty,pos), tv) <- vars ]+  where+    mk_conc_frr ty pos =+      ConcreteFRR $ FixedRuntimeRepOrigin ty+                  $ FRRRepPolyId nm RepPolyFunction pos
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         (@@ -32,7 +30,7 @@         , mkLitFloat, mkLitDouble         , mkLitChar, mkLitString         , mkLitBigNat-        , mkLitNumber, mkLitNumberWrap+        , mkLitNumber, mkLitNumberWrap, mkLitNumberMaybe          -- ** Operations on Literals         , literalType@@ -86,6 +84,7 @@ import Data.Data ( Data ) import GHC.Exts( isTrue#, dataToTag#, (<#) ) import Numeric ( fromRat )+import Control.DeepSeq  {- ************************************************************************@@ -136,8 +135,8 @@   | LitRubbish                  -- ^ A nonsense value; See Note [Rubbish literals].       TypeOrConstraint          -- t_or_c: whether this is a type or a constraint       RuntimeRepType            -- rr: a type of kind RuntimeRep-      -- The type of the literal is forall (a:TYPE rr). a-      --                         or forall (a:CONSTRAINT rr). a+      -- The type of the literal is forall (a::TYPE rr). a+      --                         or forall (a::CONSTRAINT rr). a       --       -- INVARIANT: the Type has no free variables       --    and so substitution etc can ignore it@@ -145,19 +144,13 @@   | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'   | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble' -  | LitLabel   FastString (Maybe Int) FunctionOrData+  | LitLabel   FastString FunctionOrData                                 -- ^ A label literal. Parameters:                                 --                                 -- 1) The name of the symbol mentioned in the                                 --    declaration                                 ---                                -- 2) The size (in bytes) of the arguments-                                --    the label expects. Only applicable with-                                --    @stdcall@ labels. @Just x@ => @\<x\>@ will-                                --    be appended to label name when emitting-                                --    assembly.-                                ---                                -- 3) Flag indicating whether the symbol+                                -- 2) Flag indicating whether the symbol                                 --    references a function or a data   deriving Data @@ -212,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] ~~~~~~~~~~~~~~~~~~~~~~@@ -259,10 +266,9 @@     put_ bh (LitNullAddr)    = putByte bh 2     put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah     put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai-    put_ bh (LitLabel aj mb fod)+    put_ bh (LitLabel aj fod)         = do putByte bh 5              put_ bh aj-             put_ bh mb              put_ bh fod     put_ bh (LitNumber nt i)         = do putByte bh 6@@ -289,15 +295,24 @@                     return (LitDouble ai)               5 -> do                     aj <- get bh-                    mb <- get bh                     fod <- get bh-                    return (LitLabel aj mb fod)+                    return (LitLabel aj fod)               6 -> do                     nt <- get bh                     i  <- get bh                     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@@ -336,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@@ -353,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@@ -372,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)  @@ -411,6 +429,12 @@   assertPpr (litNumCheckRange platform nt i) (integer i)   (LitNumber nt i) +-- | Create a numeric 'Literal' of the given type if it is in range+mkLitNumberMaybe :: Platform -> LitNumType -> Integer -> Maybe Literal+mkLitNumberMaybe platform nt i+  | litNumCheckRange platform nt i = Just (LitNumber nt i)+  | otherwise                      = Nothing+ -- | Creates a 'Literal' of type @Int#@ mkLitInt :: Platform -> Integer -> Literal mkLitInt platform x = assertPpr (platformInIntRange platform x) (integer x)@@ -431,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@@ -455,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@@ -837,7 +861,7 @@ literalType (LitString  _)    = addrPrimTy literalType (LitFloat _)      = floatPrimTy literalType (LitDouble _)     = doublePrimTy-literalType (LitLabel _ _ _)  = addrPrimTy+literalType (LitLabel _ _)    = addrPrimTy literalType (LitNumber lt _)  = case lt of    LitNumBigNat  -> byteArrayPrimTy    LitNumInt     -> intPrimTy@@ -868,7 +892,7 @@ cmpLit (LitNullAddr)        (LitNullAddr)         = EQ cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b-cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `lexicalCompareFS` b+cmpLit (LitLabel     a _)   (LitLabel      b _)   = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a)    (LitNumber nt2  b)   = (nt1 `compare` nt2) `mappend` (a `compare` b) cmpLit (LitRubbish tc1 b1)  (LitRubbish tc2 b2)  = (tc1 `compare` tc2) `mappend`@@ -902,11 +926,8 @@        LitNumWord16  -> pprPrimWord16 i        LitNumWord32  -> pprPrimWord32 i        LitNumWord64  -> pprPrimWord64 i-pprLiteral add_par (LitLabel l mb fod) =-    add_par (text "__label" <+> b <+> ppr fod)-    where b = case mb of-              Nothing -> pprHsString l-              Just x  -> doubleQuotes (ftext l <> text ('@':show x))+pprLiteral add_par (LitLabel l fod) =+    add_par (text "__label" <+> pprHsString l <+> ppr fod) pprLiteral _       (LitRubbish torc rep)   = text "RUBBISH" <> pp_tc <> parens (ppr rep)   where
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,7 +1,10 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- instance NFData FieldLabel+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -56,15 +59,17 @@         localiseName,         namePun_maybe, -        pprName,+        pprName, pprName_userQual,         nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,-        pprFullName, pprTickyName,+        pprFullName, pprFullNameWithUnique, pprTickyName,          -- ** Predicates on 'Name's         isSystemName, isInternalName, isExternalName,         isTyVarName, isTyConName, isDataConName,-        isValName, isVarName, isDynLinkName,-        isWiredInName, isWiredIn, isBuiltInSyntax,+        isValName, isVarName, isDynLinkName, isFieldName,+        isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName,+        isSumTyConName,+        isUnboxedTupleDataConLikeName,         isHoleName,         wiredInNameTyThing_maybe,         nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage,@@ -91,6 +96,7 @@ import GHC.Types.Name.Occurrence import GHC.Unit.Module import GHC.Unit.Home+import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Utils.Misc@@ -99,10 +105,14 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.OldList (intersperse)  import Control.DeepSeq import Data.Data import qualified Data.Semigroup as S+import GHC.Types.Basic (Boxity(Boxed, Unboxed))+import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique,+                             isSumTyConUnique, isTupleDataConLikeUnique )  {- ************************************************************************@@ -138,12 +148,16 @@ -- See Note [About the NameSorts] data NameSort   = External Module+        -- Either an import from another module+        -- or a top-level name+        -- See Note [About the NameSorts]    | WiredIn Module TyThing BuiltInSyntax         -- A variant of External, for wired-in things -  | Internal            -- A user-defined Id or TyVar+  | Internal            -- A user-defined local Id or TyVar                         -- defined in the module being compiled+                        -- See Note [About the NameSorts]    | System              -- A system-defined Id or TyVar.  Typically the                         -- OccName is very uninformative (like 's')@@ -157,6 +171,10 @@ instance NFData Name where   rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc +-- Needs NFData Name, so the instance is here to avoid cyclic imports.+instance NFData FieldLabel where+  rnf (FieldLabel a b c) = rnf a `seq` rnf b `seq` rnf c+ instance NFData NameSort where   rnf (External m) = rnf m   rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` ()@@ -176,18 +194,18 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this wired-in Name in GHC.Builtin.Names: -   int8TyConName = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey+   int8TyConName = tcQual gHC_INTERNAL_INT  (fsLit "Int8")  int8TyConKey  Ultimately this turns into something like: -   int8TyConName = Name gHC_INT (mkOccName ..."Int8") int8TyConKey+   int8TyConName = Name gHC_INTERNAL_INT (mkOccName ..."Int8") int8TyConKey  So a comparison like `x == int8TyConName` will turn into `getUnique x == int8TyConKey`, nice and efficient.  But if the `n_occ` field is strict, that definition will look like: -   int8TyCOnName = case (mkOccName..."Int8") of occ ->-                   Name gHC_INT occ int8TyConKey+   int8TyConName = case (mkOccName..."Int8") of occ ->+                   Name gHC_INTERNAL_INT occ int8TyConKey  and now the comparison will not optimise.  This matters even more when there are numerous comparisons (see #19386):@@ -204,21 +222,32 @@ {- Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~+1.  Initially:+    * 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 -1.  Initially, top-level Ids (including locally-defined ones) get External names,-    and all other local Ids get Internal names+2.  In the Tidy phase (GHC.Iface.Tidy):+      * An Id that is "externally-visible" is given an External Name,+        even if the name was Internal up to that point+      * An Id that is not externally visible is given an Internal Name.+        even if the name was External up to that point+    See GHC.Iface.Tidy.tidyTopName -2.  In any invocation of GHC, an External Name for "M.x" has one and only one+    An Id is externally visible if it is mentioned in the interface file; e.g.+        - it is exported+        - it is mentioned in an unfolding+    See GHC.Iface.Tidy.chooseExternalIds++3.  In any invocation of GHC, an External Name for "M.x" has one and only one     unique.  This unique association is ensured via the Name Cache;     see Note [The Name Cache] in GHC.Iface.Env. -3.  Things with a External name are given C static labels, so they finally-    appear in the .o file's symbol table.  They appear in the symbol table-    in the form M.n.  If originally-local things have this property they-    must be made @External@ first.+4.  In code generation, things with a External name are given C static+    labels, so they finally appear in the .o file's symbol table.  They+    appear in the symbol table in the form M.n. That is why+    externally-visible things are made External (see (2) above). -4.  In the tidy-core phase, a External that is not visible to an importer-    is changed to Internal, and a Internal that is visible is changed to External  5.  A System Name differs in the following ways:         a) has unique attached when printing dumps@@ -230,13 +259,13 @@     If any desugarer sys-locals have survived that far, they get changed to     "ds1", "ds2", etc. -Built-in syntax => It's a syntactic form, not "in scope" (e.g. [])+6. A WiredIn Name is used for things (Id, TyCon) that are fully known to the compiler,+   not read from an interface file. E.g. Bool, True, Int, Float, and many others. -Wired-in thing  => The thing (Id, TyCon) is fully known to the compiler,-                   not read from an interface file.-                   E.g. Bool, True, Int, Float, and many others+   A WiredIn Name contains contains a TyThing, so we don't have to look it up. -All built-in syntax is for wired-in things.+   The BuiltInSyntax flag => It's a syntactic form, not "in scope" (e.g. [])+   All built-in syntax things are WiredIn. -}  instance HasOccName Name where@@ -282,6 +311,18 @@ isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True isBuiltInSyntax _                                           = False +isTupleTyConName :: Name -> Bool+isTupleTyConName = isJust . isTupleTyConUnique . getUnique++isSumTyConName :: Name -> Bool+isSumTyConName = isJust . isSumTyConUnique . getUnique++-- | This matches a datacon as well as its worker and promoted tycon.+isUnboxedTupleDataConLikeName :: Name -> Bool+isUnboxedTupleDataConLikeName n+  | Just (Unboxed, _) <- isTupleDataConLikeUnique (getUnique n) = True+  | otherwise = False+ isExternalName (Name {n_sort = External _})    = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True isExternalName _                               = False@@ -338,8 +379,30 @@  -- Return the pun for a name if available. -- Used for pretty-printing under ListTuplePuns.+-- Arity 1 is skipped here because unary tuples have no prefix representation,+-- since that is occupied by the unit tuple. namePun_maybe :: Name -> Maybe FastString-namePun_maybe name | getUnique name == getUnique listTyCon = Just (fsLit "[]")+namePun_maybe name+  | getUnique name == getUnique listTyCon = Just (fsLit "[]")++  | Just (boxity, ar) <- isTupleTyConUnique (getUnique name)+  , 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+    commas ar = replicate (ar-1) ','+    bars ar = intersperse ' ' (replicate (ar-1) '|')+ namePun_maybe _ = Nothing  nameIsLocalOrFrom :: Module -> Name -> Bool@@ -424,6 +487,9 @@ isVarName :: Name -> Bool isVarName = isVarOcc . nameOccName +isFieldName :: Name -> Bool+isFieldName = isFieldOcc . nameOccName+ isSystemName (Name {n_sort = System}) = True isSystemName _                        = False @@ -569,7 +635,7 @@ -- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which -- means that the ordering is not stable across deserialization or rebuilds. ----- See `nonDetCmpUnique` for further information, and trac #15240 for a bug+-- See `nonDetCmpUnique` for further information, and #15240 for a bug -- caused by improper use of this instance.  -- For a deterministic lexicographic ordering, use `stableNameCmp`.@@ -602,12 +668,12 @@ -- distinction. instance Binary Name where    put_ bh name =-      case getUserData bh of-        UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name+      case findUserDataWriter Proxy bh of+        tbl -> putEntry tbl bh name     get bh =-      case getUserData bh of-        UserData { ud_get_name = get_name } -> get_name bh+      case findUserDataReader Proxy bh of+        tbl -> getEntry tbl bh  {- ************************************************************************@@ -626,28 +692,41 @@     pprPrefixOcc = pprPrefixName  pprName :: forall doc. IsLine doc => Name -> doc-pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})-  = docWithContext $ \ctx ->-    let sty = sdocStyle ctx-        debug = sdocPprDebug ctx-        listTuplePuns = sdocListTuplePuns ctx-    in 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-      System                  -> pprSystem   debug sty uniq occ-      Internal                -> pprInternal debug sty uniq 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-    -- Print GHC.Types.List as [], etc.-    handlePuns :: Bool -> Maybe FastString -> doc -> doc-    handlePuns True (Just pun) _ = ftext pun-    handlePuns _    _          r = r+   codeDoc = case sort of+               WiredIn mod _ _ -> pprModule mod <> char '_' <> z_occ+               External mod    -> pprModule mod <> char '_' <> z_occ+                                  -- In code style, always qualify+                                  -- ToDo: maybe we could print all wired-in things unqualified+                                  --       in code style, to reduce symbol table bloat?+               System          -> pprUniqueAlways uniq+               Internal        -> pprUniqueAlways uniq+   z_occ = ztext $ zEncodeFS $ occNameMangledFS occ++   normalDoc sty =+     getPprDebug $ \debug ->+     sdocOption sdocListTuplePuns $ \listTuplePuns ->+       handlePuns listTuplePuns (namePun_maybe name) $+       case sort of+         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++   handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc+   handlePuns True (Just pun) _ = ftext pun+   handlePuns _    _          r = r {-# SPECIALISE pprName :: Name -> SDoc #-} {-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable --- | Print fully qualified name (with unit-id, module and unique)+-- | Print fully qualified name (with unit-id and module, but no unique) pprFullName :: Module -> Name -> SDoc-pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} =+pprFullName this_mod Name{n_sort = sort, n_occ = occ} =   let mod = case sort of         WiredIn  m _ _ -> m         External m     -> m@@ -656,8 +735,18 @@       in ftext (unitIdFS (moduleUnitId mod))          <> colon    <> ftext (moduleNameFS $ moduleName mod)          <> dot      <> ftext (occNameFS occ)-         <> char '_' <> pprUniqueAlways uniq +-- | 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 --@@ -674,12 +763,14 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc-pprExternal debug sty uniq mod occ is_wired is_builtin-  | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ-        -- In code style, always qualify-        -- ToDo: maybe we could print all wired-in things unqualified-        --       in code style, to reduce symbol table bloat?+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),@@ -687,17 +778,16 @@   | 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) -pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc+pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc pprInternal debug sty uniq occ-  | codeStyle sty  = pprUniqueAlways uniq   | debug          = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),                                                        pprUnique uniq])   | dumpStyle sty  = ppr_occ_name occ <> ppr_underscore_unique uniq@@ -706,9 +796,8 @@   | otherwise      = ppr_occ_name occ   -- User style  -- Like Internal, except that we only omit the unique in Iface style-pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc-pprSystem debug sty uniq occ-  | codeStyle sty  = pprUniqueAlways uniq+pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc+pprSystem debug _sty uniq occ   | debug          = ppr_occ_name occ <> ppr_underscore_unique uniq                      <> braces (pprNameSpaceBrief (occNameSpace occ))   | otherwise      = ppr_occ_name occ <> ppr_underscore_unique uniq@@ -717,40 +806,35 @@                                 -- so print the unique  -pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc+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                           <> pprModuleName (moduleName mod) <> dot    -- scope either       NameUnqual       -> empty                   -- In scope unqualified -pprUnique :: IsLine doc => Unique -> doc+pprUnique :: Unique -> SDoc -- Print a unique unless we are suppressing them pprUnique uniq   = ppUnlessOption sdocSuppressUniques $       pprUniqueAlways uniq -ppr_underscore_unique :: IsLine doc => Unique -> doc+ppr_underscore_unique :: Unique -> SDoc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq   = ppUnlessOption sdocSuppressUniques $       char '_' <> pprUniqueAlways uniq -ppr_occ_name :: IsLine doc => OccName -> doc+ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ)         -- Don't use pprOccName; instead, just print the string of the OccName;         -- we print the namespace in the debug stuff above --- In code style, we Z-encode the strings.  The results of Z-encoding each FastString are--- cached behind the scenes in the FastString implementation.-ppr_z_occ_name :: IsLine doc => OccName -> doc-ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))- -- Prints (if mod information is available) "Defined at <loc>" or --  "Defined in <mod>" information for a Name. pprDefinedAt :: Name -> SDoc@@ -819,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.hs-boot view
@@ -3,7 +3,7 @@     module GHC.Types.Name.Occurrence ) where -import GHC.Prelude (Eq)+import GHC.Prelude (Eq, Bool) import {-# SOURCE #-} GHC.Types.Name.Occurrence import GHC.Types.Unique import GHC.Utils.Outputable@@ -28,3 +28,4 @@ setNameUnique :: Name -> Unique -> Name nameOccName :: Name -> OccName tidyNameOcc :: Name -> OccName -> Name+isFieldName :: Name -> Bool
compiler/GHC/Types/Name/Cache.hs view
@@ -1,9 +1,10 @@- {-# LANGUAGE RankNTypes #-}  -- | The Name Cache module GHC.Types.Name.Cache   ( NameCache (..)+  , newNameCache+  , newNameCacheWith   , initNameCache   , takeUniqFromNameCache   , updateNameCache'@@ -14,6 +15,10 @@   , lookupOrigNameCache   , extendOrigNameCache'   , extendOrigNameCache++  -- * Known-key names+  , knownKeysOrigNameCache+  , isKnownOrigName_maybe   ) where @@ -24,10 +29,12 @@ 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 @@ -57,35 +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 tuples and unboxed sums 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) 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 syntax directly as Exact RdrNames, and 2) built-in 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 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.@@ -101,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_TUPLE_PRIM-  , Just name <- isBuiltInOcc_maybe 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@@ -125,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@@ -158,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
@@ -5,22 +5,22 @@ \section[NameEnv]{@NameEnv@: name environments} -} --{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}- module GHC.Types.Name.Env (         -- * Var, Id and TyVar environments (maps)         NameEnv,          -- ** Manipulating these environments         mkNameEnv, mkNameEnvWith,+        fromUniqMap,         emptyNameEnv, isEmptyNameEnv,         unitNameEnv, nonDetNameEnvElts,         extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,         extendNameEnvList, extendNameEnvList_C,-        filterNameEnv, mapMaybeNameEnv, anyNameEnv,+        filterNameEnv, anyNameEnv,+        mapMaybeNameEnv,+        extendNameEnvListWith,         plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv,+        plusNameEnvList, plusNameEnvListWith,         lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,         elemNameEnv, mapNameEnv, disjointNameEnv,         seqEltsNameEnv,@@ -47,6 +47,7 @@ import GHC.Types.Name import GHC.Types.Unique.FM import GHC.Types.Unique.DFM+import GHC.Types.Unique.Map import GHC.Data.Maybe  {-@@ -103,6 +104,7 @@ isEmptyNameEnv     :: NameEnv a -> Bool mkNameEnv          :: [(Name,a)] -> NameEnv a mkNameEnvWith      :: (a -> Name) -> [a] -> NameEnv a+fromUniqMap        :: UniqMap Name a -> NameEnv a nonDetNameEnvElts  :: NameEnv a -> [a] alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a@@ -112,7 +114,10 @@ plusNameEnv_C      :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_CD     :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a plusNameEnv_CD2    :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a+plusNameEnvList    :: [NameEnv a] -> NameEnv a+plusNameEnvListWith :: (a->a->a) -> [NameEnv a] -> NameEnv a extendNameEnvList  :: NameEnv a -> [(Name,a)] -> NameEnv a+extendNameEnvListWith :: (a -> Name) -> NameEnv a -> [a] -> NameEnv a extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a delFromNameEnv     :: NameEnv a -> Name -> NameEnv a delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a@@ -133,16 +138,22 @@ unitNameEnv x y       = unitUFM x y extendNameEnv x y z   = addToUFM x y z extendNameEnvList x l = addListToUFM x l+extendNameEnvListWith f x l = addListToUFM x (map (\a -> (f a, a)) l) lookupNameEnv x y     = lookupUFM x y alterNameEnv          = alterUFM mkNameEnv     l       = listToUFM l mkNameEnvWith f       = mkNameEnv . map (\a -> (f a, a))+fromUniqMap           = mapUFM snd . getUniqMap elemNameEnv x y          = elemUFM x y plusNameEnv x y          = plusUFM x y plusNameEnv_C f x y      = plusUFM_C f x y {-# INLINE plusNameEnv_CD #-} plusNameEnv_CD f x d y b = plusUFM_CD f x d y b plusNameEnv_CD2 f x y    = plusUFM_CD2 f x y+{-# INLINE plusNameEnvList #-}+plusNameEnvList xs       = plusUFMList xs+{-# INLINE plusNameEnvListWith #-}+plusNameEnvListWith f xs = plusUFMListWith f xs extendNameEnv_C f x y z  = addToUFM_C f x y z mapNameEnv f x           = mapUFM f x extendNameEnv_Acc x y z a b  = addToUFM_Acc x y z a b@@ -151,11 +162,11 @@ delListFromNameEnv x y  = delListFromUFM x y filterNameEnv x y       = filterUFM x y mapMaybeNameEnv x y     = mapMaybeUFM x y-anyNameEnv f x          = foldUFM ((||) . f) False x+anyNameEnv f x          = nonDetFoldUFM ((||) . f) False x 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
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}  -- |@@ -29,7 +29,7 @@          -- ** Construction         -- $real_vs_source_data_constructors-        tcName, clsName, tcClsName, dataName, varName,+        tcName, clsName, tcClsName, dataName, varName, fieldName,         tvName, srcDataName,          -- ** Pretty Printing@@ -37,19 +37,22 @@          -- * The 'OccName' type         OccName,        -- Abstract, instance of Outputable-        pprOccName,+        pprOccName, occNameMangledFS,          -- ** Construction         mkOccName, mkOccNameFS,         mkVarOcc, mkVarOccFS,+        mkRecFieldOcc, mkRecFieldOccFS,         mkDataOcc, mkDataOccFS,         mkTyVarOcc, mkTyVarOccFS,         mkTcOcc, mkTcOccFS,         mkClsOcc, mkClsOccFS,         mkDFunOcc,         setOccNameSpace,-        demoteOccName,+        demoteOccName, demoteOccTcClsName, demoteOccTvName,         promoteOccName,+        varToRecFieldOcc,+        recFieldToVarOcc,         HasOccName(..),          -- ** Derived 'OccName's@@ -66,33 +69,44 @@         mkSuperDictSelOcc, mkSuperDictAuxOcc,         mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,         mkInstTyCoOcc, mkEqPredCoOcc,-        mkRecFldSelOcc,         mkTyConRepOcc,          -- ** Deconstruction         occNameFS, occNameString, occNameSpace,          isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,-        parenSymOcc, startsWithUnderscore,+        isFieldOcc, fieldOcc_maybe,+        parenSymOcc, startsWithUnderscore, isUnderscore,          isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,+        isFieldNameSpace, isTermVarOrFieldNameSpace,          -- * The 'OccEnv' type-        OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,-        lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,-        nonDetOccEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,+        OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv,+        mapOccEnv, strictMapOccEnv,+        mapMaybeOccEnv,+        lookupOccEnv, lookupOccEnv_AllNameSpaces,+        lookupOccEnv_WithFields, lookupFieldsOccEnv,+        mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,+        nonDetOccEnvElts, nonDetFoldOccEnv,+        plusOccEnv, plusOccEnv_C,         extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,-        alterOccEnv, minusOccEnv, minusOccEnv_C, pprOccEnv,+        alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns,+        sizeOccEnv,+        pprOccEnv, forceOccEnv,+        intersectOccEnv_C,          -- * The 'OccSet' type         OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,         extendOccSetList,-        unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,-        isEmptyOccSet, intersectOccSet,-        filterOccSet, occSetToEnv,+        unionOccSets, unionManyOccSets, elemOccSet,+        isEmptyOccSet, +        -- * Dealing with main+        mainOcc, ppMainFn,+         -- * Tidying up-        TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,+        TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, trimTidyOccEnv,         tidyOccName, avoidClashesOccEnv, delTidyOccEnvList,          -- FsEnv@@ -101,9 +115,9 @@  import GHC.Prelude +import GHC.Builtin.Uniques import GHC.Utils.Misc import GHC.Types.Unique-import GHC.Builtin.Uniques import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Data.FastString@@ -111,10 +125,13 @@ import GHC.Utils.Outputable import GHC.Utils.Lexeme import GHC.Utils.Binary+import GHC.Utils.Panic.Plain+ import Control.DeepSeq import Data.Char import Data.Data import qualified Data.Semigroup as S+import GHC.Exts( Int(I#), dataToTag# )  {- ************************************************************************@@ -124,33 +141,109 @@ ************************************************************************ -} -data NameSpace = VarName        -- Variables, including "real" data constructors-               | DataName       -- "Source" data constructors-               | TvName         -- Type variables-               | TcClsName      -- Type constructors and classes; Haskell has them-                                -- in the same name space for now.-               deriving( Eq, Ord )+data NameSpace+  -- | Variable name space (including "real" data constructors).+  = VarName+  -- | Record field namespace for the given record.+  | FldName+    { fldParent :: !FastString+      -- ^ The textual name of the parent of the field.+      --+      --   - For a field of a datatype, this is the name of the first constructor+      --     of the datatype (regardless of whether this constructor has this field).+      --   - For a field of a pattern synonym, this is the name of the pattern synonym.+    }+  -- | "Source" data constructor namespace.+  | DataName+  -- | Type variable namespace.+  | TvName+  -- | Type constructor and class namespace.+  | TcClsName+    -- Haskell has type constructors and classes in the same namespace, for now.+   deriving Eq --- Note [Data Constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~--- see also: Note [Data Constructor Naming] in GHC.Core.DataCon------ $real_vs_source_data_constructors--- There are two forms of data constructor:------      [Source data constructors] The data constructors mentioned in Haskell source code------      [Real data constructors] The data constructors of the representation type, which may not be the same as the source type------ For example:------ > data T = T !(Int, Int)------ The source datacon has type @(Int, Int) -> T@--- The real   datacon has type @Int -> Int -> T@------ GHC chooses a representation based on the strictness etc.+instance Ord NameSpace where+  compare ns1 ns2 =+    case compare (I# (dataToTag# ns1)) (I# (dataToTag# ns2)) of+      LT -> LT+      GT -> GT+      EQ+        | FldName { fldParent = p1 } <- ns1+        , FldName { fldParent = p2 } <- ns2+        -> lexicalCompareFS p1 p2+        | otherwise+        -> EQ +instance Uniquable NameSpace where+  getUnique (FldName fs) = mkFldNSUnique  fs+  getUnique VarName      = varNSUnique+  getUnique DataName     = dataNSUnique+  getUnique TvName       = tvNSUnique+  getUnique TcClsName    = tcNSUnique++instance NFData NameSpace where+  rnf VarName = ()+  rnf (FldName par) = rnf par+  rnf DataName = ()+  rnf TvName = ()+  rnf TcClsName = ()++{-+Note [Data Constructors]+~~~~~~~~~~~~~~~~~~~~~~~~+see also: Note [Data Constructor Naming] in GHC.Core.DataCon++$real_vs_source_data_constructors+There are two forms of data constructor:++     [Source data constructors] The data constructors mentioned in Haskell source code++     [Real data constructors] The data constructors of the representation type, which may not be the same as the source type++For example:++> data T = T !(Int, Int)++The source datacon has type @(Int, Int) -> T@+The real   datacon has type @Int -> Int -> T@++GHC chooses a representation based on the strictness etc.++Note [Record field namespacing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Record fields have a separate namespace from variables, to support+DuplicateRecordFields, e.g. in++  data X = MkX { fld :: Int }+  data Y = MkY { fld :: Bool }++  f x = x { fld = 3 }+  g y = y { fld = False }++we want the two occurrences of "fld" to refer to the field names associated with+the corresponding data type.++The namespace for a record field is as follows:++  - for a data type, it is the textual name of the first constructor of the+    datatype, whether this constructor has this field or not;+  - for a pattern synonym, it is the textual name of the pattern synonym itself.++Record fields are initially parsed as variables, but the renamer resolves their+namespace in GHC.Rename.Names.newRecordFieldLabel, which is called when renaming+record data declarations and record pattern synonym declarations.++To illustrate the namespacing, consider the record field "fld" in the following datatype++  data instance A Int Bool Char+    = MkA1 | MkA2 { fld :: Int } | MkA3 { bar :: Bool, fld :: Int }++Its namespace is `FldName "MkA1"`. This is a convention used throughout GHC+to circumvent the fact that we don't have a way to refer to the type constructor+"A Int Bool Char" in the renamer, as data family instances only get given+'Name's in the typechecker.+-}+ tcName, clsName, tcClsName :: NameSpace dataName, srcDataName      :: NameSpace tvName, varName            :: NameSpace@@ -168,6 +261,9 @@ tvName      = TvName varName     = VarName +fieldName :: FastString -> NameSpace+fieldName = FldName+ isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True isDataConNameSpace _        = False@@ -181,40 +277,71 @@ isTvNameSpace _      = False  isVarNameSpace :: NameSpace -> Bool     -- Variables or type variables, but not constructors-isVarNameSpace TvName  = True-isVarNameSpace VarName = True-isVarNameSpace _       = False+isVarNameSpace TvName       = True+isVarNameSpace VarName      = True+isVarNameSpace (FldName {}) = True+isVarNameSpace _            = False +-- | Is this a term variable or field name namespace?+isTermVarOrFieldNameSpace :: NameSpace -> Bool+isTermVarOrFieldNameSpace VarName      = True+isTermVarOrFieldNameSpace (FldName {}) = True+isTermVarOrFieldNameSpace _            = False+ isValNameSpace :: NameSpace -> Bool-isValNameSpace DataName = True-isValNameSpace VarName  = True-isValNameSpace _        = False+isValNameSpace DataName     = True+isValNameSpace VarName      = True+isValNameSpace (FldName {}) = True+isValNameSpace _            = False +isFieldNameSpace :: NameSpace -> Bool+isFieldNameSpace (FldName {}) = True+isFieldNameSpace _            = False+ pprNameSpace :: NameSpace -> SDoc-pprNameSpace DataName  = text "data constructor"-pprNameSpace VarName   = text "variable"-pprNameSpace TvName    = text "type variable"-pprNameSpace TcClsName = text "type constructor or class"+pprNameSpace DataName    = text "data constructor"+pprNameSpace VarName     = text "variable"+pprNameSpace TvName      = text "type variable"+pprNameSpace TcClsName   = text "type constructor or class"+pprNameSpace (FldName p) = text "record field of" <+> ftext p  pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns -pprNameSpaceBrief :: IsLine doc => NameSpace -> doc-pprNameSpaceBrief DataName  = char 'd'-pprNameSpaceBrief VarName   = char 'v'-pprNameSpaceBrief TvName    = text "tv"-pprNameSpaceBrief TcClsName = text "tc"+pprNameSpaceBrief :: NameSpace -> SDoc+pprNameSpaceBrief DataName     = char 'd'+pprNameSpaceBrief VarName      = char 'v'+pprNameSpaceBrief TvName       = text "tv"+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+demoteTvNameSpace TvName = Just VarName+demoteTvNameSpace VarName = Nothing+demoteTvNameSpace DataName = Nothing+demoteTvNameSpace TcClsName = Nothing+demoteTvNameSpace (FldName {}) = Nothing+ -- promoteNameSpace promotes the NameSpace as follows. -- See Note [Promotion] in GHC.Rename.Env. promoteNameSpace :: NameSpace -> Maybe NameSpace@@ -222,6 +349,7 @@ promoteNameSpace VarName = Just TvName promoteNameSpace TcClsName = Nothing promoteNameSpace TvName = Nothing+promoteNameSpace (FldName {}) = Nothing  {- ************************************************************************@@ -246,7 +374,8 @@  instance Ord OccName where         -- Compares lexicographically, *not* by Unique of the string-    compare (OccName sp1 s1) (OccName sp2 s2) = lexicalCompareFS s1 s2 S.<> compare sp1 sp2+    compare (OccName sp1 s1) (OccName sp2 s2) =+      lexicalCompareFS s1 s2 S.<> compare sp1 sp2  instance Data OccName where   -- don't traverse?@@ -278,11 +407,41 @@  pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ)-  = docWithContext $ \ sty ->-    if codeStyle (sdocStyle sty)-    then ztext (zEncodeFS occ)-    else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))+  = docWithStyle (ztext (zEncodeFS occ))+    (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)))+{-# SPECIALIZE pprOccName :: OccName -> SDoc #-}+{-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +-- | Mangle field names to avoid duplicate symbols.+--+-- See Note [Mangling OccNames].+occNameMangledFS :: OccName -> FastString+occNameMangledFS (OccName ns fs) =+  case ns of+    -- Fields need to include the constructor, to ensure that we don't define+    -- duplicate symbols when using DuplicateRecordFields.+    FldName con -> concatFS [fsLit "$fld:", con, ":", fs]+    -- Otherwise, we can ignore the namespace, as there is no risk of name+    -- clashes.+    _           -> fs++{- Note [Mangling OccNames]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating a symbol for a Name, we usually discard the NameSpace entirely+(see GHC.Types.Name.pprName). This is because clashes are usually not possible,+e.g. a variable and a data constructor can't clash because data constructors+start with a capital letter or a colon, while variables never do.++However, record field names, in the presence of DuplicateRecordFields, need this+disambiguation. So, for a record field like++  data A = MkA { foo :: Int }++we generate the symbol $fld:MkA:foo. We use the constructor 'MkA' to disambiguate,+and not the TyCon A as one might naively expect: this is explained in+Note [Record field namespacing].+-}+ {- ************************************************************************ *                                                                      *@@ -303,6 +462,27 @@ mkVarOccFS :: FastString -> OccName mkVarOccFS fs = mkOccNameFS varName fs +mkRecFieldOcc :: FastString -> String -> OccName+mkRecFieldOcc dc = mkOccName (fieldName dc)++mkRecFieldOccFS :: FastString -> FastString -> OccName+mkRecFieldOccFS dc = mkOccNameFS (fieldName dc)++varToRecFieldOcc :: HasDebugCallStack => FastString -> OccName -> OccName+varToRecFieldOcc dc (OccName ns s) =+  assert makes_sense $ mkRecFieldOccFS dc s+    where+      makes_sense = case ns of+        VarName    -> True+        FldName {} -> True+          -- NB: it's OK to change the parent data constructor,+          -- see e.g. test T23220 in which we construct with TH+          -- a datatype using the fields of a different datatype.+        _          -> False++recFieldToVarOcc :: HasDebugCallStack => OccName -> OccName+recFieldToVarOcc (OccName _ns s) = mkVarOccFS s+ mkDataOcc :: String -> OccName mkDataOcc = mkOccName dataName @@ -334,11 +514,23 @@   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+  return $ OccName space' name+ -- promoteOccName promotes the NameSpace of OccName. -- See Note [Promotion] in GHC.Rename.Env. promoteOccName :: OccName -> Maybe OccName promoteOccName (OccName space name) = do-  space' <- promoteNameSpace space+  promoted_space <- promoteNameSpace space+  let tyop   = isTvNameSpace promoted_space && isLexVarSym name+      space' = if tyop then tcClsName else promoted_space   -- special case for type operators (#24570)   return $ OccName space' name  {- | Other names in the compiler add additional information to an OccName.@@ -353,91 +545,295 @@ *                                                                      * ************************************************************************ -OccEnvs are used mainly for the envts in ModIfaces.+OccEnvs are used for the GlobalRdrEnv and for the envts in ModIface. -Note [The Unique of an OccName]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-They are efficient, because FastStrings have unique Int# keys.  We assume-this key is less than 2^24, and indeed FastStrings are allocated keys-sequentially starting at 0.+Note [OccEnv]+~~~~~~~~~~~~~+An OccEnv is a map keyed on OccName. Recall that an OccEnv consists of two+components: -So we can make a Unique using-        mkUnique ns key  :: Unique-where 'ns' is a Char representing the name space.  This in turn makes it-easy to build an OccEnv.--}+  - a namespace,+  - a textual name (in the form of a FastString). -instance Uniquable OccName where-      -- See Note [The Unique of an OccName]-  getUnique (OccName VarName   fs) = mkVarOccUnique  fs-  getUnique (OccName DataName  fs) = mkDataOccUnique fs-  getUnique (OccName TvName    fs) = mkTvOccUnique   fs-  getUnique (OccName TcClsName fs) = mkTcOccUnique   fs+In general, for a given textual name, there is only one appropriate namespace.+However, sometimes we do get an occurrence that belongs to several namespaces: -newtype OccEnv a = A (UniqFM OccName a)-  deriving Data+  - Symbolic identifiers such as (:+) can belong to both the data constructor and+    type constructor/class namespaces.+  - With duplicate record fields, a field name can belong to several different+    namespaces, one for each parent datatype (or pattern synonym). +So we represent an OccEnv as a nested data structure++  FastStringEnv (UniqFM NameSpace a)++in which we can first look up the textual name, and then choose which of the+namespaces are relevant. This supports the two main uses of OccEnvs:++  1. One wants to look up a specific OccName in the environment, at a specific+     namespace. One looks up the textual name, and then the namespace.+  2. One wants to look up something, but isn't sure in advance of the namespace.+     So one looks up the textual name, and then can decide what to do based on+     the returned map of namespaces.++This data structure isn't performance critical in most situations, but some+improvements to its performance that might be worth it are as follows:++  A. Use a tailor-made data structure for a map keyed on NameSpaces.++     Recall that we have:++        data IntMap a = Bin !Int !Int !(IntMap a) !(IntMap a)+                      | Tip !Key a+                      | Nil++     This is already pretty efficient for singletons, but we don't need the+     empty case (as we would simply omit the parent key in the OccEnv instead+     of storing an empty inner map).++  B. Always ensure the inner map (keyed on namespaces) is evaluated, i.e.+     is never a thunk. For this, we would need to use strict operations on+     the outer FastStringEnv (but we'd keep using lazy operations on the inner+     UniqFM).+-}++-- | A map keyed on 'OccName'. See Note [OccEnv].+newtype OccEnv a = MkOccEnv (FastStringEnv (UniqFM NameSpace a))+  deriving Functor++-- | The empty 'OccEnv'. emptyOccEnv :: OccEnv a-unitOccEnv  :: OccName -> a -> OccEnv a+emptyOccEnv = MkOccEnv emptyFsEnv++-- | A singleton 'OccEnv'.+unitOccEnv :: OccName -> a -> OccEnv a+unitOccEnv (OccName ns s) a = MkOccEnv $ unitFsEnv s (unitUFM ns a)++-- | Add a single element to an 'OccEnv'. extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a+extendOccEnv (MkOccEnv as) (OccName ns s) a =+  MkOccEnv $ extendFsEnv_C plusUFM as s (unitUFM ns a)++-- | Extend an 'OccEnv' by a list.+--+-- 'OccName's later on in the list override earlier 'OccName's. extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a+extendOccEnvList = foldl' $ \ env (occ, a) -> extendOccEnv env occ a++-- | Look an element up in an 'OccEnv'. lookupOccEnv :: OccEnv a -> OccName -> Maybe a-mkOccEnv     :: [(OccName,a)] -> OccEnv a-mkOccEnv_C   :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a-elemOccEnv   :: OccName -> OccEnv a -> Bool-foldOccEnv   :: (a -> b -> b) -> b -> OccEnv a -> b-nonDetOccEnvElts   :: OccEnv a -> [a]-extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a-extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b-plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a-plusOccEnv_C   :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a-mapOccEnv      :: (a->b) -> OccEnv a -> OccEnv b-delFromOccEnv      :: OccEnv a -> OccName -> OccEnv a+lookupOccEnv (MkOccEnv as) (OccName ns s)+  = do { m <- lookupFsEnv as s+       ; lookupUFM m ns }++-- | Lookup an element in an 'OccEnv', ignoring 'NameSpace's entirely.+lookupOccEnv_AllNameSpaces :: OccEnv a -> OccName -> [a]+lookupOccEnv_AllNameSpaces (MkOccEnv as) (OccName _ s)+  = case lookupFsEnv as s of+      Nothing -> []+      Just r  -> nonDetEltsUFM r++-- | Lookup an element in an 'OccEnv', looking in the record field+-- namespace for a variable.+lookupOccEnv_WithFields :: OccEnv a -> OccName -> [a]+lookupOccEnv_WithFields env occ =+  case lookupOccEnv env occ of+      Nothing  -> fieldGREs+      Just gre -> gre : fieldGREs+  where+    fieldGREs+      -- If the 'OccName' is a variable, also look up+      -- in the record field namespaces.+      | isVarOcc occ+      = lookupFieldsOccEnv env (occNameFS occ)+      | otherwise+      = []++-- | Look up all the record fields that match with the given 'FastString'+-- in an 'OccEnv'.+lookupFieldsOccEnv :: OccEnv a -> FastString -> [a]+lookupFieldsOccEnv (MkOccEnv as) fld =+  case lookupFsEnv as fld of+    Nothing   -> []+    Just flds -> nonDetEltsUFM $ filter_flds flds+  -- NB: non-determinism is OK: in practice we will either end up resolving+  -- to a single field or throwing an error.+  where+    filter_flds = filterUFM_Directly (\ uniq _ -> isFldNSUnique uniq)++-- | Create an 'OccEnv' from a list.+--+-- 'OccName's later on in the list override earlier 'OccName's.+mkOccEnv :: [(OccName,a)] -> OccEnv a+mkOccEnv = extendOccEnvList emptyOccEnv++-- | Create an 'OccEnv' from a list, combining different values+-- with the same 'OccName' using the combining function.+mkOccEnv_C :: (a -> a -> a) -- ^ old -> new -> result+           -> [(OccName,a)]+           -> OccEnv a+mkOccEnv_C f elts+  = MkOccEnv $ foldl' g emptyFsEnv elts+    where+      g env (OccName ns s, a) =+        extendFsEnv_C (plusUFM_C $ flip f) env s (unitUFM ns a)++-- | Compute whether there is a value keyed by the given 'OccName'.+elemOccEnv :: OccName -> OccEnv a -> Bool+elemOccEnv (OccName ns s) (MkOccEnv as)+  = case lookupFsEnv as s of+      Nothing -> False+      Just m  -> ns `elemUFM` m++-- | Fold over an 'OccEnv'. Non-deterministic, unless the folding function+-- is commutative (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@).+nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b+nonDetFoldOccEnv f b0 (MkOccEnv as) =+  nonDetFoldFsEnv (flip $ nonDetFoldUFM f) b0 as++-- | Obtain the elements of an 'OccEnv'.+--+-- The resulting order is non-deterministic.+nonDetOccEnvElts :: OccEnv a -> [a]+nonDetOccEnvElts = nonDetFoldOccEnv (:) []++-- | Union of two 'OccEnv's, right-biased.+plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a+plusOccEnv (MkOccEnv env1) (MkOccEnv env2)+  = MkOccEnv $ plusFsEnv_C plusUFM env1 env2++-- | Union of two 'OccEnv's with a combining function.+plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a+plusOccEnv_C f (MkOccEnv env1) (MkOccEnv env2)+  = MkOccEnv $ plusFsEnv_C (plusUFM_C f) env1 env2++-- | Map over an 'OccEnv' ('Functor' instance).+mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b+mapOccEnv = fmap++-- | 'mapMaybe' for b 'OccEnv'.+mapMaybeOccEnv :: (a -> Maybe b) -> OccEnv a -> OccEnv b+mapMaybeOccEnv f (MkOccEnv env)+  = MkOccEnv $ mapMaybeUFM g env+    where+      g as =+        case mapMaybeUFM f as of+          m' | isNullUFM m' -> Nothing+             | otherwise    -> Just m'++-- | Add a single element to an 'OccEnv', using a different function whether+-- the 'OccName' already exists or not.+extendOccEnv_Acc :: forall a b+                 .  (a->b->b)    -- ^ add to existing+                 -> (a->b)       -- ^ new element+                 -> OccEnv b     -- ^ old+                 -> OccName -> a -- ^ new+                 -> OccEnv b+extendOccEnv_Acc f g (MkOccEnv env) (OccName ns s) =+  MkOccEnv . extendFsEnv_Acc f' g' env s+    where+     f' :: a -> UniqFM NameSpace b -> UniqFM NameSpace b+     f' a bs = alterUFM (Just . \ case { Nothing -> g a ; Just b -> f a b }) bs ns+     g' a = unitUFM ns (g a)++-- | Delete one element from an 'OccEnv'.+delFromOccEnv :: forall a. OccEnv a -> OccName -> OccEnv a+delFromOccEnv (MkOccEnv env1) (OccName ns s) =+  MkOccEnv $ alterFsEnv f env1 s+    where+      f :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a)+      f Nothing = Nothing+      f (Just m) =+        case delFromUFM m ns of+          m' | isNullUFM m' -> Nothing+             | otherwise    -> Just m'++-- | Delete multiple elements from an 'OccEnv'. delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a-filterOccEnv       :: (elt -> Bool) -> OccEnv elt -> OccEnv elt-alterOccEnv        :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt+delListFromOccEnv = foldl' delFromOccEnv++-- | Filter out all elements in an 'OccEnv' using a predicate.+filterOccEnv :: forall a. (a -> Bool) -> OccEnv a -> OccEnv a+filterOccEnv f (MkOccEnv env) =+  MkOccEnv $ mapMaybeFsEnv g env+    where+      g :: UniqFM NameSpace a -> Maybe (UniqFM NameSpace a)+      g ms =+        case filterUFM f ms of+          m' | isNullUFM m' -> Nothing+             | otherwise    -> Just m'++-- | Alter an 'OccEnv', adding or removing an element at the given key.+alterOccEnv :: forall a. (Maybe a -> Maybe a) -> OccEnv a -> OccName -> OccEnv a+alterOccEnv f (MkOccEnv env) (OccName ns s) =+  MkOccEnv $ alterFsEnv g env s+    where+      g :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a)+      g Nothing  = fmap (unitUFM ns) (f Nothing)+      g (Just m) =+        case alterUFM f m ns of+          m' | isNullUFM m' -> Nothing+             | otherwise    -> Just m'++intersectOccEnv_C :: (a -> b -> c) -> OccEnv a -> OccEnv b -> OccEnv c+intersectOccEnv_C f (MkOccEnv as) (MkOccEnv bs)+  = MkOccEnv $ intersectUFM_C (intersectUFM_C f) as bs++-- | Remove elements of the first 'OccEnv' that appear in the second 'OccEnv'. minusOccEnv :: OccEnv a -> OccEnv b -> OccEnv a+minusOccEnv = minusOccEnv_C_Ns minusUFM --- | Alters (replaces or removes) those elements of the map that are mentioned in the second map-minusOccEnv_C :: (a -> b -> Maybe a) -> OccEnv a -> OccEnv b -> OccEnv a+-- | Alters (replaces or removes) those elements of the first 'OccEnv' that are+-- mentioned in the second 'OccEnv'.+--+-- Same idea as 'Data.Map.differenceWith'.+minusOccEnv_C :: (a -> b -> Maybe a)+              -> OccEnv a -> OccEnv b -> OccEnv a+minusOccEnv_C f = minusOccEnv_C_Ns (minusUFM_C f) -emptyOccEnv      = A emptyUFM-unitOccEnv x y = A $ unitUFM x y-extendOccEnv (A x) y z = A $ addToUFM x y z-extendOccEnvList (A x) l = A $ addListToUFM x l-lookupOccEnv (A x) y = lookupUFM x y-mkOccEnv     l    = A $ listToUFM l-elemOccEnv x (A y)       = elemUFM x y-foldOccEnv a b (A c)     = foldUFM a b c-nonDetOccEnvElts (A x)         = nonDetEltsUFM x-plusOccEnv (A x) (A y)   = A $ plusUFM x y-plusOccEnv_C f (A x) (A y)       = A $ plusUFM_C f x y-extendOccEnv_C f (A x) y z   = A $ addToUFM_C f x y z-extendOccEnv_Acc f g (A x) y z   = A $ addToUFM_Acc f g x y z-mapOccEnv f (A x)        = A $ mapUFM f x-mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l-delFromOccEnv (A x) y    = A $ delFromUFM x y-delListFromOccEnv (A x) y  = A $ delListFromUFM x y-filterOccEnv x (A y)       = A $ filterUFM x y-alterOccEnv fn (A y) k     = A $ alterUFM fn y k-minusOccEnv (A x) (A y) = A $ minusUFM x y-minusOccEnv_C fn (A x) (A y) = A $ minusUFM_C fn x y+minusOccEnv_C_Ns :: forall a b+                 .  (UniqFM NameSpace a -> UniqFM NameSpace b -> UniqFM NameSpace a)+                 -> OccEnv a -> OccEnv b -> OccEnv a+minusOccEnv_C_Ns f (MkOccEnv as) (MkOccEnv bs) =+  MkOccEnv $ minusUFM_C g as bs+    where+      g :: UniqFM NameSpace a -> UniqFM NameSpace b -> Maybe (UniqFM NameSpace a)+      g as bs =+        let m = f as bs+        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  pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc-pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env+pprOccEnv ppr_elt (MkOccEnv env)+    = brackets $ fsep $ punctuate comma $+    [ ppr uq <+> text ":->" <+> ppr_elt elt+    | (uq, elts) <- nonDetUFMToList env+    , elt <- nonDetEltsUFM elts ]  instance NFData a => NFData (OccEnv a) where   rnf = forceOccEnv rnf +-- | Map over an 'OccEnv' strictly.+strictMapOccEnv :: (a -> b) -> OccEnv a -> OccEnv b+strictMapOccEnv f (MkOccEnv as) =+  MkOccEnv $ strictMapFsEnv (strictMapUFM f) as+ -- | Force an 'OccEnv' with the provided function. forceOccEnv :: (a -> ()) -> OccEnv a -> ()-forceOccEnv nf (A fs) = seqEltsUFM nf fs+forceOccEnv nf (MkOccEnv fs) = seqEltsUFM (seqEltsUFM nf) fs -type OccSet = UniqSet OccName+-------------------------------------------------------------------------------- +newtype OccSet = OccSet (FastStringEnv (UniqSet NameSpace))+ emptyOccSet       :: OccSet unitOccSet        :: OccName -> OccSet mkOccSet          :: [OccName] -> OccSet@@ -445,27 +841,18 @@ extendOccSetList  :: OccSet -> [OccName] -> OccSet unionOccSets      :: OccSet -> OccSet -> OccSet unionManyOccSets  :: [OccSet] -> OccSet-minusOccSet       :: OccSet -> OccSet -> OccSet elemOccSet        :: OccName -> OccSet -> Bool isEmptyOccSet     :: OccSet -> Bool-intersectOccSet   :: OccSet -> OccSet -> OccSet-filterOccSet      :: (OccName -> Bool) -> OccSet -> OccSet--- | Converts an OccSet to an OccEnv (operationally the identity)-occSetToEnv       :: OccSet -> OccEnv OccName -emptyOccSet       = emptyUniqSet-unitOccSet        = unitUniqSet-mkOccSet          = mkUniqSet-extendOccSet      = addOneToUniqSet-extendOccSetList  = addListToUniqSet-unionOccSets      = unionUniqSets-unionManyOccSets  = unionManyUniqSets-minusOccSet       = minusUniqSet-elemOccSet        = elementOfUniqSet-isEmptyOccSet     = isEmptyUniqSet-intersectOccSet   = intersectUniqSets-filterOccSet      = filterUniqSet-occSetToEnv       = A . getUniqSet+emptyOccSet       = OccSet emptyFsEnv+unitOccSet (OccName ns s) = OccSet $ unitFsEnv s (unitUniqSet ns)+mkOccSet          = extendOccSetList emptyOccSet+extendOccSet      (OccSet occs) (OccName ns s) = OccSet $ extendFsEnv occs s (unitUniqSet ns)+extendOccSetList  = foldl' extendOccSet+unionOccSets      (OccSet xs) (OccSet ys) = OccSet $ plusFsEnv_C unionUniqSets xs ys+unionManyOccSets  = foldl' unionOccSets emptyOccSet+elemOccSet (OccName ns s) (OccSet occs) = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s+isEmptyOccSet     (OccSet occs) = isNullUFM occs  {- ************************************************************************@@ -481,7 +868,7 @@ setOccNameSpace :: NameSpace -> OccName -> OccName setOccNameSpace sp (OccName _ occ) = OccName sp occ -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool+isVarOcc, isTvOcc, isTcOcc, isDataOcc, isFieldOcc :: OccName -> Bool  isVarOcc (OccName VarName _) = True isVarOcc _                   = False@@ -492,12 +879,20 @@ isTcOcc (OccName TcClsName _) = True isTcOcc _                     = False +isFieldOcc (OccName (FldName {}) _) = True+isFieldOcc _                        = False++fieldOcc_maybe :: OccName -> Maybe FastString+fieldOcc_maybe (OccName (FldName con) _) = Just con+fieldOcc_maybe _                         = Nothing+ -- | /Value/ 'OccNames's are those that are either in--- the variable or data constructor namespaces+-- the variable, field name or data constructor namespaces isValOcc :: OccName -> Bool-isValOcc (OccName VarName  _) = True-isValOcc (OccName DataName _) = True-isValOcc _                    = False+isValOcc (OccName VarName      _) = True+isValOcc (OccName DataName     _) = True+isValOcc (OccName (FldName {}) _) = True+isValOcc _                        = False  isDataOcc (OccName DataName _) = True isDataOcc _                    = False@@ -512,10 +907,12 @@ -- | Test if the 'OccName' is that for any operator (whether -- it is a data constructor or variable or whatever) isSymOcc :: OccName -> Bool-isSymOcc (OccName DataName s)  = isLexConSym s-isSymOcc (OccName TcClsName s) = isLexSym s-isSymOcc (OccName VarName s)   = isLexSym s-isSymOcc (OccName TvName s)    = isLexSym s+isSymOcc (OccName ns s) = case ns of+  DataName   -> isLexConSym s+  TcClsName  -> isLexSym s+  VarName    -> isLexSym s+  TvName     -> isLexSym s+  FldName {} -> isLexSym s -- Pretty inefficient!  parenSymOcc :: OccName -> SDoc -> SDoc@@ -530,6 +927,9 @@   '_':_ -> True   _     -> False +isUnderscore :: OccName -> Bool+isUnderscore occ = occNameFS occ == fsLit "_"+ {- ************************************************************************ *                                                                      *@@ -652,10 +1052,6 @@ mkGenR   = mk_simple_deriv tcName "Rep_" mkGen1R  = mk_simple_deriv tcName "Rep1_" --- Overloaded record field selectors-mkRecFldSelOcc :: FastString -> OccName-mkRecFldSelOcc s = mk_deriv varName "$sel" [s]- mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] @@ -762,7 +1158,7 @@  Note [TidyOccEnv] ~~~~~~~~~~~~~~~~~-type TidyOccEnv = UniqFM Int+type TidyOccEnv = UniqFM FastString Int  * Domain = The OccName's FastString. These FastStrings are "taken";            make sure that we don't re-use@@ -817,8 +1213,16 @@ To achieve this, the function avoidClashesOccEnv can be used to prepare the TidyEnv, by “blocking” every name that occurs twice in the map. This way, none of the "a"s will get the privilege of keeping this name, and all of them will-get a suitable number by tidyOccName.+get a suitable number by tidyOccName.  Thus +   avoidNameClashesOccEnv ["a" :-> 7] ["b", "a", "c", "b", "a"]+     = ["a" :-> 7, "b" :-> 1]++Here+* "a" is already the TidyOccEnv, and so is unaffected+* "b" occurs twice, so is blocked by adding "b" :-> 1+* "c" occurs only once, and so is not affected.+ This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs for an example where this is used. @@ -837,8 +1241,8 @@   where     add env (OccName _ fs) = addToUFM env fs 1 -delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv-delTidyOccEnvList = delListFromUFM+delTidyOccEnvList :: TidyOccEnv -> [OccName] -> TidyOccEnv+delTidyOccEnvList env occs = env `delListFromUFM` map occNameFS occs  -- see Note [Tidying multiple names at once] avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv@@ -882,10 +1286,38 @@                      -- If they are the same (n==1), the former wins                      -- See Note [TidyOccEnv] +trimTidyOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv+-- Restrict the env to just the [OccName]+trimTidyOccEnv env vs+  = foldl' add emptyUFM vs+  where+    add :: TidyOccEnv -> OccName -> TidyOccEnv+    add so_far (OccName _ fs)+      = case lookupUFM env fs of+          Just n  -> addToUFM so_far fs n+          Nothing -> so_far  {- ************************************************************************ *                                                                      *+                            Utilies for "main"+*                                                                      *+************************************************************************+-}++mainOcc :: OccName+mainOcc = mkVarOccFS (fsLit "main")++ppMainFn :: OccName -> SDoc+ppMainFn main_occ+  | main_occ == mainOcc+  = text "IO action" <+> quotes (ppr main_occ)+  | otherwise+  = text "main IO action" <+> quotes (ppr main_occ)++{-+************************************************************************+*                                                                      *                 Binary instance     Here rather than in GHC.Iface.Binary because OccName is abstract *                                                                      *@@ -901,13 +1333,19 @@             putByte bh 2     put_ bh TcClsName =             putByte bh 3+    put_ bh (FldName parent) = do+            putByte bh 4+            put_ bh parent     get bh = do             h <- getByte bh             case h of               0 -> return VarName               1 -> return DataName               2 -> return TvName-              _ -> return TcClsName+              3 -> return TcClsName+              _ -> do+                parent <- get bh+                return $ FldName { fldParent = parent }  instance Binary OccName where     put_ bh (OccName aa ab) = do
compiler/GHC/Types/Name/Occurrence.hs-boot view
@@ -8,5 +8,4 @@   occName :: name -> OccName  occNameFS :: OccName -> FastString-mkRecFldSelOcc :: FastString -> OccName mkVarOccFS :: FastString -> OccName
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@@ -23,6 +24,7 @@ import GHC.Utils.Misc import GHC.Builtin.Types.Prim ( fUNTyConName ) import GHC.Builtin.Types+import Data.Maybe (isJust)   {-@@ -67,71 +69,83 @@  -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics.-mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx 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 :: GlobalRdrEnv -> QueryQualifyName+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_RdrName (mkRdrQual (moduleName mod) occ) env)-          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-            , manyDataConName ]+    | 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_RdrName (mkRdrUnqual occ) env-        qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)+      -- 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). -mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick+mkPromTick :: PromotionTickContext -> GlobalRdrEnvX info -> QueryPromotionTick mkPromTick ptc env   | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick   | otherwise                      = print_prom_tick@@ -147,7 +161,7 @@       = ptcListTuplePuns ptc        | Just occ' <- promoteOccName occ-      , [] <- lookupGRE_RdrName (mkRdrUnqual occ') env+      , [] <- lookupGRE env (LookupRdrName (mkRdrUnqual occ') SameNameSpace)       = -- Could not find a corresponding type name in the environment,         -- so the data name is unambiguous. Promotion tick not needed.         False@@ -201,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,1386 +5,2227 @@  {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}---- |--- #name_types#--- GHC uses several kinds of name internally:------ * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types"------ * 'GHC.Types.Name.Reader.RdrName' is the type of names that come directly from the parser. They---   have not yet had their scoping and binding resolved by the renamer and can be---   thought of to a first approximation as an 'GHC.Types.Name.Occurrence.OccName' with an optional module---   qualifier------ * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types"------ * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types"------ * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types"--module GHC.Types.Name.Reader (-        -- * The main type-        RdrName(..),    -- Constructors exported only to GHC.Iface.Binary--        -- ** Construction-        mkRdrUnqual, mkRdrQual,-        mkUnqual, mkVarUnqual, mkQual, mkOrig,-        nameRdrName, getRdrName,--        -- ** Destruction-        rdrNameOcc, rdrNameSpace, demoteRdrName, promoteRdrName,-        isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,-        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,--        -- * Local mapping of 'RdrName' to 'Name.Name'-        LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,-        lookupLocalRdrEnv, lookupLocalRdrOcc,-        elemLocalRdrEnv, inLocalRdrEnvScope,-        localRdrEnvElts, minusLocalRdrEnv,--        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's-        GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,-        lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,-        pprGlobalRdrEnv, globalRdrEnvElts,-        lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name,-        lookupGRE_GreName, lookupGRE_FieldLabel,-        lookupGRE_Name_OccName,-        getGRE_NameQualifier_maybes,-        transformGREs, pickGREs, pickGREsModExp,--        -- * GlobalRdrElts-        gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,-        greRdrNames, greSrcSpan, greQualModName,-        gresToAvailInfo,-        greDefinitionModule, greDefinitionSrcSpan,-        greMangledName, grePrintableName,-        greFieldLabel,--        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'-        GlobalRdrElt(..), isLocalGRE, isRecFldGRE,-        isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE,-        unQualOK, qualSpecOK, unQualSpecOK,-        pprNameProvenance,-        GreName(..), greNameSrcSpan,-        Parent(..), greParent_maybe,-        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),-        importSpecLoc, importSpecModule, isExplicitItem, bestImport,--        -- * Utils-        opIsAt-  ) where--import GHC.Prelude--import GHC.Unit.Module-import GHC.Types.Name-import GHC.Types.Avail-import GHC.Types.Name.Set-import GHC.Data.Maybe-import GHC.Types.SrcLoc as SrcLoc-import GHC.Data.FastString-import GHC.Types.FieldLabel-import GHC.Utils.Outputable-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Utils.Misc as Utils-import GHC.Utils.Panic-import GHC.Types.Name.Env--import Language.Haskell.Syntax.Basic (FieldLabelString(..))--import Data.Data-import Data.List( sortBy )-import qualified Data.Semigroup as S-import Control.DeepSeq-import GHC.Data.Bag--{--************************************************************************-*                                                                      *-\subsection{The main data type}-*                                                                      *-************************************************************************--}---- | Reader Name------ Do not use the data constructors of RdrName directly: prefer the family--- of functions that creates them, such as 'mkRdrUnqual'------ - Note: A Located RdrName will only have API Annotations if it is a---         compound one,---   e.g.------ > `bar`--- > ( ~ )------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',---           'GHC.Parser.Annotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,---           'GHC.Parser.Annotation.AnnClose' @')'@ or @']'@ or @':]'@,,---           'GHC.Parser.Annotation.AnnBackquote' @'`'@,---           'GHC.Parser.Annotation.AnnVal'---           'GHC.Parser.Annotation.AnnTilde',---- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation"-data RdrName-  = Unqual OccName-        -- ^ Unqualified  name-        ---        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.-        -- Create such a 'RdrName' with 'mkRdrUnqual'--  | Qual ModuleName OccName-        -- ^ Qualified name-        ---        -- A qualified name written by the user in-        -- /source/ code.  The module isn't necessarily-        -- the module where the thing is defined;-        -- just the one from which it is imported.-        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.-        -- Create such a 'RdrName' with 'mkRdrQual'--  | Orig Module OccName-        -- ^ Original name-        ---        -- An original name; the module is the /defining/ module.-        -- This is used when GHC generates code that will be fed-        -- into the renamer (e.g. from deriving clauses), but where-        -- we want to say \"Use Prelude.map dammit\". One of these-        -- can be created with 'mkOrig'--  | Exact Name-        -- ^ Exact name-        ---        -- We know exactly the 'Name'. This is used:-        ---        --  (1) When the parser parses built-in syntax like @[]@-        --      and @(,)@, but wants a 'RdrName' from it-        ---        --  (2) By Template Haskell, when TH has generated a unique name-        ---        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'-  deriving Data--{--************************************************************************-*                                                                      *-\subsection{Simple functions}-*                                                                      *-************************************************************************--}--instance HasOccName RdrName where-  occName = rdrNameOcc--rdrNameOcc :: RdrName -> OccName-rdrNameOcc (Qual _ occ) = occ-rdrNameOcc (Unqual occ) = occ-rdrNameOcc (Orig _ occ) = occ-rdrNameOcc (Exact name) = nameOccName name--rdrNameSpace :: RdrName -> NameSpace-rdrNameSpace = occNameSpace . rdrNameOcc---- demoteRdrName lowers the NameSpace of RdrName.--- See Note [Demotion] in GHC.Rename.Env-demoteRdrName :: RdrName -> Maybe RdrName-demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)-demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)-demoteRdrName (Orig _ _) = Nothing-demoteRdrName (Exact _) = Nothing---- promoteRdrName promotes the NameSpace of RdrName.--- See Note [Promotion] in GHC.Rename.Env.-promoteRdrName :: RdrName -> Maybe RdrName-promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ)-promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ)-promoteRdrName (Orig _ _) = Nothing-promoteRdrName (Exact _)  = Nothing--        -- These two are the basic constructors-mkRdrUnqual :: OccName -> RdrName-mkRdrUnqual occ = Unqual occ--mkRdrQual :: ModuleName -> OccName -> RdrName-mkRdrQual mod occ = Qual mod occ--mkOrig :: Module -> OccName -> RdrName-mkOrig mod occ = Orig mod occ------------------        -- These two are used when parsing source files-        -- They do encode the module and occurrence names-mkUnqual :: NameSpace -> FastString -> RdrName-mkUnqual sp n = Unqual (mkOccNameFS sp n)--mkVarUnqual :: FastString -> RdrName-mkVarUnqual n = Unqual (mkVarOccFS n)---- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and--- the 'OccName' are taken from the first and second elements of the tuple respectively-mkQual :: NameSpace -> (FastString, FastString) -> RdrName-mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)--getRdrName :: NamedThing thing => thing -> RdrName-getRdrName name = nameRdrName (getName name)--nameRdrName :: Name -> RdrName-nameRdrName name = Exact name--- Keep the Name even for Internal names, so that the--- unique is still there for debug printing, particularly--- of Types (which are converted to IfaceTypes before printing)--nukeExact :: Name -> RdrName-nukeExact n-  | isExternalName n = Orig (nameModule n) (nameOccName n)-  | otherwise        = Unqual (nameOccName n)--isRdrDataCon :: RdrName -> Bool-isRdrTyVar   :: RdrName -> Bool-isRdrTc      :: RdrName -> Bool--isRdrDataCon rn = isDataOcc (rdrNameOcc rn)-isRdrTyVar   rn = isTvOcc   (rdrNameOcc rn)-isRdrTc      rn = isTcOcc   (rdrNameOcc rn)--isSrcRdrName :: RdrName -> Bool-isSrcRdrName (Unqual _) = True-isSrcRdrName (Qual _ _) = True-isSrcRdrName _          = False--isUnqual :: RdrName -> Bool-isUnqual (Unqual _) = True-isUnqual _          = False--isQual :: RdrName -> Bool-isQual (Qual _ _) = True-isQual _          = False--isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)-isQual_maybe (Qual m n) = Just (m,n)-isQual_maybe _          = Nothing--isOrig :: RdrName -> Bool-isOrig (Orig _ _) = True-isOrig _          = False--isOrig_maybe :: RdrName -> Maybe (Module, OccName)-isOrig_maybe (Orig m n) = Just (m,n)-isOrig_maybe _          = Nothing--isExact :: RdrName -> Bool-isExact (Exact _) = True-isExact _         = False--isExact_maybe :: RdrName -> Maybe Name-isExact_maybe (Exact n) = Just n-isExact_maybe _         = Nothing--{--************************************************************************-*                                                                      *-\subsection{Instances}-*                                                                      *-************************************************************************--}--instance Outputable RdrName where-    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)--instance OutputableBndr RdrName where-    pprBndr _ n-        | isTvOcc (rdrNameOcc n) = char '@' <> ppr n-        | otherwise              = ppr n--    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)-    pprPrefixOcc rdr-      | Just name <- isExact_maybe rdr = pprPrefixName name-             -- pprPrefixName has some special cases, so-             -- we delegate to them rather than reproduce them-      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)--instance Eq RdrName where-    (Exact n1)    == (Exact n2)    = n1==n2-        -- Convert exact to orig-    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2-    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2--    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2-    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2-    (Unqual o1)   == (Unqual o2)   = o1==o2-    _             == _             = False--instance Ord RdrName where-    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }-    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }-    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }-    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }--        -- Exact < Unqual < Qual < Orig-        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig-        --      before comparing so that Prelude.map == the exact Prelude.map, but-        --      that meant that we reported duplicates when renaming bindings-        --      generated by Template Haskell; e.g-        --      do { n1 <- newName "foo"; n2 <- newName "foo";-        --           <decl involving n1,n2> }-        --      I think we can do without this conversion-    compare (Exact n1) (Exact n2) = n1 `compare` n2-    compare (Exact _)  _          = LT--    compare (Unqual _)   (Exact _)    = GT-    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2-    compare (Unqual _)   _            = LT--    compare (Qual _ _)   (Exact _)    = GT-    compare (Qual _ _)   (Unqual _)   = GT-    compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2-    compare (Qual _ _)   (Orig _ _)   = LT--    compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2-    compare (Orig _ _)   _            = GT--{--************************************************************************-*                                                                      *-                        LocalRdrEnv-*                                                                      *-************************************************************************--}--{- Note [LocalRdrEnv]-~~~~~~~~~~~~~~~~~~~~~-The LocalRdrEnv is used to store local bindings (let, where, lambda, case).--* It is keyed by OccName, because we never use it for qualified names.--* It maps the OccName to a Name.  That Name is almost always an-  Internal Name, but (hackily) it can be External too for top-level-  pattern bindings.  See Note [bindLocalNames for an External name]-  in GHC.Rename.Pat--* We keep the current mapping (lre_env), *and* the set of all Names in-  scope (lre_in_scope).  Reason: see Note [Splicing Exact names] in-  GHC.Rename.Env.--}---- | Local Reader Environment--- See Note [LocalRdrEnv]-data LocalRdrEnv = LRE { lre_env      :: OccEnv Name-                       , lre_in_scope :: NameSet }--instance Outputable LocalRdrEnv where-  ppr (LRE {lre_env = env, lre_in_scope = ns})-    = hang (text "LocalRdrEnv {")-         2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env-                 , text "in_scope ="-                    <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)-                 ] <+> char '}')-    where-      ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name-                     -- So we can see if the keys line up correctly--emptyLocalRdrEnv :: LocalRdrEnv-emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv-                       , lre_in_scope = emptyNameSet }--extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv--- See Note [LocalRdrEnv]-extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name-  = lre { lre_env      = extendOccEnv env (nameOccName name) name-        , lre_in_scope = extendNameSet ns name }--extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv--- See Note [LocalRdrEnv]-extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names-  = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]-        , lre_in_scope = extendNameSetList ns names }--lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name-lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr-  | Unqual occ <- rdr-  = lookupOccEnv env occ--  -- See Note [Local bindings with Exact Names]-  | Exact name <- rdr-  , name `elemNameSet` ns-  = Just name--  | otherwise-  = Nothing--lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name-lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ--elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool-elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })-  = case rdr_name of-      Unqual occ -> occ  `elemOccEnv` env-      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]-      Qual {} -> False-      Orig {} -> False--localRdrEnvElts :: LocalRdrEnv -> [Name]-localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env--inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool--- This is the point of the NameSet-inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns--minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv-minusLocalRdrEnv lre@(LRE { lre_env = env }) occs-  = lre { lre_env = minusOccEnv env occs }--{--Note [Local bindings with Exact Names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With Template Haskell we can make local bindings that have Exact Names.-Computing shadowing etc may use elemLocalRdrEnv (at least it certainly-does so in GHC.Rename.HsType.bindHsQTyVars), so for an Exact Name we must consult-the in-scope-name-set.---************************************************************************-*                                                                      *-                        GlobalRdrEnv-*                                                                      *-************************************************************************--}---- | Global Reader Environment-type GlobalRdrEnv = OccEnv [GlobalRdrElt]--- ^ Keyed by 'OccName'; when looking up a qualified name--- we look up the 'OccName' part, and then check the 'Provenance'--- to see if the appropriate qualification is valid.  This--- saves routinely doubling the size of the env by adding both--- qualified and unqualified names to the domain.------ The list in the codomain is required because there may be name clashes--- These only get reported on lookup, not on construction------ INVARIANT 1: All the members of the list have distinct---              'gre_name' fields; that is, no duplicate Names------ INVARIANT 2: Imported provenance => Name is an ExternalName---              However LocalDefs can have an InternalName.  This---              happens only when type-checking a [d| ... |] Template---              Haskell quotation; see this note in GHC.Rename.Names---              Note [Top-level Names in Template Haskell decl quotes]------ INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then---                 greOccName gre = occ------              NB: greOccName gre is usually the same as---                  nameOccName (greMangledName gre), but not always in the---                  case of record selectors; see Note [GreNames]---- | Global Reader Element------ An element of the 'GlobalRdrEnv'-data GlobalRdrElt-  = GRE { gre_name :: !GreName      -- ^ See Note [GreNames]-        , gre_par  :: !Parent       -- ^ See Note [Parents]-        , gre_lcl ::  !Bool          -- ^ True <=> the thing was defined locally-        , gre_imp ::  !(Bag ImportSpec)  -- ^ In scope through these imports-    } deriving (Data)-         -- INVARIANT: either gre_lcl = True or gre_imp is non-empty-         -- See Note [GlobalRdrElt provenance]--instance NFData GlobalRdrElt where-  rnf (GRE name par _ imp) = rnf name `seq` rnf par `seq` rnf imp----- | See Note [Parents]-data Parent = NoParent-            | ParentIs  { par_is :: !Name }-            deriving (Eq, Data)--instance Outputable Parent where-   ppr NoParent        = empty-   ppr (ParentIs n)    = text "parent:" <> ppr n--instance NFData Parent where-  rnf NoParent = ()-  rnf (ParentIs n) = rnf n--plusParent :: Parent -> Parent -> Parent--- See Note [Combining parents]-plusParent p1@(ParentIs _)    p2 = hasParent p1 p2-plusParent p1 p2@(ParentIs _)    = hasParent p2 p1-plusParent NoParent NoParent     = NoParent--hasParent :: Parent -> Parent -> Parent-#if defined(DEBUG)-hasParent p NoParent = p-hasParent p p'-  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree-#endif-hasParent p _  = p---{- Note [GlobalRdrElt provenance]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",-i.e. how the Name came to be in scope.  It can be in scope two ways:-  - gre_lcl = True: it is bound in this module-  - gre_imp: a list of all the imports that brought it into scope--It's an INVARIANT that you have one or the other; that is, either-gre_lcl is True, or gre_imp is non-empty.--It is just possible to have *both* if there is a module loop: a Name-is defined locally in A, and also brought into scope by importing a-module that SOURCE-imported A.  Example (#7672):-- A.hs-boot   module A where-               data T-- B.hs        module B(Decl.T) where-               import {-# SOURCE #-} qualified A as Decl-- A.hs        module A where-               import qualified B-               data T = Z | S B.T--In A.hs, 'T' is locally bound, *and* imported as B.T.---Note [Parents]-~~~~~~~~~~~~~~~~~-The children of a Name are the things that are abbreviated by the ".." notation-in export lists.--~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  Parent           Children-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  data T           Data constructors-                   Record-field ids--  data family T    Data constructors and record-field ids-                   of all visible data instances of T--  class C          Class operations-                   Associated type constructors--~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  Constructor      Meaning-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  NoParent         Not bundled with a type constructor.-  ParentIs n       Bundled with the type constructor corresponding to n.--Pattern synonym constructors (and their record fields, if any) are unusual:-their gre_par is NoParent in the module in which they are defined.  However, a-pattern synonym can be bundled with a type constructor on export, in which case-whenever the pattern synonym is imported the gre_par will be ParentIs.--Thus the gre_name and gre_par fields are independent, because a normal datatype-introduces FieldGreNames using ParentIs, but a record pattern synonym can-introduce FieldGreNames that use NoParent. (In the past we represented fields-using an additional constructor of the Parent type, which could not adequately-represent this situation.) See also-Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail.---Note [GreNames]-~~~~~~~~~~~~~~~-A `GlobalRdrElt` has a field `gre_name :: GreName`, which uniquely-identifies what the `GlobalRdrElt` describes.  There are two sorts of-`GreName` (see the data type decl):--* NormalGreName Name: this is used for most entities; the Name-  uniquely identifies it. It is stored in the GlobalRdrEnv under-  the OccName of the Name.--* FieldGreName FieldLabel: is used only for field labels of a-  record. With -XDuplicateRecordFields there may be many field-  labels `x` in scope; e.g.-     data T1 = MkT1 { x :: Int }-     data T2 = MkT2 { x :: Bool }-  Each has a different GlobalRdrElt with a distinct GreName.-  The two fields are uniquely identified by their record selectors,-  which are stored in the FieldLabel, and have mangled names like-  `$sel:x:MkT1`.  See Note [FieldLabel] in GHC.Types.FieldLabel.--  These GREs are stored in the GlobalRdrEnv under the OccName of the-  field (i.e. "x" in both cases above), /not/ the OccName of the mangled-  record selector function.--A GreName, and hence a GRE, has both a "printable" and a "mangled" Name.  These-are identical for normal names, but for record fields compiled with--XDuplicateRecordFields they will differ. So we have two pairs of functions:-- * greNameMangledName :: GreName -> Name-   greMangledName :: GlobalRdrElt -> Name-   The "mangled" Name is the actual Name of the selector function,-   e.g. $sel:x:MkT1.  This should not be displayed to the user, but is used to-   uniquely identify the field in the renamer, and later in the backend.-- * greNamePrintableName :: GreName -> Name-   grePrintableName :: GlobalRdrElt -> Name-   The "printable" Name is the "manged" Name with its OccName replaced with that-   of the field label.  This is how the field should be output to the user.--Since the right Name to use is context-dependent, we do not define a NamedThing-instance for GREName (or GlobalRdrElt), but instead make the choice explicit.---Note [Combining parents]-~~~~~~~~~~~~~~~~~~~~~~~~-With an associated type we might have-   module M where-     class C a where-       data T a-       op :: T a -> a-     instance C Int where-       data T Int = TInt-     instance C Bool where-       data T Bool = TBool--Then:   C is the parent of T-        T is the parent of TInt and TBool-So: in an export list-    C(..) is short for C( op, T )-    T(..) is short for T( TInt, TBool )--Module M exports everything, so its exports will be-   AvailTC C [C,T,op]-   AvailTC T [T,TInt,TBool]-On import we convert to GlobalRdrElt and then combine-those.  For T that will mean we have-  one GRE with Parent C-  one GRE with NoParent-That's why plusParent picks the "best" case.--}---- | make a 'GlobalRdrEnv' where all the elements point to the same--- Provenance (useful for "hiding" imports, or imports with no details).-gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]--- prov = Nothing   => locally bound---        Just spec => imported as described by spec-gresFromAvails prov avails-  = concatMap (gresFromAvail (const prov)) avails--localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]--- Turn an Avail into a list of LocalDef GlobalRdrElts-localGREsFromAvail = gresFromAvail (const Nothing)--gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]-gresFromAvail prov_fn avail-  = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)-  where-    mk_gre n-      = case prov_fn n of  -- Nothing => bound locally-                           -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail-                         , gre_lcl = True, gre_imp = emptyBag }-          Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail-                         , gre_lcl = False, gre_imp = unitBag is }--    mk_fld_gre fl-      = case prov_fn (flSelector fl) of  -- Nothing => bound locally-                           -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail-                         , gre_lcl = True, gre_imp = emptyBag }-          Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail-                         , gre_lcl = False, gre_imp = unitBag is }--instance HasOccName GlobalRdrElt where-  occName = greOccName---- | See Note [GreNames]-greOccName :: GlobalRdrElt -> OccName-greOccName = occName . gre_name---- | A 'Name' for the GRE for internal use.  Careful: the 'OccName' of this--- 'Name' is not necessarily the same as the 'greOccName' (see Note [GreNames]).-greMangledName :: GlobalRdrElt -> Name-greMangledName = greNameMangledName . gre_name---- | A 'Name' for the GRE suitable for output to the user.  Its 'OccName' will--- be the 'greOccName' (see Note [GreNames]).-grePrintableName :: GlobalRdrElt -> Name-grePrintableName = greNamePrintableName . gre_name---- | The SrcSpan of the name pointed to by the GRE.-greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan-greDefinitionSrcSpan = nameSrcSpan . greMangledName---- | The module in which the name pointed to by the GRE is defined.-greDefinitionModule :: GlobalRdrElt -> Maybe Module-greDefinitionModule = nameModule_maybe . greMangledName--greQualModName :: GlobalRdrElt -> ModuleName--- Get a suitable module qualifier for the GRE--- (used in mkPrintUnqualified)--- Precondition: the greMangledName is always External-greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss })- | lcl, Just mod <- greDefinitionModule gre = moduleName mod- | Just is <- headMaybe iss                 = is_as (is_decl is)- | otherwise                                = pprPanic "greQualModName" (ppr gre)--greRdrNames :: GlobalRdrElt -> [RdrName]-greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }-  = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss)-  where-    occ    = greOccName gre-    unqual = Unqual occ-    do_spec decl_spec-        | is_qual decl_spec = unitBag qual-        | otherwise         = listToBag [unqual,qual]-        where qual = Qual (is_as decl_spec) occ---- the SrcSpan that pprNameProvenance prints out depends on whether--- the Name is defined locally or not: for a local definition the--- definition site is used, otherwise the location of the import--- declaration.  We want to sort the export locations in--- exportClashErr by this SrcSpan, we need to extract it:-greSrcSpan :: GlobalRdrElt -> SrcSpan-greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } )-  | lcl           = greDefinitionSrcSpan gre-  | Just is <- headMaybe iss = is_dloc (is_decl is)-  | otherwise     = pprPanic "greSrcSpan" (ppr gre)--mkParent :: Name -> AvailInfo -> Parent-mkParent _ (Avail _)                 = NoParent-mkParent n (AvailTC m _) | n == m    = NoParent-                         | otherwise = ParentIs m--availParent :: AvailInfo -> Parent-availParent (AvailTC m _) = ParentIs m-availParent (Avail {})    = NoParent---greParent_maybe :: GlobalRdrElt -> Maybe Name-greParent_maybe gre = case gre_par gre of-                        NoParent      -> Nothing-                        ParentIs n    -> Just n---- | Takes a list of distinct GREs and folds them--- into AvailInfos. This is more efficient than mapping each individual--- GRE to an AvailInfo and the folding using `plusAvail` but needs the--- uniqueness assumption.-gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]-gresToAvailInfo gres-  = nonDetNameEnvElts avail_env-  where-    avail_env :: NameEnv AvailInfo -- Keyed by the parent-    (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres--    add :: (NameEnv AvailInfo, NameSet)-        -> GlobalRdrElt-        -> (NameEnv AvailInfo, NameSet)-    add (env, done) gre-      | name `elemNameSet` done-      = (env, done)  -- Don't insert twice into the AvailInfo-      | otherwise-      = ( extendNameEnv_Acc comb availFromGRE env key gre-        , done `extendNameSet` name )-      where-        name = greMangledName gre-        key = case greParent_maybe gre of-                 Just parent -> parent-                 Nothing     -> greMangledName gre--        -- We want to insert the child `k` into a list of children but-        -- need to maintain the invariant that the parent is first.-        ---        -- We also use the invariant that `k` is not already in `ns`.-        insertChildIntoChildren :: Name -> [GreName] -> GreName -> [GreName]-        insertChildIntoChildren _ [] k = [k]-        insertChildIntoChildren p (n:ns) k-          | NormalGreName p == k = k:n:ns-          | otherwise = n:k:ns--        comb :: GlobalRdrElt -> AvailInfo -> AvailInfo-        comb _   (Avail n) = Avail n -- Duplicated name, should not happen-        comb gre (AvailTC m ns)-          = case gre_par gre of-              NoParent    -> AvailTC m (gre_name gre:ns) -- Not sure this ever happens-              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_name gre))--availFromGRE :: GlobalRdrElt -> AvailInfo-availFromGRE (GRE { gre_name = child, gre_par = parent })-  = case parent of-      ParentIs p -> AvailTC p [child]-      NoParent | NormalGreName me <- child, isTyConName me -> AvailTC me [child]-               | otherwise -> Avail child--emptyGlobalRdrEnv :: GlobalRdrEnv-emptyGlobalRdrEnv = emptyOccEnv--globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]-globalRdrEnvElts env = foldOccEnv (++) [] env--instance Outputable GlobalRdrElt where-  ppr gre = hang (ppr (greMangledName gre) <+> ppr (gre_par gre))-               2 (pprNameProvenance gre)--pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc-pprGlobalRdrEnv locals_only env-  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)")-             <+> lbrace-         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ]-             <+> rbrace) ]-  where-    remove_locals gres | locals_only = filter isLocalGRE gres-                       | otherwise   = gres-    pp []   = empty-    pp gres@(gre:_) = hang (ppr occ-                     <+> parens (text "unique" <+> ppr (getUnique occ))-                     <> colon)-                 2 (vcat (map ppr gres))-      where-        occ = nameOccName (greMangledName gre)--lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]-lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of-                                  Nothing   -> []-                                  Just gres -> gres--lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]--- ^ Look for this 'RdrName' in the global environment.  Omits record fields--- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env).-lookupGRE_RdrName rdr_name env =-    filter (not . isNoFieldSelectorGRE) (lookupGRE_RdrName' rdr_name env)--lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]--- ^ Look for this 'RdrName' in the global environment.  Includes record fields--- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env).-lookupGRE_RdrName' rdr_name env-  = case lookupOccEnv env (rdrNameOcc rdr_name) of-    Nothing   -> []-    Just gres -> pickGREs rdr_name gres--lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt--- ^ Look for precisely this 'Name' in the environment.  This tests--- whether it is in scope, ignoring anything else that might be in--- scope with the same 'OccName'.-lookupGRE_Name env name-  = lookupGRE_Name_OccName env name (nameOccName name)--lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt--- ^ Look for precisely this 'GreName' in the environment.  This tests--- whether it is in scope, ignoring anything else that might be in--- scope with the same 'OccName'.-lookupGRE_GreName env gname-  = lookupGRE_Name_OccName env (greNameMangledName gname) (occName gname)--lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt--- ^ Look for a particular record field selector in the environment, where the--- selector name and field label may be different: the GlobalRdrEnv is keyed on--- the label.  See Note [GreNames] for why this happens.-lookupGRE_FieldLabel env fl-  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (field_label $ flLabel fl))--lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt--- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'--- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and--- Note [GreNames].-lookupGRE_Name_OccName env name occ-  = case [ gre | gre <- lookupGlobalRdrEnv env occ-               , greMangledName gre == name ] of-      []    -> Nothing-      [gre] -> Just gre-      gres  -> pprPanic "lookupGRE_Name_OccName"-                        (ppr name $$ ppr occ $$ ppr gres)-               -- See INVARIANT 1 on GlobalRdrEnv---getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]--- Returns all the qualifiers by which 'x' is in scope--- Nothing means "the unqualified version is in scope"--- [] means the thing is not in scope at all-getGRE_NameQualifier_maybes env name-  = case lookupGRE_Name env name of-      Just gre -> [qualifier_maybe gre]-      Nothing  -> []-  where-    qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })-      | lcl       = Nothing-      | otherwise = Just $ map (is_as . is_decl) (bagToList iss)--isLocalGRE :: GlobalRdrElt -> Bool-isLocalGRE (GRE {gre_lcl = lcl }) = lcl--isRecFldGRE :: GlobalRdrElt -> Bool-isRecFldGRE = isJust . greFieldLabel--isDuplicateRecFldGRE :: GlobalRdrElt -> Bool--- ^ Is this a record field defined with DuplicateRecordFields?--- (See Note [GreNames])-isDuplicateRecFldGRE =-    maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel--isNoFieldSelectorGRE :: GlobalRdrElt -> Bool--- ^ Is this a record field defined with NoFieldSelectors?--- (See Note [NoFieldSelectors] in GHC.Rename.Env)-isNoFieldSelectorGRE =-    maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel--isFieldSelectorGRE :: GlobalRdrElt -> Bool--- ^ Is this a record field defined with FieldSelectors?--- (See Note [NoFieldSelectors] in GHC.Rename.Env)-isFieldSelectorGRE =-    maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel--greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel--- ^ Returns the field label of this GRE, if it has one-greFieldLabel = greNameFieldLabel . gre_name--unQualOK :: GlobalRdrElt -> Bool--- ^ Test if an unqualified version of this thing would be in scope-unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })-  | lcl = True-  | otherwise = any unQualSpecOK iss--{- Note [GRE filtering]-~~~~~~~~~~~~~~~~~~~~~~~-(pickGREs rdr gres) takes a list of GREs which have the same OccName-as 'rdr', say "x".  It does two things:--(a) filters the GREs to a subset that are in scope-    * Qualified,   as 'M.x'  if want_qual    is Qual M _-    * Unqualified, as 'x'    if want_unqual  is Unqual _--(b) for that subset, filter the provenance field (gre_lcl and gre_imp)-    to ones that brought it into scope qualified or unqualified resp.--Example:-      module A ( f ) where-      import qualified Foo( f )-      import Baz( f )-      f = undefined--Let's suppose that Foo.f and Baz.f are the same entity really, but the local-'f' is different, so there will be two GREs matching "f":-   gre1:  gre_lcl = True,  gre_imp = []-   gre2:  gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]--The use of "f" in the export list is ambiguous because it's in scope-from the local def and the import Baz(f); but *not* the import qualified Foo.-pickGREs returns two GRE-   gre1:   gre_lcl = True,  gre_imp = []-   gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]--Now the "ambiguous occurrence" message can correctly report how the-ambiguity arises.--}--pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]--- ^ Takes a list of GREs which have the right OccName 'x'--- Pick those GREs that are in scope---    * Qualified,   as 'M.x'  if want_qual    is Qual M _---    * Unqualified, as 'x'    if want_unqual  is Unqual _------ Return each such GRE, with its ImportSpecs filtered, to reflect--- how it is in scope qualified or unqualified respectively.--- See Note [GRE filtering]-pickGREs (Unqual {})  gres = mapMaybe pickUnqualGRE     gres-pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres-pickGREs _            _    = []  -- I don't think this actually happens--pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt-pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })-  | not lcl, null iss' = Nothing-  | otherwise          = Just (gre { gre_imp = iss' })-  where-    iss' = filterBag unQualSpecOK iss--pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt-pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss })-  | not lcl', null iss' = Nothing-  | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })-  where-    iss' = filterBag (qualSpecOK mod) iss-    lcl' = lcl && name_is_from mod--    name_is_from :: ModuleName -> Bool-    name_is_from mod = case greDefinitionModule gre of-                         Just n_mod -> moduleName n_mod == mod-                         Nothing    -> False--pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]--- ^ Pick GREs that are in scope *both* qualified *and* unqualified--- Return each GRE that is, as a pair---    (qual_gre, unqual_gre)--- These two GREs are the original GRE with imports filtered to express how--- it is in scope qualified an unqualified respectively------ 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---- | 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--- cluttered envt is no use.  Really, it's only useful for--- GHC.Base and GHC.Tuple.-pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)-pickBothGRE mod gre-  | isBuiltInSyntax (greMangledName gre)   = Nothing-  | Just gre1 <- pickQualGRE mod gre-  , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)-  | otherwise                        = Nothing---- Building GlobalRdrEnvs--plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv-plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2--mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv-mkGlobalRdrEnv gres-  = foldr add emptyGlobalRdrEnv gres-  where-    add gre env = extendOccEnv_Acc insertGRE Utils.singleton env-                                   (greOccName gre)-                                   gre--insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]-insertGRE new_g [] = [new_g]-insertGRE new_g (old_g : old_gs)-        | gre_name new_g == gre_name old_g-        = new_g `plusGRE` old_g : old_gs-        | otherwise-        = old_g : insertGRE new_g old_gs--plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt--- Used when the gre_name fields match-plusGRE g1 g2-  = GRE { gre_name = gre_name g1-        , gre_lcl  = gre_lcl g1 || gre_lcl g2-        , gre_imp  = gre_imp g1 `unionBags` gre_imp g2-        , gre_par  = gre_par  g1 `plusParent` gre_par  g2 }--transformGREs :: (GlobalRdrElt -> GlobalRdrElt)-              -> [OccName]-              -> GlobalRdrEnv -> GlobalRdrEnv--- ^ Apply a transformation function to the GREs for these OccNames-transformGREs trans_gre occs rdr_env-  = foldr trans rdr_env occs-  where-    trans occ env-      = case lookupOccEnv env occ of-           Just gres -> extendOccEnv env occ (map trans_gre gres)-           Nothing   -> env--extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv-extendGlobalRdrEnv env gre-  = extendOccEnv_Acc insertGRE Utils.singleton env-                     (greOccName gre) gre--{- Note [GlobalRdrEnv shadowing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Before adding new names to the GlobalRdrEnv we nuke some existing entries;-this is "shadowing".  The actual work is done by RdrEnv.shadowNames.-Suppose-   env' = shadowNames env f `extendGlobalRdrEnv` M.f--Then:-   * Looking up (Unqual f) in env' should succeed, returning M.f,-     even if env contains existing unqualified bindings for f.-     They are shadowed--   * Looking up (Qual M.f) in env' should succeed, returning M.f--   * Looking up (Qual X.f) in env', where X /= M, should be the same as-     looking up (Qual X.f) in env.--     That is, shadowNames does /not/ delete earlier qualified bindings--There are two reasons for shadowing:--* The GHCi REPL--  - Ids bought into scope on the command line (eg let x = True) have-    External Names, like Ghci4.x.  We want a new binding for 'x' (say)-    to override the existing binding for 'x'.  Example:--           ghci> :load M    -- Brings `x` and `M.x` into scope-           ghci> x-           ghci> "Hello"-           ghci> M.x-           ghci> "hello"-           ghci> let x = True  -- Shadows `x`-           ghci> x             -- The locally bound `x`-                               -- NOT an ambiguous reference-           ghci> True-           ghci> M.x           -- M.x is still in scope!-           ghci> "Hello"--    So when we add `x = True` we must not delete the `M.x` from the-    `GlobalRdrEnv`; rather we just want to make it "qualified only";-    hence the `set_qual` in `shadowNames`.  See also Note-    [Interactively-bound Ids in GHCi] in GHC.Runtime.Context--  - Data types also have External Names, like Ghci4.T; but we still want-    'T' to mean the newly-declared 'T', not an old one.--* Nested Template Haskell declaration brackets-  See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names--  Consider a TH decl quote:-      module M where-        f x = h [d| f = ...f...M.f... |]-  We must shadow the outer unqualified binding of 'f', else we'll get-  a complaint when extending the GlobalRdrEnv, saying that there are-  two bindings for 'f'.  There are several tricky points:--    - This shadowing applies even if the binding for 'f' is in a-      where-clause, and hence is in the *local* RdrEnv not the *global*-      RdrEnv.  This is done in lcl_env_TH in extendGlobalRdrEnvRn.--    - The External Name M.f from the enclosing module must certainly-      still be available.  So we don't nuke it entirely; we just make-      it seem like qualified import.--    - We only shadow *External* names (which come from the main module),-      or from earlier GHCi commands. Do not shadow *Internal* names-      because in the bracket-          [d| class C a where f :: a-              f = 4 |]-      rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the-      class decl, and *separately* extend the envt with the value binding.-      At that stage, the class op 'f' will have an Internal name.--}--shadowNames :: GlobalRdrEnv -> OccEnv a -> GlobalRdrEnv--- Remove certain old GREs that share the same OccName as this new Name.--- See Note [GlobalRdrEnv shadowing] for details-shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres))-  where-    shadow :: GlobalRdrElt -> Maybe GlobalRdrElt-    shadow-       old_gre@(GRE { gre_lcl = lcl, gre_imp = iss })-       = case greDefinitionModule old_gre of-           Nothing -> Just old_gre   -- Old name is Internal; do not shadow-           Just old_mod-              | null iss'            -- Nothing remains-              -> Nothing--              | otherwise-              -> Just (old_gre { gre_lcl = False, gre_imp = iss' })--              where-                iss' = lcl_imp `unionBags` mapMaybeBag set_qual iss-                lcl_imp | lcl       = listToBag [mk_fake_imp_spec old_gre old_mod]-                        | otherwise = emptyBag--    mk_fake_imp_spec old_gre old_mod    -- Urgh!-      = ImpSpec id_spec ImpAll-      where-        old_mod_name = moduleName old_mod-        id_spec      = ImpDeclSpec { is_mod = old_mod_name-                                   , is_as = old_mod_name-                                   , is_qual = True-                                   , is_dloc = greDefinitionSrcSpan old_gre }--    set_qual :: ImportSpec -> Maybe ImportSpec-    set_qual is = Just (is { is_decl = (is_decl is) { is_qual = True } })---{--************************************************************************-*                                                                      *-                        ImportSpec-*                                                                      *-************************************************************************--}---- | Import Specification------ The 'ImportSpec' of something says how it came to be imported--- It's quite elaborate so that we can give accurate unused-name warnings.-data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec,-                            is_item :: !ImpItemSpec }-                deriving( Eq, Data )--instance NFData ImportSpec where-  rnf = rwhnf -- All fields are strict, so we don't need to do anything---- | Import Declaration Specification------ Describes a particular import declaration and is--- shared among all the 'Provenance's for that decl-data ImpDeclSpec-  = ImpDeclSpec {-        is_mod      :: !ModuleName, -- ^ Module imported, e.g. @import Muggle@-                                   -- Note the @Muggle@ may well not be-                                   -- the defining module for this thing!--                                   -- TODO: either should be Module, or there-                                   -- should be a Maybe UnitId here too.-        is_as       :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)-        is_qual     :: !Bool,       -- ^ Was this import qualified?-        is_dloc     :: !SrcSpan     -- ^ The location of the entire import declaration-    } deriving (Eq, Data)---- | Import Item Specification------ Describes import info a particular Name-data ImpItemSpec-  = ImpAll              -- ^ The import had no import list,-                        -- or had a hiding list--  | ImpSome {-        is_explicit :: !Bool,-        is_iloc     :: !SrcSpan  -- Location of the import item-    }   -- ^ The import had an import list.-        -- The 'is_explicit' field is @True@ iff the thing was named-        -- /explicitly/ in the import specs rather-        -- than being imported as part of a "..." group. Consider:-        ---        -- > import C( T(..) )-        ---        -- Here the constructors of @T@ are not named explicitly;-        -- only @T@ is named explicitly.-  deriving (Eq, Data)--bestImport :: [ImportSpec] -> ImportSpec--- See Note [Choosing the best import declaration]-bestImport iss-  = case sortBy best iss of-      (is:_) -> is-      []     -> pprPanic "bestImport" (ppr iss)-  where-    best :: ImportSpec -> ImportSpec -> Ordering-    -- Less means better-    -- Unqualified always wins over qualified; then-    -- import-all wins over import-some; then-    -- earlier declaration wins over later-    best (ImpSpec { is_item = item1, is_decl = d1 })-         (ImpSpec { is_item = item2, is_decl = d2 })-      = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<>-        SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2)--    best_item :: ImpItemSpec -> ImpItemSpec -> Ordering-    best_item ImpAll ImpAll = EQ-    best_item ImpAll (ImpSome {}) = LT-    best_item (ImpSome {}) ImpAll = GT-    best_item (ImpSome { is_explicit = e1 })-              (ImpSome { is_explicit = e2 }) = e1 `compare` e2-     -- False < True, so if e1 is explicit and e2 is not, we get GT--{- Note [Choosing the best import declaration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When reporting unused import declarations we use the following rules.-   (see [wiki:commentary/compiler/unused-imports])--Say that an import-item is either-  * an entire import-all decl (eg import Foo), or-  * a particular item in an import list (eg import Foo( ..., x, ...)).-The general idea is that for each /occurrence/ of an imported name, we will-attribute that use to one import-item. Once we have processed all the-occurrences, any import items with no uses attributed to them are unused,-and are warned about. More precisely:--1. For every RdrName in the program text, find its GlobalRdrElt.--2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one-   the "chosen import-item", and mark it "used". This is done-   by 'bestImport'--3. After processing all the RdrNames, bleat about any-   import-items that are unused.-   This is done in GHC.Rename.Names.warnUnusedImportDecls.--The function 'bestImport' returns the dominant import among the-ImportSpecs it is given, implementing Step 2.  We say import-item A-dominates import-item B if we choose A over B. In general, we try to-choose the import that is most likely to render other imports-unnecessary.  Here is the dominance relationship we choose:--    a) import Foo dominates import qualified Foo.--    b) import Foo dominates import Foo(x).--    c) Otherwise choose the textually first one.--Rationale for (a).  Consider-   import qualified M  -- Import #1-   import M( x )       -- Import #2-   foo = M.x + x--The unqualified 'x' can only come from import #2.  The qualified 'M.x'-could come from either, but bestImport picks import #2, because it is-more likely to be useful in other imports, as indeed it is in this-case (see #5211 for a concrete example).--But the rules are not perfect; consider-   import qualified M  -- Import #1-   import M( x )       -- Import #2-   foo = M.x + M.y--The M.x will use import #2, but M.y can only use import #1.--}---unQualSpecOK :: ImportSpec -> Bool--- ^ Is in scope unqualified?-unQualSpecOK is = not (is_qual (is_decl is))--qualSpecOK :: ModuleName -> ImportSpec -> Bool--- ^ Is in scope qualified with the given module?-qualSpecOK mod is = mod == is_as (is_decl is)--importSpecLoc :: ImportSpec -> SrcSpan-importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl-importSpecLoc (ImpSpec _    item)   = is_iloc item--importSpecModule :: ImportSpec -> ModuleName-importSpecModule is = is_mod (is_decl is)--isExplicitItem :: ImpItemSpec -> Bool-isExplicitItem ImpAll                        = False-isExplicitItem (ImpSome {is_explicit = exp}) = exp--pprNameProvenance :: GlobalRdrElt -> SDoc--- ^ Print out one place where the name was define/imported--- (With -dppr-debug, print them all)-pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss })-  = ifPprDebug (vcat pp_provs)-               (head pp_provs)-  where-    name = greMangledName gre-    pp_provs = pp_lcl ++ map pp_is (bagToList iss)-    pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]-                    else []-    pp_is is = sep [ppr is, ppr_defn_site is name]---- If we know the exact definition point (which we may do with GHCi)--- then show that too.  But not if it's just "imported from X".-ppr_defn_site :: ImportSpec -> Name -> SDoc-ppr_defn_site imp_spec name-  | same_module && not (isGoodSrcSpan loc)-  = empty              -- Nothing interesting to say-  | otherwise-  = parens $ hang (text "and originally defined" <+> pp_mod)-                2 (pprLoc loc)-  where-    loc = nameSrcSpan name-    defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name-    same_module = importSpecModule imp_spec == moduleName defining_mod-    pp_mod | same_module = empty-           | otherwise   = text "in" <+> quotes (ppr defining_mod)---instance Outputable ImportSpec where-   ppr imp_spec-     = text "imported" <+> qual-        <+> text "from" <+> quotes (ppr (importSpecModule imp_spec))-        <+> pprLoc (importSpecLoc imp_spec)-     where-       qual | is_qual (is_decl imp_spec) = text "qualified"-            | otherwise                  = empty--pprLoc :: SrcSpan -> SDoc-pprLoc (RealSrcSpan s _)  = text "at" <+> ppr s-pprLoc (UnhelpfulSpan {}) = empty---- | Indicate if the given name is the "@" operator-opIsAt :: RdrName -> Bool-opIsAt e = e == mkUnqual varName (fsLit "@")+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- #name_types#+-- GHC uses several kinds of name internally:+--+-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types"+--+-- * 'GHC.Types.Name.Reader.RdrName' is the type of names that come directly from the parser. They+--   have not yet had their scoping and binding resolved by the renamer and can be+--   thought of to a first approximation as an 'GHC.Types.Name.Occurrence.OccName' with an optional module+--   qualifier+--+-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types"+--+-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types"+--+-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types"++module GHC.Types.Name.Reader (+        -- * The main type+        RdrName(..),    -- Constructors exported only to GHC.Iface.Binary++        -- ** Construction+        mkRdrUnqual, mkRdrQual,+        mkUnqual, mkVarUnqual, mkQual, mkOrig,+        nameRdrName, getRdrName,++        -- ** Destruction+        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,+        elemLocalRdrEnv, inLocalRdrEnvScope,+        localRdrEnvElts, minusLocalRdrEnv, minusLocalRdrEnvList,++        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's+        GlobalRdrEnvX, GlobalRdrEnv, IfGlobalRdrEnv,+        emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,+        extendGlobalRdrEnv, greOccName,+        pprGlobalRdrEnv, globalRdrEnvElts, globalRdrEnvLocal,++        -- ** Looking up 'GlobalRdrElt's+        FieldsOrSelectors(..), filterFieldGREs, allowGRE,++        LookupGRE(..), lookupGRE,+        WhichGREs(.., AllRelevantGREs, RelevantGREsFOS),+        greIsRelevant,++        lookupGRE_Name,+        lookupGRE_FieldLabel,+        getGRE_NameQualifier_maybes,+        transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE,++        -- * GlobalRdrElts+        availFromGRE,+        greRdrNames, greSrcSpan, greQualModName,+        gresToAvailInfo,+        greDefinitionModule, greDefinitionSrcSpan,+        greFieldLabel_maybe,++        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'+        GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt,+        greName, greNameSpace, greParent, greInfo,+        plusGRE, insertGRE,+        forceGlobalRdrEnv, hydrateGlobalRdrEnv,+        isLocalGRE, isImportedGRE, isRecFldGRE,+        fieldGREInfo,+        isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE,+        unQualOK, qualSpecOK, unQualSpecOK,+        pprNameProvenance,+        mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE,+        mkLocalConLikeGRE, mkLocalFieldGREs,+        gresToNameSet, greLevels,++        -- ** Shadowing+        greClashesWith, shadowNames,++        -- ** Information attached to a 'GlobalRdrElt'+        ConLikeName(..),+        GREInfo(..), RecFieldInfo(..),+        plusGREInfo,+        recFieldConLike_maybe, recFieldInfo_maybe,+        fieldGRE_maybe, fieldGRELabel,++        -- ** Parent information+        Parent(..), ParentGRE(..), greParent_maybe,+        mkParent, availParent,+        ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),+        importSpecLoc, importSpecModule, importSpecLevel, isExplicitItem, bestImport,+        ImportLevel(..),++        -- * Utils+        opIsAt,++  ) where++import GHC.Prelude++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.Maybe++import GHC.Types.Avail+import GHC.Types.Basic+import GHC.Types.GREInfo+import GHC.Types.FieldLabel+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.PkgQual+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique+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 Data.Data+import Data.List ( sort )+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified Data.Semigroup as S+import System.IO.Unsafe ( unsafePerformIO )++{-+************************************************************************+*                                                                      *+\subsection{The main data type}+*                                                                      *+************************************************************************+-}++-- | Reader Name+--+-- Do not use the data constructors of RdrName directly: prefer the family+-- of functions that creates them, such as 'mkRdrUnqual'+--+-- - Note: A Located RdrName will only have API Annotations if it is a+--         compound one,+--   e.g.+--+-- > `bar`+-- > ( ~ )+--+data RdrName+  = Unqual OccName+        -- ^ Unqualified  name+        --+        -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.+        -- Create such a 'RdrName' with 'mkRdrUnqual'++  | Qual ModuleName OccName+        -- ^ Qualified name+        --+        -- A qualified name written by the user in+        -- /source/ code.  The module isn't necessarily+        -- the module where the thing is defined;+        -- just the one from which it is imported.+        -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.+        -- Create such a 'RdrName' with 'mkRdrQual'++  | Orig Module OccName+        -- ^ Original name+        --+        -- An original name; the module is the /defining/ module.+        -- This is used when GHC generates code that will be fed+        -- into the renamer (e.g. from deriving clauses), but where+        -- we want to say \"Use Prelude.map dammit\". One of these+        -- can be created with 'mkOrig'++  | Exact Name+        -- ^ Exact name+        --+        -- We know exactly the 'Name'. This is used:+        --+        --  (1) When the parser parses built-in syntax like @[]@+        --      and @(,)@, but wants a 'RdrName' from it+        --+        --  (2) By Template Haskell, when TH has generated a unique name+        --+        -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'+  deriving Data++{-+************************************************************************+*                                                                      *+\subsection{Simple functions}+*                                                                      *+************************************************************************+-}++instance HasOccName RdrName where+  occName = rdrNameOcc++rdrNameOcc :: RdrName -> OccName+rdrNameOcc (Qual _ occ) = occ+rdrNameOcc (Unqual occ) = occ+rdrNameOcc (Orig _ occ) = occ+rdrNameOcc (Exact name) = nameOccName name++rdrNameSpace :: RdrName -> NameSpace+rdrNameSpace = occNameSpace . rdrNameOcc++-- | '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)+demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)+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)+demoteRdrNameTv (Orig _ _) = Nothing+demoteRdrNameTv (Exact _) = Nothing++-- promoteRdrName promotes the NameSpace of RdrName.+-- See Note [Promotion] in GHC.Rename.Env.+promoteRdrName :: RdrName -> Maybe RdrName+promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ)+promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ)+promoteRdrName (Orig _ _) = Nothing+promoteRdrName (Exact _)  = Nothing++        -- These two are the basic constructors+mkRdrUnqual :: OccName -> RdrName+mkRdrUnqual occ = Unqual occ++mkRdrQual :: ModuleName -> OccName -> RdrName+mkRdrQual mod occ = Qual mod occ++mkOrig :: Module -> OccName -> RdrName+mkOrig mod occ = Orig mod occ++---------------+        -- These two are used when parsing source files+        -- They do encode the module and occurrence names+mkUnqual :: NameSpace -> FastString -> RdrName+mkUnqual sp n = Unqual (mkOccNameFS sp n)++mkVarUnqual :: FastString -> RdrName+mkVarUnqual n = Unqual (mkVarOccFS n)++-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and+-- the 'OccName' are taken from the first and second elements of the tuple respectively+mkQual :: NameSpace -> (FastString, FastString) -> RdrName+mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)++getRdrName :: NamedThing thing => thing -> RdrName+getRdrName name = nameRdrName (getName name)++nameRdrName :: Name -> RdrName+nameRdrName name = Exact name+-- Keep the Name even for Internal names, so that the+-- unique is still there for debug printing, particularly+-- of Types (which are converted to IfaceTypes before printing)++nukeExact :: Name -> RdrName+nukeExact n+  | isExternalName n = Orig (nameModule n) (nameOccName n)+  | otherwise        = Unqual (nameOccName n)++isRdrDataCon :: RdrName -> Bool+isRdrTyVar   :: RdrName -> Bool+isRdrTc      :: RdrName -> Bool++isRdrDataCon rn = isDataOcc (rdrNameOcc rn)+isRdrTyVar   rn = isTvOcc   (rdrNameOcc rn)+isRdrTc      rn = isTcOcc   (rdrNameOcc rn)++isSrcRdrName :: RdrName -> Bool+isSrcRdrName (Unqual _) = True+isSrcRdrName (Qual _ _) = True+isSrcRdrName _          = False++isUnqual :: RdrName -> Bool+isUnqual (Unqual _) = True+isUnqual _          = False++isQual :: RdrName -> Bool+isQual (Qual _ _) = True+isQual _          = False++isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)+isQual_maybe (Qual m n) = Just (m,n)+isQual_maybe _          = Nothing++isOrig :: RdrName -> Bool+isOrig (Orig _ _) = True+isOrig _          = False++isOrig_maybe :: RdrName -> Maybe (Module, OccName)+isOrig_maybe (Orig m n) = Just (m,n)+isOrig_maybe _          = Nothing++isExact :: RdrName -> Bool+isExact (Exact _) = True+isExact _         = False++isExact_maybe :: RdrName -> Maybe Name+isExact_maybe (Exact n) = Just n+isExact_maybe _         = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Outputable RdrName where+    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 Nothing occ <> ppr occ)++instance OutputableBndr RdrName where+    pprBndr _ n+        | isTvOcc (rdrNameOcc n) = char '@' <> ppr n+        | otherwise              = ppr n++    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)+    pprPrefixOcc rdr+      | Just name <- isExact_maybe rdr = pprPrefixName name+             -- pprPrefixName has some special cases, so+             -- we delegate to them rather than reproduce them+      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)++instance Eq RdrName where+    (Exact n1)    == (Exact n2)    = n1==n2+        -- Convert exact to orig+    (Exact n1)    == r2@(Orig _ _) = nukeExact n1 == r2+    r1@(Orig _ _) == (Exact n2)    = r1 == nukeExact n2++    (Orig m1 o1)  == (Orig m2 o2)  = m1==m2 && o1==o2+    (Qual m1 o1)  == (Qual m2 o2)  = m1==m2 && o1==o2+    (Unqual o1)   == (Unqual o2)   = o1==o2+    _             == _             = False++instance Ord RdrName where+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }++        -- Exact < Unqual < Qual < Orig+        -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig+        --      before comparing so that Prelude.map == the exact Prelude.map, but+        --      that meant that we reported duplicates when renaming bindings+        --      generated by Template Haskell; e.g+        --      do { n1 <- newName "foo"; n2 <- newName "foo";+        --           <decl involving n1,n2> }+        --      I think we can do without this conversion+    compare (Exact n1) (Exact n2) = n1 `compare` n2+    compare (Exact _)  _          = LT++    compare (Unqual _)   (Exact _)    = GT+    compare (Unqual o1)  (Unqual  o2) = o1 `compare` o2+    compare (Unqual _)   _            = LT++    compare (Qual _ _)   (Exact _)    = GT+    compare (Qual _ _)   (Unqual _)   = GT+    compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2+    compare (Qual _ _)   (Orig _ _)   = LT++    compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2+    compare (Orig _ _)   _            = GT++{-+************************************************************************+*                                                                      *+                        LocalRdrEnv+*                                                                      *+************************************************************************+-}++{- Note [LocalRdrEnv]+~~~~~~~~~~~~~~~~~~~~~+The LocalRdrEnv is used to store local bindings (let, where, lambda, case).++* It is keyed by OccName, because we never use it for qualified names.++* It maps the OccName to a Name.  That Name is almost always an+  Internal Name, but (hackily) it can be External too for top-level+  pattern bindings.  See Note [bindLocalNames for an External name]+  in GHC.Rename.Pat++* We keep the current mapping (lre_env), *and* the set of all Names in+  scope (lre_in_scope).  Reason: see Note [Splicing Exact names] in+  GHC.Rename.Env.+-}++-- | Local Reader Environment+-- See Note [LocalRdrEnv]+data LocalRdrEnv = LRE { lre_env      :: OccEnv Name+                       , lre_in_scope :: NameSet }++instance Outputable LocalRdrEnv where+  ppr (LRE {lre_env = env, lre_in_scope = ns})+    = hang (text "LocalRdrEnv {")+         2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env+                 , text "in_scope ="+                    <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)+                 ] <+> char '}')+    where+      ppr_elt name = parens (ppr (nameOccName name)) <+> ppr name+                     -- So we can see if the keys line up correctly++emptyLocalRdrEnv :: LocalRdrEnv+emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv+                       , lre_in_scope = emptyNameSet }++extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv+-- See Note [LocalRdrEnv]+extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name+  = lre { lre_env      = extendOccEnv env (nameOccName name) name+        , lre_in_scope = extendNameSet ns name }++extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv+-- See Note [LocalRdrEnv]+extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names+  = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]+        , lre_in_scope = extendNameSetList ns names }++lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name+lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr+  | Unqual occ <- rdr+  = lookupOccEnv env occ++  -- See Note [Local bindings with Exact Names]+  | Exact name <- rdr+  , name `elemNameSet` ns+  = 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+lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ++elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool+elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })+  = case rdr_name of+      Unqual occ -> occ  `elemOccEnv` env+      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]+      Qual {} -> False+      Orig {} -> False++localRdrEnvElts :: LocalRdrEnv -> [Name]+localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env++inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool+-- This is the point of the NameSet+inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns++minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv+minusLocalRdrEnv lre@(LRE { lre_env = env }) occs+  = lre { lre_env = minusOccEnv env occs }++minusLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv+minusLocalRdrEnvList lre@(LRE { lre_env = env }) occs+  = lre { lre_env = delListFromOccEnv env occs }++{-+Note [Local bindings with Exact Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Template Haskell we can make local bindings that have Exact Names.+Computing shadowing etc may use elemLocalRdrEnv (at least it certainly+does so in GHC.Rename.HsType.bindHsQTyVars), so for an Exact Name we must consult+the in-scope-name-set.+++************************************************************************+*                                                                      *+                        GlobalRdrEnv+*                                                                      *+************************************************************************+-}++-- | Global Reader Environment+type GlobalRdrEnv = GlobalRdrEnvX GREInfo+-- ^ Keyed by 'OccName'; when looking up a qualified name+-- we look up the 'OccName' part, and then check the 'Provenance'+-- to see if the appropriate qualification is valid.  This+-- saves routinely doubling the size of the env by adding both+-- qualified and unqualified names to the domain.+--+-- The list in the codomain is required because there may be name clashes+-- These only get reported on lookup, not on construction+--+-- INVARIANT 1: All the members of the list have distinct+--              'gre_name' fields; that is, no duplicate Names+--+-- INVARIANT 2: Imported provenance => Name is an ExternalName+--              However LocalDefs can have an InternalName.  This+--              happens only when type-checking a [d| ... |] Template+--              Haskell quotation; see this note in GHC.Rename.Names+--              Note [Top-level Names in Template Haskell decl quotes]+--+-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then+--                 greOccName gre = occ++-- | A 'GlobalRdrEnv' in which the 'GlobalRdrElt's don't have any 'GREInfo'+-- attached to them. This is useful to avoid space leaks, see Note [IfGlobalRdrEnv].+type IfGlobalRdrEnv = GlobalRdrEnvX ()++-- | Parametrises 'GlobalRdrEnv' over the presence or absence of 'GREInfo'.+--+-- See Note [IfGlobalRdrEnv].+type GlobalRdrEnvX info = OccEnv [GlobalRdrEltX info]++-- | Global Reader Element+--+-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'.+-- See Note [GlobalRdrElt provenance].++type GlobalRdrElt   = GlobalRdrEltX GREInfo++-- | A 'GlobalRdrElt' in which we stripped out the 'GREInfo' field,+-- in order to avoid space leaks.+--+-- See Note [IfGlobalRdrEnv].+type IfGlobalRdrElt = GlobalRdrEltX ()++-- | Global Reader Element+--+-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'.+-- See Note [GlobalRdrElt provenance].+--+-- Why do we parametrise over the 'gre_info' field? See Note [IfGlobalRdrEnv].+data GlobalRdrEltX info+  = GRE { gre_name :: !Name+        , gre_par  :: !Parent            -- ^ See Note [Parents]+        , gre_lcl  :: !Bool              -- ^ True <=> the thing was defined locally+        , gre_imp  :: !(Bag ImportSpec)  -- ^ In scope through these imports+  -- See Note [GlobalRdrElt provenance] for the relation between gre_lcl and gre_imp.++        , gre_info :: info+            -- ^ Information the renamer knows about this particular 'Name'.+            --+            -- Careful about forcing this field! Forcing it can trigger+            -- the loading of interface files.+            --+            -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo.+    } deriving (Data)++instance NFData a => NFData (GlobalRdrEltX a) where+  rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info+++{- Note [IfGlobalRdrEnv]+~~~~~~~~~~~~~~~~~~~~~~~~+Information pertinent to the renamer about a 'Name' is stored in the fields of+'GlobalRdrElt'. The 'gre_info' field, described in Note [GREInfo] in GHC.Types.GREInfo,+is a bit special: as Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo+describes, for imported 'Name's it is usually obtained by a look up in a type environment,+and forcing can cause the interface file for the module defining the 'Name' to be+loaded. As described in Note [Forcing GREInfo] in GHC.Types.GREInfo, keeping it+a thunk can cause space leaks, while forcing it can cause extra work to be done.+So it's best to discard it when we don't need it, for example when we are about+to store it in a 'ModIface'.++We thus parametrise 'GlobalRdrElt' (and 'GlobalRdrEnv') over the presence or+absence of the 'GREInfo' field.++  - When we are about to stash the 'GlobalRdrElt' in a long-lived data structure,+    e.g. a 'ModIface', we force it by setting all the 'GREInfo' fields to '()'.+    See 'forceGlobalRdrEnv'.+  - To go back the other way, we use 'hydrateGlobalRdrEnv', which sets the+    'gre_info' fields back to lazy lookups.++This parametrisation also helps ensure that we don't accidentally force the+GREInfo field (which can cause unnecessary loading of interface files).+In particular, the 'lookupGRE' function is statically guaranteed to not consult+the 'GREInfo' field when using 'SameNameSpace', which is important+as we sometimes need to use this function with an 'IfaceGlobalRdrEnv' in which+the 'GREInfo' fields have been stripped.+-}++-- | A 'FieldGlobalRdrElt' is a 'GlobalRdrElt'+-- in which the 'gre_info' field is 'IAmRecField'.+type FieldGlobalRdrElt = GlobalRdrElt++greName :: GlobalRdrEltX info -> Name+greName = gre_name++greNameSpace :: GlobalRdrEltX info -> NameSpace+greNameSpace = nameNameSpace . greName++greParent :: GlobalRdrEltX info -> Parent+greParent = gre_par++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 }+            deriving (Eq, Data)++instance Outputable Parent where+   ppr NoParent        = empty+   ppr (ParentIs n)    = text "parent:" <> ppr n++instance NFData Parent where+  rnf NoParent = ()+  rnf (ParentIs n) = rnf n++plusParent :: Parent -> Parent -> Parent+-- See Note [Combining parents]+plusParent p1@(ParentIs _)    p2 = hasParent p1 p2+plusParent p1 p2@(ParentIs _)    = hasParent p2 p1+plusParent NoParent NoParent     = NoParent++hasParent :: Parent -> Parent -> Parent+#if defined(DEBUG)+hasParent p NoParent = p+hasParent p p'+  | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')  -- Parents should agree+#endif+hasParent p _  = p+++{- Note [GlobalRdrElt provenance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",+i.e. how the Name came to be in scope.  It can be in scope in one of the following+three ways:++  A. The Name was locally bound, in the current module.+     gre_lcl = True++     The renamer adds this Name to the GlobalRdrEnv after renaming the binding.+     See the calls to "extendGlobalRdrEnvRn" in GHC.Rename.Module.rnSrcDecls.++  B. The Name was imported+     gre_imp = Just imps <=> brought into scope by the imports "imps"++     The renamer adds this Name to the GlobalRdrEnv after processing the imports.+     See GHC.Rename.Names.filterImports and GHC.Tc.Module.tcRnImports.++  C. We followed an exact reference (i.e. an Exact or Orig RdrName)+     gre_lcl = False, gre_imp = Nothing++     In this case, we directly fetch a Name and its GREInfo from direct reference.+     We don't add it to the GlobalRdrEnv. See "GHC.Rename.Env.lookupExactOrOrig".++It is just about possible to have *both* gre_lcl = True and gre_imp = Just imps.+This can happen with module loops: a Name is defined locally in A, and also+brought into scope by importing a module that SOURCE-imported A.++Example (#7672):++ A.hs-boot   module A where+               data T++ B.hs        module B(Decl.T) where+               import {-# SOURCE #-} qualified A as Decl++ A.hs        module A where+               import qualified B+               data T = Z | S B.T++In A.hs, 'T' is locally bound, *and* imported as B.T.+++Note [Parents]+~~~~~~~~~~~~~~~~~+The children of a Name are the things that are abbreviated by the ".." notation+in export lists.++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Parent           Children+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  data T           Data constructors+                   Record-field ids++  data family T    Data constructors and record-field ids+                   of all visible data instances of T++  class C          Class operations+                   Associated type constructors++~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Constructor      Meaning+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  NoParent         Not bundled with a type constructor.+  ParentIs n       Bundled with the type constructor corresponding to n.++Pattern synonym constructors (and their record fields, if any) are unusual:+their gre_par is NoParent in the module in which they are defined.  However, a+pattern synonym can be bundled with a type constructor on export, in which case+whenever the pattern synonym is imported the gre_par will be ParentIs.++Thus the gre_name and gre_par fields are independent, because a normal datatype+introduces FieldGlobalRdrElts using ParentIs, but a record pattern synonym can+introduce FieldGlobalRdrElts that use NoParent. (In the past we represented+fields using an additional constructor of the Parent type, which could not+adequately represent this situation.) See also+Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail.++Note [Combining parents]+~~~~~~~~~~~~~~~~~~~~~~~~+With an associated type we might have+   module M where+     class C a where+       data T a+       op :: T a -> a+     instance C Int where+       data T Int = TInt+     instance C Bool where+       data T Bool = TBool++Then:   C is the parent of T+        T is the parent of TInt and TBool+So: in an export list+    C(..) is short for C( op, T )+    T(..) is short for T( TInt, TBool )++Module M exports everything, so its exports will be+   AvailTC C [C,T,op]+   AvailTC T [T,TInt,TBool]+On import we convert to GlobalRdrElt and then combine+those.  For T that will mean we have+  one GRE with Parent C+  one GRE with NoParent+That's why plusParent picks the "best" case.+-}++mkGRE :: (Name -> Maybe ImportSpec) -> GREInfo -> Parent -> Name -> GlobalRdrElt+mkGRE prov_fn info par n =+  case prov_fn n of+      -- Nothing => bound locally+      -- Just is => imported from 'is'+    Nothing -> GRE { gre_name = n, gre_par = par+                   , gre_lcl = True, gre_imp = emptyBag+                   , gre_info = info }+    Just is -> GRE { gre_name = n, gre_par = par+                   , gre_lcl = False, gre_imp = unitBag is+                   , gre_info = info }++mkExactGRE :: Name -> GREInfo -> GlobalRdrElt+mkExactGRE nm info =+  GRE { gre_name = nm, gre_par = NoParent+      , gre_lcl = False, gre_imp = emptyBag+      , gre_info = info }++mkLocalGRE :: GREInfo -> Parent -> Name -> GlobalRdrElt+mkLocalGRE = mkGRE (const Nothing)++mkLocalVanillaGRE :: Parent -> Name -> GlobalRdrElt+mkLocalVanillaGRE = mkLocalGRE Vanilla++-- | Create a local 'GlobalRdrElt' for a 'TyCon'.+mkLocalTyConGRE :: TyConFlavour Name+              -> Name+              -> GlobalRdrElt+mkLocalTyConGRE flav nm = mkLocalGRE (IAmTyCon flav) par nm+  where+    par = case tyConFlavourAssoc_maybe flav of+      Nothing -> NoParent+      Just p  -> ParentIs p++mkLocalConLikeGRE :: Parent -> (ConLikeName, ConInfo) -> GlobalRdrElt+mkLocalConLikeGRE p (con_nm, con_info) =+  mkLocalGRE (IAmConLike con_info) p (conLikeName_Name con_nm )++mkLocalFieldGREs :: Parent -> [(ConLikeName, ConInfo)] -> [GlobalRdrElt]+mkLocalFieldGREs p cons =+  [ mkLocalGRE (IAmRecField fld_info) p fld_nm+  | (S.Arg fld_nm fl, fl_cons) <- flds+  , let fld_info = RecFieldInfo { recFieldLabel = fl+                                , recFieldCons  = fl_cons } ]+  where+    -- We are given a map taking a constructor to its fields, but we want+    -- a map taking a field to the constructors which have it.+    -- We thus need to convert [(Con, [Field])] into [(Field, [Con])].+    flds = Map.toList+         $ Map.fromListWith unionUniqSets+         [ (S.Arg (flSelector fl) fl, unitUniqSet con)+         | (con, con_info) <- cons+         , ConInfo _ (ConHasRecordFields fls) <- [con_info]+         , fl <- NE.toList fls ]++instance HasOccName (GlobalRdrEltX info) where+  occName = greOccName++greOccName :: GlobalRdrEltX info -> OccName+greOccName ( GRE { gre_name = nm } ) = nameOccName nm++-- | The SrcSpan of the name pointed to by the GRE.+greDefinitionSrcSpan :: GlobalRdrEltX info -> SrcSpan+greDefinitionSrcSpan = nameSrcSpan . greName++-- | The module in which the name pointed to by the GRE is defined.+greDefinitionModule :: GlobalRdrEltX info -> Maybe Module+greDefinitionModule = nameModule_maybe . greName++greQualModName :: Outputable info => GlobalRdrEltX info -> ModuleName+-- Get a suitable module qualifier for the GRE+-- (used in mkPrintUnqualified)+-- Precondition: the gre_name is always External+greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss })+ | lcl, Just mod <- greDefinitionModule gre = moduleName mod+ | Just is <- headMaybe iss                 = is_as (is_decl is)+ | otherwise                                = pprPanic "greQualModName" (ppr gre)++greRdrNames :: GlobalRdrEltX info -> [RdrName]+greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }+  = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss)+  where+    occ    = greOccName gre+    unqual = Unqual occ+    do_spec decl_spec+        | is_qual decl_spec = unitBag qual+        | otherwise         = listToBag [unqual,qual]+        where qual = Qual (is_as decl_spec) occ++-- the SrcSpan that pprNameProvenance prints out depends on whether+-- the Name is defined locally or not: for a local definition the+-- definition site is used, otherwise the location of the import+-- declaration.  We want to sort the export locations in+-- exportClashErr by this SrcSpan, we need to extract it:+greSrcSpan :: Outputable info => GlobalRdrEltX info -> SrcSpan+greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } )+  | lcl           = greDefinitionSrcSpan gre+  | Just is <- headMaybe iss = is_dloc (is_decl is)+  | otherwise     = pprPanic "greSrcSpan" (ppr gre)++mkParent :: Name -> AvailInfo -> Parent+mkParent _ (Avail _)                 = NoParent+mkParent n (AvailTC m _) | n == m    = NoParent+                         | otherwise = ParentIs m++availParent :: AvailInfo -> Parent+availParent (AvailTC m _) = ParentIs m+availParent (Avail {})    = NoParent+++greParent_maybe :: GlobalRdrEltX info -> Maybe Name+greParent_maybe gre = case gre_par gre of+                        NoParent      -> Nothing+                        ParentIs n    -> Just n++gresToNameSet :: [GlobalRdrEltX info] -> NameSet+gresToNameSet gres = foldr add emptyNameSet gres+  where add gre set = extendNameSet set (greName gre)++-- | Takes a list of distinct GREs and folds them+-- into AvailInfos. This is more efficient than mapping each individual+-- GRE to an AvailInfo and then folding using `plusAvail`, but needs the+-- uniqueness assumption.+gresToAvailInfo :: forall info. [GlobalRdrEltX info] -> [AvailInfo]+gresToAvailInfo gres+  = nonDetNameEnvElts avail_env+  where+    avail_env :: NameEnv AvailInfo -- Keyed by the parent+    (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres++    add :: (NameEnv AvailInfo, NameSet)+        -> GlobalRdrEltX info+        -> (NameEnv AvailInfo, NameSet)+    add (env, done) gre+      | name `elemNameSet` done+      = (env, done)  -- Don't insert twice into the AvailInfo+      | otherwise+      = ( extendNameEnv_Acc comb availFromGRE env key gre+        , done `extendNameSet` name )+      where+        name = greName gre+        key = case greParent_maybe gre of+                 Just parent -> parent+                 Nothing     -> greName gre++        -- We want to insert the child `k` into a list of children but+        -- need to maintain the invariant that the parent is first.+        --+        -- We also use the invariant that `k` is not already in `ns`.+        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]+        insertChildIntoChildren _ [] k = [k]+        insertChildIntoChildren p (n:ns) k+          | p == k    = k:n:ns+          | otherwise = n:k:ns++        comb :: GlobalRdrEltX info -> AvailInfo -> AvailInfo+        comb _   (Avail n) = Avail n -- Duplicated name, should not happen+        comb gre (AvailTC m ns)+          = case gre_par gre of+              NoParent    -> AvailTC m (greName gre:ns) -- Not sure this ever happens+              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (greName gre))++availFromGRE :: GlobalRdrEltX info -> AvailInfo+availFromGRE (GRE { gre_name = child, gre_par = parent })+  = case parent of+      ParentIs p+        -> AvailTC p [child]+      NoParent+        | isTyConName child -- NB: don't force the GREInfo field unnecessarily.+        -> AvailTC child [child]+        | otherwise+        -> Avail child++emptyGlobalRdrEnv :: GlobalRdrEnvX info+emptyGlobalRdrEnv = emptyOccEnv++globalRdrEnvElts :: GlobalRdrEnvX info -> [GlobalRdrEltX info]+globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env++globalRdrEnvLocal :: GlobalRdrEnvX info -> GlobalRdrEnvX info+globalRdrEnvLocal = mapOccEnv (filter isLocalGRE)++-- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to+-- avoid space leaks.+-- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv+forceGlobalRdrEnv rdrs =+  strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs++-- | Hydrate a previously dehydrated 'GlobalRdrEnv',+-- by (lazily!) looking up the 'GREInfo' using the provided function.+--+-- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+hydrateGlobalRdrEnv :: forall info noInfo+                    .  (Name -> IO info)+                    -> GlobalRdrEnvX noInfo -> GlobalRdrEnvX info+hydrateGlobalRdrEnv f = mapOccEnv (fmap g)+  where+    g gre = gre { gre_info = unsafePerformIO $ f (greName gre) }+    -- NB: use unsafePerformIO to delay the lookup until it is forced.+    -- See also 'GHC.Rename.Env.lookupGREInfo'.++instance Outputable info => Outputable (GlobalRdrEltX info) where+  ppr gre = hang (ppr (greName gre) <+> ppr (gre_par gre) <+> ppr (gre_info gre))+               2 (pprNameProvenance gre)++pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc+pprGlobalRdrEnv locals_only env+  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)")+             <+> lbrace+         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ]+             <+> rbrace) ]+  where+    remove_locals gres | locals_only = filter isLocalGRE gres+                       | otherwise   = gres+    pp []   = empty+    pp gres@(gre:_) = hang (ppr occ <> colon)+                         2 (vcat (map ppr gres))+      where+        occ = nameOccName (greName gre)++{-+Note [NoFieldSelectors]+~~~~~~~~~~~~~~~~~~~~~~~+The NoFieldSelectors extension allows record fields to be defined without+bringing the corresponding selector functions into scope.  However, such fields+may still be used in contexts such as record construction, pattern matching or+update. This requires us to distinguish contexts in which selectors are required+from those in which any field may be used.  For example:++  {-# LANGUAGE NoFieldSelectors #-}+  module M (T(foo), foo) where  -- T(foo) refers to the field,+                                -- unadorned foo to the value binding+    data T = MkT { foo :: Int }+    foo = ()++    bar = foo -- refers to the value binding, field ignored++  module N where+    import M (T(..))+    baz = MkT { foo = 3 } -- refers to the field+    oops = foo -- an error: the field is in scope but the value binding is not++Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the+FieldSelectors extension was enabled in the defining module.  This allows them+to be filtered out by 'filterFieldGREs'.++Even when NoFieldSelectors is in use, we still generate selector functions+internally. For example, the expression+   getField @"foo" t+or (with dot-notation)+   t.foo+extracts the `foo` field of t::T, and hence needs the selector function+(see Note [HasField instances] in GHC.Tc.Instance.Class).++In many of the name lookup functions in this module we pass a FieldsOrSelectors+value, indicating what we are looking for:++ * WantNormal: fields are in scope only if they have an accompanying selector+   function, e.g. we are looking up a variable in an expression+   (lookupExprOccRn).++ * WantBoth: any name or field will do, regardless of whether the selector+   function is available, e.g. record updates (lookupRecUpdFields) with+   NoDisambiguateRecordFields.++ * WantField: any field will do, regardless of whether the selector function is+   available, but ignoring any non-field names, e.g. record updates+   (lookupRecUpdFields with DisambiguateRecordFields.++-----------------------------------------------------------------------------------+  Context                                  FieldsOrSelectors+-----------------------------------------------------------------------------------+  Record construction/pattern match        WantField, but unless DisambiguateRecordFields+  e.g. MkT { foo = 3 }                     is in effect, also look up using WantBoth+  Record update, e.g. e { foo = 3 }        to report when a non-field clashes with a field.++  :info in GHCi                            WantBoth++  Variable occurrence in expression        WantNormal+  Type variable, data constructor+  Pretty much everything else+-----------------------------------------------------------------------------------+-}++fieldGRE_maybe :: GlobalRdrElt -> Maybe FieldGlobalRdrElt+fieldGRE_maybe gre = do+  guard (isRecFldGRE gre)+  return gre++fieldGRELabel :: HasDebugCallStack => FieldGlobalRdrElt -> FieldLabel+fieldGRELabel = recFieldLabel . fieldGREInfo++fieldGREInfo :: HasDebugCallStack => FieldGlobalRdrElt -> RecFieldInfo+fieldGREInfo gre+  = assertPpr (isRecFldGRE gre) (ppr gre) $+    case greInfo gre of+      IAmRecField info -> info+      info -> pprPanic "fieldGREInfo" $+        vcat [ text "gre_name:" <+> ppr (greName gre)+             , text "info:" <+> ppr info ]++recFieldConLike_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe ConInfo+recFieldConLike_maybe gre =+  case greInfo gre of+    IAmConLike info -> Just info+    _               -> Nothing++recFieldInfo_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe RecFieldInfo+recFieldInfo_maybe gre =+  case greInfo gre of+    IAmRecField info -> assertPpr (isRecFldGRE gre) (ppr gre) $ Just info+    _                -> Nothing++-- | When looking up GREs, we may or may not want to include fields that were+-- defined in modules with @NoFieldSelectors@ enabled.  See Note+-- [NoFieldSelectors].+data FieldsOrSelectors+    = WantNormal -- ^ Include normal names, and fields with selectors, but+                 -- ignore fields without selectors.+    | WantBoth   -- ^ Include normal names and all fields (regardless of whether+                 -- they have selectors).+    | WantField  -- ^ Include only fields, with or without selectors, ignoring+                 -- any non-fields in scope.+  deriving (Eq, Show)++filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt]+filterFieldGREs WantBoth = id+filterFieldGREs fos = filter (allowGRE fos)++allowGRE :: FieldsOrSelectors -> GlobalRdrElt -> Bool+allowGRE WantBoth   _+  = True+allowGRE WantNormal gre+  -- NB: we only need to consult the GREInfo for record field GREs,+  -- to check whether they define field selectors.+  -- By checking 'isRecFldGRE' first, which only consults the NameSpace,+  -- we avoid forcing the GREInfo for things that aren't record fields.+  | isRecFldGRE gre+  = flHasFieldSelector (fieldGRELabel gre) == FieldSelectors+  | otherwise+  = True+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?+--+-- Depending on the answer, we might need more or less information from the+-- 'GlobalRdrEnv', e.g. if we want to include matching record fields we need+-- to know if the corresponding record fields define field selectors, for which+-- we need to consult the 'GREInfo'. This is why this datatype is a GADT.+--+-- See Note [IfGlobalRdrEnv].+data LookupGRE info where+  -- | Look for this specific 'OccName', with the exact same 'NameSpace',+  -- in the 'GlobalRdrEnv'.+  LookupOccName :: OccName -- ^ the 'OccName' to look up+                -> WhichGREs info+                    -- ^ information about other relevant 'NameSpace's+                -> LookupGRE info++  -- | Look up the 'OccName' of this 'RdrName' in the 'GlobalRdrEnv',+  -- filtering out those whose qualification matches that of the 'RdrName'.+  --+  -- Lookup returns an empty result for 'Exact' or 'Orig' 'RdrName's.+  LookupRdrName :: RdrName -- ^ the 'RdrName' to look up+                -> WhichGREs info+                    -- ^ information about other relevant 'NameSpace's+                -> LookupGRE info++  -- | Look for 'GRE's with the same unique as the given 'Name'+  -- in the 'GlobalRdrEnv'.+  LookupExactName+    :: { lookupExactName :: Name+          -- ^ the 'Name' to look up+       , lookInAllNameSpaces :: Bool+          -- ^ whether to look in *all* 'NameSpace's, or just+          -- in the 'NameSpace' of the 'Name'+          -- See Note [Template Haskell ambiguity]+       }+    -> LookupGRE info++  -- | Look up children 'GlobalRdrElt's with a given 'Parent'.+  LookupChildren+    :: 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?+data WhichGREs info where+  -- | Only consider 'GlobalRdrElt's with the exact 'NameSpace' we look up.+  SameNameSpace :: WhichGREs info+  -- | Allow 'GlobalRdrElt's with different 'NameSpace's, e.g. allow looking up+  -- record fields from the variable 'NameSpace', or looking up a 'TyCon' from+  -- the data constructor 'NameSpace'.+  RelevantGREs+    :: { includeFieldSelectors :: !FieldsOrSelectors+        -- ^ how should we handle looking up variables?+        --+        --   - should we include record fields defined with @-XNoFieldSelectors@?+        --   - should we include non-fields?+        --+        -- See Note [NoFieldSelectors].+       , lookupVariablesForFields :: !Bool+          -- ^ when looking up a record field, should we also look up plain variables?+       , lookupTyConsAsWell :: !Bool+          -- ^ when looking up a variable, field or data constructor, should we+          -- also try the type constructor 'NameSpace'?+       }+    -> WhichGREs GREInfo++instance Outputable (WhichGREs info) where+  ppr SameNameSpace = text "SameNameSpace"+  ppr (RelevantGREs { includeFieldSelectors = sel+                    , lookupVariablesForFields = vars+                    , lookupTyConsAsWell = tcs_too })+    = braces $ hsep+       [ text "RelevantGREs"+       , text (show sel)+       , if vars then text "[vars]" else empty+       , if tcs_too then text "[tcs]" else empty ]++-- | Look up as many possibly relevant 'GlobalRdrElt's as possible.+pattern AllRelevantGREs :: WhichGREs GREInfo+pattern AllRelevantGREs =+  RelevantGREs { includeFieldSelectors = WantBoth+               , lookupVariablesForFields = True+               , lookupTyConsAsWell = True }++-- | Look up relevant GREs, taking into account the interaction between the+-- variable and field 'NameSpace's as determined by the 'FieldsOrSelector'+-- argument.+pattern RelevantGREsFOS :: FieldsOrSelectors -> WhichGREs GREInfo+pattern RelevantGREsFOS fos <- RelevantGREs { includeFieldSelectors = fos }+  where+    RelevantGREsFOS fos =+      RelevantGREs { includeFieldSelectors = fos+                   , lookupVariablesForFields = fos == WantBoth+                   , lookupTyConsAsWell = False }++-- | 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?+greIsRelevant :: WhichGREs GREInfo -- ^ specification of which 'GlobalRdrElt's to consider relevant+              -> NameSpace    -- ^ the 'NameSpace' of the thing we are looking up+              -> GlobalRdrElt -- ^ the 'GlobalRdrElt' we have looked up, in a+                              -- potentially different 'NameSpace' than we wanted+              -> Bool+greIsRelevant which_gres ns gre+  | ns == other_ns+  = True+  | otherwise+  = case which_gres of+      SameNameSpace -> False+      RelevantGREs { includeFieldSelectors = fos+                   , lookupVariablesForFields = vars_for_flds+                   , lookupTyConsAsWell = tycons_too }+        | ns == varName+        -> (isFieldNameSpace other_ns && allowGRE fos gre) || tc_too+        | isFieldNameSpace ns+        -> vars_for_flds &&+          (  other_ns == varName+          || (isFieldNameSpace other_ns && allowGRE fos gre)+          || tc_too )+        | isDataConNameSpace ns+        -> tc_too+        | otherwise+        -> False+        where+          tc_too = tycons_too && isTcClsNameSpace other_ns+  where+    other_ns = greNameSpace gre++{- Note [childGREPriority]+~~~~~~~~~~~~~~~~~~~~~~~~~~+There are currently two places in the compiler where we look up GlobalRdrElts+which have a given Parent. These are the two calls to lookupSubBndrOcc_helper:++  A. Looking up children in an export item, e.g.++       module M ( T(MkT, D) ) where { data T = MkT; data D = D }++  B. Looking up binders in a class or instance declaration, e.g.+     the operator +++ in the fixity declaration:++       class C a where { type (+++) :: a -> a ->; infixl 6 +++ }+       (+++) :: Int -> Int -> Int; (+++) = (+)++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'?++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.++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'.+--+-- 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 (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 :: 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 wanted_ns+        , isTermVarOrFieldNameSpace child_ns+        = Just 0+        | 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`"+        -- inside a class declaration, we want to account for the possibility+        -- that the identifier refers to an associated type (type constructor+        -- NameSpace), when otherwise "+!" would be in the term-level variable+        -- NameSpace, and "Fun" would be in the term-level data constructor+        -- NameSpace.  See tests T10816, T23664, T24037.+        = 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 :: 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+-- whether there should there be any lee-way if the 'NameSpace's don't+-- exactly match.+lookupGRE :: GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]+lookupGRE env = \case+  LookupOccName occ which_gres ->+    case which_gres of+      SameNameSpace ->+        concat $ lookupOccEnv env occ+      rel@(RelevantGREs{}) ->+        filter (greIsRelevant rel (occNameSpace occ)) $+          concat $ lookupOccEnv_AllNameSpaces env occ+  LookupRdrName rdr rel ->+    pickGREs rdr $ lookupGRE env (LookupOccName (rdrNameOcc rdr) rel)+  LookupExactName { lookupExactName = nm+                  , lookInAllNameSpaces = all_ns } ->+      [ gre | gre <- lkup, greName gre == nm ]+    where+      occ = nameOccName nm+      lkup | all_ns    = concat $ lookupOccEnv_AllNameSpaces env occ+           | otherwise = fromMaybe [] $ lookupOccEnv env occ+  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).+--+-- This allows us to first look in e.g. the data 'NameSpace', and then fall back+-- to the type/class 'NameSpace'.+highestPriorityGREs :: forall gre prio+                    .  Ord prio+                    => (gre -> Maybe prio)+                      -- ^ priority function+                      -- lower value <=> higher priority+                    -> [gre] -> [gre]+highestPriorityGREs priority gres =+  take_highest_prio $ NE.group $ sort+    [ S.Arg prio gre+    | gre <- gres+    , prio <- maybeToList $ priority gre ]+  where+    take_highest_prio :: [NE.NonEmpty (S.Arg prio gre)] -> [gre]+    take_highest_prio [] = []+    take_highest_prio (fs:_) = map (\ (S.Arg _ gre) -> gre) $ NE.toList fs+{-# INLINEABLE highestPriorityGREs #-}++-- | Look for precisely this 'Name' in the environment,+-- in the __same 'NameSpace'__ as the 'Name'.+--+-- This tests whether it is in scope, ignoring anything+-- else that might be in scope which doesn't have the same 'Unique'.+lookupGRE_Name :: Outputable info => GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)+lookupGRE_Name env name =+  case lookupGRE env (LookupExactName { lookupExactName = name+                                      , lookInAllNameSpaces = False }) of+      []    -> Nothing+      [gre] -> Just gre+      gres  -> pprPanic "lookupGRE_Name"+                        (ppr name $$ ppr (nameOccName name) $$ ppr gres)+               -- See INVARIANT 1 on GlobalRdrEnv++-- | Look for a particular record field selector in the environment.+lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe FieldGlobalRdrElt+lookupGRE_FieldLabel env fl =+  case lookupGRE_Name env (flSelector fl) of+    Nothing -> Nothing+    Just gre ->+      assertPpr (isRecFldGRE gre)+        (vcat [ text "lookupGre_FieldLabel:" <+> ppr fl ]) $+        Just gre++getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]+-- Returns all the qualifiers by which 'x' is in scope+-- Nothing means "the unqualified version is in scope"+-- [] means the thing is not in scope at all+getGRE_NameQualifier_maybes env name+  = case lookupGRE_Name env name of+      Just gre -> [qualifier_maybe gre]+      Nothing  -> []+  where+    qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })+      | lcl       = Nothing+      | otherwise = Just $ map (is_as . is_decl) (bagToList iss)++-- | Is this 'GlobalRdrElt' defined locally?+isLocalGRE :: GlobalRdrEltX info -> Bool+isLocalGRE (GRE { gre_lcl = lcl }) = lcl++-- | Is this 'GlobalRdrElt' imported?+--+-- Not just the negation of 'isLocalGRE', because it might be an Exact or+-- Orig name reference. See Note [GlobalRdrElt provenance].+isImportedGRE :: GlobalRdrEltX info -> Bool+isImportedGRE (GRE { gre_imp = imps }) = not $ isEmptyBag imps++-- | Is this a record field GRE?+--+-- Important: does /not/ consult the 'GreInfo' field.+isRecFldGRE :: GlobalRdrEltX info -> Bool+isRecFldGRE (GRE { gre_name = nm }) = isFieldName nm++isDuplicateRecFldGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with DuplicateRecordFields?+isDuplicateRecFldGRE =+    maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel_maybe++isNoFieldSelectorGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with NoFieldSelectors?+-- (See Note [NoFieldSelectors] in GHC.Rename.Env)+isNoFieldSelectorGRE =+    maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe++isFieldSelectorGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with FieldSelectors?+-- (See Note [NoFieldSelectors] in GHC.Rename.Env)+isFieldSelectorGRE =+    maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe++greFieldLabel_maybe :: GlobalRdrElt -> Maybe FieldLabel+-- ^ Returns the field label of this GRE, if it has one+greFieldLabel_maybe = fmap fieldGRELabel . fieldGRE_maybe++unQualOK :: GlobalRdrEltX info -> Bool+-- ^ Test if an unqualified version of this thing would be in scope+unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })+  | lcl = True+  | otherwise = any unQualSpecOK iss++{- Note [GRE filtering]+~~~~~~~~~~~~~~~~~~~~~~~+(pickGREs rdr gres) takes a list of GREs which have the same OccName+as 'rdr', say "x".  It does two things:++(a) filters the GREs to a subset that are in scope+    * Qualified,   as 'M.x'  if want_qual    is Qual M _+    * Unqualified, as 'x'    if want_unqual  is Unqual _++(b) for that subset, filter the provenance field (gre_lcl and gre_imp)+    to ones that brought it into scope qualified or unqualified resp.++Example:+      module A ( f ) where+      import qualified Foo( f )+      import Baz( f )+      f = undefined++Let's suppose that Foo.f and Baz.f are the same entity really, but the local+'f' is different, so there will be two GREs matching "f":+   gre1:  gre_lcl = True,  gre_imp = []+   gre2:  gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ]++The use of "f" in the export list is ambiguous because it's in scope+from the local def and the import Baz(f); but *not* the import qualified Foo.+pickGREs returns two GRE+   gre1:   gre_lcl = True,  gre_imp = []+   gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]++Now the "ambiguous occurrence" message can correctly report how the+ambiguity arises.+-}++pickGREs :: RdrName -> [GlobalRdrEltX info] -> [GlobalRdrEltX info]+-- ^ Takes a list of GREs which have the right OccName 'x'+-- Pick those GREs that are in scope+--    * Qualified,   as 'M.x'  if want_qual    is Qual M _+--    * Unqualified, as 'x'    if want_unqual  is Unqual _+--+-- Return each such GRE, with its ImportSpecs filtered, to reflect+-- how it is in scope qualified or unqualified respectively.+-- See Note [GRE filtering]+pickGREs (Unqual {})  gres = mapMaybe pickUnqualGRE     gres+pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres+pickGREs _            _    = []  -- I don't think this actually happens++pickUnqualGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info)+pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })+  | not lcl, null iss' = Nothing+  | otherwise          = Just (gre { gre_imp = iss' })+  where+    iss' = filterBag unQualSpecOK iss++pickQualGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info)+pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss })+  | not lcl', null iss' = Nothing+  | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })+  where+    iss' = filterBag (qualSpecOK mod) iss+    lcl' = lcl && name_is_from mod++    name_is_from :: ModuleName -> Bool+    name_is_from mod = case greDefinitionModule gre of+                         Just n_mod -> moduleName n_mod == mod+                         Nothing    -> False++pickGREsModExp :: ModuleName -> [GlobalRdrEltX info] -> [(GlobalRdrEltX info,GlobalRdrEltX info)]+-- ^ Pick GREs that are in scope *both* qualified *and* unqualified+-- Return each GRE that is, as a pair+--    (qual_gre, unqual_gre)+-- These two GREs are the original GRE with imports filtered to express how+-- it is in scope qualified an unqualified respectively+--+-- Used only for the 'module M' item in export list;+--   see 'GHC.Tc.Gen.Export.exports_from_avail'+-- 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+-- cluttered envt is no use.  Really, it's only useful for+-- GHC.Base and GHC.Tuple.+pickBothGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info, GlobalRdrEltX info)+pickBothGRE mod gre+  | isBuiltInSyntax (greName gre)+  = Nothing+  | Just gre1 <- pickQualGRE mod gre+  , Just gre2 <- pickUnqualGRE   gre+  = Just (gre1, gre2)+  | otherwise+  = Nothing++-- Building GlobalRdrEnvs++plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv+plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2++mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv+mkGlobalRdrEnv gres+  = foldr add emptyGlobalRdrEnv gres+  where+    add gre env = extendOccEnv_Acc insertGRE Utils.singleton env+                                   (greOccName gre)+                                   gre++insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]+insertGRE new_g [] = [new_g]+insertGRE new_g (old_g : old_gs)+        | greName new_g == greName old_g+        = new_g `plusGRE` old_g : old_gs+        | otherwise+        = old_g : insertGRE new_g old_gs++plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt+-- Used when the gre_name fields match+plusGRE g1 g2+  = GRE { gre_name = gre_name g1+        , gre_lcl  = gre_lcl g1 || gre_lcl g2+        , gre_imp  = gre_imp g1 `unionBags` gre_imp g2+        , gre_par  = gre_par g1 `plusParent` gre_par g2+        , gre_info = gre_info g1 `plusGREInfo` gre_info g2 }++transformGREs :: (GlobalRdrElt -> GlobalRdrElt)+              -> [OccName]+              -> GlobalRdrEnv -> GlobalRdrEnv+-- ^ Apply a transformation function to the GREs for these OccNames+transformGREs trans_gre occs rdr_env+  = foldr trans rdr_env occs+  where+    trans occ env+      = case lookupOccEnv env occ of+           Just gres -> extendOccEnv env occ (map trans_gre gres)+           Nothing   -> env++extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv+extendGlobalRdrEnv env gre+  = extendOccEnv_Acc insertGRE Utils.singleton env+                     (greOccName gre) gre++{- Note [GlobalRdrEnv shadowing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before adding new names to the GlobalRdrEnv we nuke some existing entries;+this is "shadowing".  The actual work is done by GHC.Types.Name.Reader.shadowNames.+Suppose++   env' = shadowNames env { f } `extendGlobalRdrEnv` { M.f }++Then:+   * Looking up (Unqual f) in env' should succeed, returning M.f,+     even if env contains existing unqualified bindings for f.+     They are shadowed++   * Looking up (Qual M.f) in env' should succeed, returning M.f++   * Looking up (Qual X.f) in env', where X /= M, should be the same as+     looking up (Qual X.f) in env.++     That is, shadowNames does /not/ delete earlier qualified bindings++There are two reasons for shadowing:++* The GHCi REPL++  - Ids bought into scope on the command line (eg let x = True) have+    External Names, like Ghci4.x.  We want a new binding for 'x' (say)+    to override the existing binding for 'x'.  Example:++           ghci> :load M    -- Brings `x` and `M.x` into scope+           ghci> x+           ghci> "Hello"+           ghci> M.x+           ghci> "hello"+           ghci> let x = True  -- Shadows `x`+           ghci> x             -- The locally bound `x`+                               -- NOT an ambiguous reference+           ghci> True+           ghci> M.x           -- M.x is still in scope!+           ghci> "Hello"++    So when we add `x = True` we must not delete the `M.x` from the+    `GlobalRdrEnv`; rather we just want to make it "qualified only";+    hence the `set_qual` in `shadowNames`.  See also Note+    [Interactively-bound Ids in GHCi] in GHC.Runtime.Context++  - Data types also have External Names, like Ghci4.T; but we still want+    'T' to mean the newly-declared 'T', not an old one.++* Nested Template Haskell declaration brackets+  See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names++  Consider a TH decl quote:+      module M where+        f x = h [d| f = ...f...M.f... |]+  We must shadow the outer unqualified binding of 'f', else we'll get+  a complaint when extending the GlobalRdrEnv, saying that there are+  two bindings for 'f'.  There are several tricky points:++    - This shadowing applies even if the binding for 'f' is in a+      where-clause, and hence is in the *local* RdrEnv not the *global*+      RdrEnv.  This is done in lcl_env_TH in extendGlobalRdrEnvRn.++    - The External Name M.f from the enclosing module must certainly+      still be available.  So we don't nuke it entirely; we just make+      it seem like qualified import.++    - We only shadow *External* names (which come from the main module),+      or from earlier GHCi commands. Do not shadow *Internal* names+      because in the bracket+          [d| class C a where f :: a+              f = 4 |]+      rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the+      class decl, and *separately* extend the envt with the value binding.+      At that stage, the class op 'f' will have an Internal name.++Wrinkle [Shadowing namespaces]++  In the following GHCi session:++    > data A = MkA { foo :: Int }+    > foo = False+    > bar = foo++  We expect the variable 'foo' to shadow the record field 'foo', even though+  they are in separate namespaces, so that the occurrence of 'foo' in the body+  of 'bar' is not ambiguous.++-}++shadowNames :: Bool -- ^ discard names that are only available qualified?+            -> GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv+-- Remove certain old GREs that share the same OccName as this new Name.+-- See Note [GlobalRdrEnv shadowing] for details+shadowNames drop_only_qualified env new_gres = minusOccEnv_C_Ns do_shadowing env new_gres+  where++    do_shadowing :: UniqFM NameSpace [GlobalRdrElt]+                 -> UniqFM NameSpace [GlobalRdrElt]+                 -> UniqFM NameSpace [GlobalRdrElt]+    do_shadowing olds news =+      -- Start off by accumulating all 'NameSpace's shadowed+      -- by the entire collection of new GREs.+      let shadowed_gres :: ShadowedGREs+          shadowed_gres =+            nonDetFoldUFM (\ gres shads -> foldMap greShadowedNameSpaces gres S.<> shads)+              mempty news++      -- Then shadow the old 'GlobalRdrElt's, now that we know which 'NameSpace's+      -- should be shadowed.+          shadow_list :: Unique -> [GlobalRdrElt] -> Maybe [GlobalRdrElt]+          shadow_list old_ns old_gres =+            case namespace_is_shadowed old_ns shadowed_gres of+              IsNotShadowed -> Just old_gres+              IsShadowed    -> guard_nonEmpty $ mapMaybe shadow old_gres+              IsShadowedIfFieldSelector ->+                guard_nonEmpty $+                mapMaybe (\ old_gre -> if isFieldSelectorGRE old_gre then shadow old_gre else Just old_gre)+                  old_gres++      -- Now do all of the shadowing in a single go. This avoids traversing+      -- the old GlobalRdrEnv multiple times over.+      in mapMaybeWithKeyUFM shadow_list olds++    guard_nonEmpty :: [a] -> Maybe [a]+    guard_nonEmpty xs | null xs   = Nothing+                      | otherwise = Just xs++    -- Shadow a single GRE, by either qualifying it or removing it entirely.+    shadow :: GlobalRdrElt-> Maybe GlobalRdrElt+    shadow old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) =+      case greDefinitionModule old_gre of+        Nothing -> Just old_gre   -- Old name is Internal; do not shadow+        Just old_mod+           |  null iss'            -- Nothing remains+           || drop_only_qualified+           -> Nothing++           | otherwise+           -> Just (old_gre { gre_lcl = False, gre_imp = iss' })++           where+             iss' = lcl_imp `unionBags` mapBag set_qual iss+             lcl_imp | lcl       = unitBag $ mk_fake_imp_spec old_gre old_mod+                     | otherwise = emptyBag++    mk_fake_imp_spec old_gre old_mod    -- Urgh!+      = ImpSpec id_spec ImpAll+      where+        old_mod_name = moduleName old_mod+        id_spec      = ImpDeclSpec { is_mod = old_mod+                                   , 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 }++    set_qual :: ImportSpec -> ImportSpec+    set_qual is = is { is_decl = (is_decl is) { is_qual = True } }++-- | @greClashesWith new_gre old_gre@ computes whether @new_gre@ clashes+-- with @old_gre@ (assuming they both have the same underlying 'occNameFS').+greClashesWith :: GlobalRdrElt -> (GlobalRdrElt -> Bool)+greClashesWith new_gre old_gre =+  old_gre `greIsShadowed` greShadowedNameSpaces new_gre++-- | Is the given 'GlobalRdrElt' shadowed, as specified by the 'ShadowedNameSpace's?+greIsShadowed :: GlobalRdrElt -> ShadowedGREs -> Bool+greIsShadowed old_gre shadowed =+  case getUnique old_ns `namespace_is_shadowed` shadowed of+    IsShadowed                -> True+    IsNotShadowed             -> False+    IsShadowedIfFieldSelector -> isFieldSelectorGRE old_gre+  where+    old_ns = occNameSpace $ greOccName old_gre+++-- | Whether a 'GlobalRdrElt' is definitely shadowed, definitely not shadowed,+-- or conditionally shadowed based on more information beyond the 'NameSpace'.+data IsShadowed+  -- | The GRE is not shadowed.+  = IsNotShadowed+  -- | The GRE is shadowed.+  | IsShadowed+  -- | The GRE is shadowed iff it is a record field GRE+  -- which defines a field selector (i.e. FieldSelectors is enabled in its+  -- defining module).+  | IsShadowedIfFieldSelector++-- | Internal function: is a 'GlobalRdrElt' with the 'NameSpace' with given+-- 'Unique' shadowed by the specified 'ShadowedGREs'?+namespace_is_shadowed :: Unique -> ShadowedGREs -> IsShadowed+namespace_is_shadowed old_ns (ShadowedGREs shadowed_nonflds shadowed_flds)+  | isFldNSUnique old_ns+  = case shadowed_flds of+      ShadowAllFieldGREs -> IsShadowed+      ShadowFieldSelectorsAnd shadowed+        | old_ns `elemUniqSet_Directly` shadowed+        -> IsShadowed+        | otherwise+        -> IsShadowedIfFieldSelector+      ShadowFieldNameSpaces shadowed+        | old_ns `elemUniqSet_Directly` shadowed+        -> IsShadowed+        | otherwise+        -> IsNotShadowed+  | old_ns `elemUniqSet_Directly` shadowed_nonflds+  = IsShadowed+  | otherwise+  = IsNotShadowed++-- | What are all the 'GlobalRdrElt's that are shadowed by this new 'GlobalRdrElt'?+greShadowedNameSpaces :: GlobalRdrElt -> ShadowedGREs+greShadowedNameSpaces gre = ShadowedGREs shadowed_nonflds shadowed_flds+  where+    ns = occNameSpace $ greOccName gre+    !shadowed_nonflds+      | isFieldNameSpace ns+      -- A new record field shadows variables if it defines a field selector.+      = if isFieldSelectorGRE gre+        then unitUniqSet varName+        else emptyUniqSet+      | otherwise+      = unitUniqSet ns+    !shadowed_flds+      | ns == varName+      -- A new variable shadows record fields with field selectors.+      = ShadowFieldSelectorsAnd emptyUniqSet+      | isFieldNameSpace ns+      -- A new record field shadows record fields unless it is a duplicate record field.+      = if isDuplicateRecFldGRE gre+        then ShadowFieldNameSpaces (unitUniqSet ns)+        -- NB: we must still shadow fields with the same constructor name.+        else ShadowAllFieldGREs+      | otherwise+      = ShadowFieldNameSpaces emptyUniqSet++-- | A description of which 'GlobalRdrElt's are shadowed.+data ShadowedGREs+  = ShadowedGREs+    { shadowedNonFieldNameSpaces :: !(UniqSet NameSpace)+      -- ^ These specific non-field 'NameSpace's are shadowed.+    , shadowedFieldGREs :: !ShadowedFieldGREs+      -- ^ These field 'GlobalRdrElt's are shadowed.+    }++-- | A description of which record field 'GlobalRdrElt's are shadowed.+data ShadowedFieldGREs+  -- | All field 'GlobalRdrElt's are shadowed.+  = ShadowAllFieldGREs+  -- | Record field GREs defining field selectors, as well as those+  -- with the explicitly specified field 'NameSpace's, are shadowed.+  | ShadowFieldSelectorsAnd { shadowedFieldNameSpaces :: !(UniqSet NameSpace) }+  -- | These specific field 'NameSpace's are shadowed.+  | ShadowFieldNameSpaces { shadowedFieldNameSpaces :: !(UniqSet NameSpace) }++instance Monoid ShadowedFieldGREs where+  mempty = ShadowFieldNameSpaces { shadowedFieldNameSpaces = emptyUniqSet }++instance Semigroup ShadowedFieldGREs where+  ShadowAllFieldGREs <> _ = ShadowAllFieldGREs+  _ <> ShadowAllFieldGREs = ShadowAllFieldGREs+  ShadowFieldSelectorsAnd ns1 <> ShadowFieldSelectorsAnd ns2 =+    ShadowFieldSelectorsAnd (ns1 S.<> ns2)+  ShadowFieldSelectorsAnd ns1 <> ShadowFieldNameSpaces ns2 =+    ShadowFieldSelectorsAnd (ns1 S.<> ns2)+  ShadowFieldNameSpaces ns1 <> ShadowFieldSelectorsAnd ns2 =+    ShadowFieldSelectorsAnd (ns1 S.<> ns2)+  ShadowFieldNameSpaces ns1 <> ShadowFieldNameSpaces ns2 =+    ShadowFieldNameSpaces (ns1 S.<> ns2)++instance Monoid ShadowedGREs where+  mempty =+    ShadowedGREs+      { shadowedNonFieldNameSpaces = emptyUniqSet+      , shadowedFieldGREs = mempty }++instance Semigroup ShadowedGREs where+  ShadowedGREs nonflds1 flds1 <> ShadowedGREs nonflds2 flds2 =+    ShadowedGREs (nonflds1 S.<> nonflds2) (flds1 S.<> flds2)++{-+************************************************************************+*                                                                      *+                        ImportSpec+*                                                                      *+************************************************************************+-}++-- | Import Specification+--+-- The 'ImportSpec' of something says how it came to be imported+-- It's quite elaborate so that we can give accurate unused-name warnings.+data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec,+                            is_item :: !ImpItemSpec }+                deriving( Eq, Data )++instance NFData ImportSpec where+  rnf = rwhnf -- All fields are strict, so we don't need to do anything++-- | Import Declaration Specification+--+-- Describes a particular import declaration and is+-- shared among all the 'Provenance's for that decl+data ImpDeclSpec+  = ImpDeclSpec {+        is_mod      :: !Module,     -- ^ Module imported, e.g. @import Muggle@+                                   -- Note the @Muggle@ may well not be+                                   -- the defining module for this thing!++                                   -- TODO: either should be Module, or there+                                   -- should be a Maybe UnitId here too.+        is_as       :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause)+        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_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+data ImpItemSpec+  = ImpAll              -- ^ The import had no import list,+                        -- or had a hiding list++  | ImpSome {+        is_explicit :: !Bool,+        is_iloc     :: !SrcSpan  -- Location of the import item+    }   -- ^ The import had an import list.+        -- The 'is_explicit' field is @True@ iff the thing was named+        -- /explicitly/ in the import specs rather+        -- than being imported as part of a "..." group. Consider:+        --+        -- > import C( T(..) )+        --+        -- Here the constructors of @T@ are not named explicitly;+        -- only @T@ is named explicitly.+  deriving (Eq, Data)++bestImport :: NE.NonEmpty ImportSpec -> ImportSpec+-- See Note [Choosing the best import declaration]+bestImport iss = NE.head $ NE.sortBy best iss+  where+    best :: ImportSpec -> ImportSpec -> Ordering+    -- Less means better+    -- Unqualified always wins over qualified; then+    -- import-all wins over import-some; then+    -- earlier declaration wins over later+    best (ImpSpec { is_item = item1, is_decl = d1 })+         (ImpSpec { is_item = item2, is_decl = d2 })+      = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<>+        SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2)++    best_item :: ImpItemSpec -> ImpItemSpec -> Ordering+    best_item ImpAll ImpAll = EQ+    best_item ImpAll (ImpSome {}) = LT+    best_item (ImpSome {}) ImpAll = GT+    best_item (ImpSome { is_explicit = e1 })+              (ImpSome { is_explicit = e2 }) = e1 `compare` e2+     -- False < True, so if e1 is explicit and e2 is not, we get GT++{- Note [Choosing the best import declaration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When reporting unused import declarations we use the following rules.+   (see [wiki:commentary/compiler/unused-imports])++Say that an import-item is either+  * an entire import-all decl (eg import Foo), or+  * a particular item in an import list (eg import Foo( ..., x, ...)).+The general idea is that for each /occurrence/ of an imported name, we will+attribute that use to one import-item. Once we have processed all the+occurrences, any import items with no uses attributed to them are unused,+and are warned about. More precisely:++1. For every RdrName in the program text, find its GlobalRdrElt.++2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one+   the "chosen import-item", and mark it "used". This is done+   by 'bestImport'++3. After processing all the RdrNames, bleat about any+   import-items that are unused.+   This is done in GHC.Rename.Names.warnUnusedImportDecls.++The function 'bestImport' returns the dominant import among the+ImportSpecs it is given, implementing Step 2.  We say import-item A+dominates import-item B if we choose A over B. In general, we try to+choose the import that is most likely to render other imports+unnecessary.  Here is the dominance relationship we choose:++    a) import Foo dominates import qualified Foo.++    b) import Foo dominates import Foo(x).++    c) Otherwise choose the textually first one.++Rationale for (a).  Consider+   import qualified M  -- Import #1+   import M( x )       -- Import #2+   foo = M.x + x++The unqualified 'x' can only come from import #2.  The qualified 'M.x'+could come from either, but bestImport picks import #2, because it is+more likely to be useful in other imports, as indeed it is in this+case (see #5211 for a concrete example).++But the rules are not perfect; consider+   import qualified M  -- Import #1+   import M( x )       -- Import #2+   foo = M.x + M.y++The M.x will use import #2, but M.y can only use import #1.+-}+++unQualSpecOK :: ImportSpec -> Bool+-- ^ Is in scope unqualified?+unQualSpecOK is = not (is_qual (is_decl is))++qualSpecOK :: ModuleName -> ImportSpec -> Bool+-- ^ Is in scope qualified with the given module?+qualSpecOK mod is = mod == is_as (is_decl is)++importSpecLoc :: ImportSpec -> SrcSpan+importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl+importSpecLoc (ImpSpec _    item)   = is_iloc item++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++pprNameProvenance :: GlobalRdrEltX info -> SDoc+-- ^ Print out one place where the name was define/imported+-- (With -dppr-debug, print them all)+pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+  = ifPprDebug (vcat pp_provs)+               (head pp_provs)+  where+    pp_provs = pp_lcl ++ map pp_is (bagToList iss)+    pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]+                    else []+    pp_is is = sep [ppr is, ppr_defn_site is name]++-- If we know the exact definition point (which we may do with GHCi)+-- then show that too.  But not if it's just "imported from X".+ppr_defn_site :: ImportSpec -> Name -> SDoc+ppr_defn_site imp_spec name+  | same_module && not (isGoodSrcSpan loc)+  = empty              -- Nothing interesting to say+  | otherwise+  = parens $ hang (text "and originally defined" <+> pp_mod)+                2 (pprLoc loc)+  where+    loc = nameSrcSpan name+    defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name+    same_module = importSpecModule imp_spec == moduleName defining_mod+    pp_mod | same_module = empty+           | otherwise   = text "in" <+> quotes (ppr defining_mod)+++instance Outputable ImportSpec where+   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++-- | 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/Name/Set.hs view
@@ -22,7 +22,7 @@         -- ** Manipulating sets of free variables         isEmptyFVs, emptyFVs, plusFVs, plusFV,         mkFVs, addOneFV, unitFV, delFV, delFVs,-        intersectFVs,+        intersectFVs, intersectsFVs,          -- * Defs and uses         Defs, Uses, DefUse, DefUses,@@ -127,6 +127,7 @@ delFV    :: Name -> FreeVars -> FreeVars delFVs   :: [Name] -> FreeVars -> FreeVars intersectFVs :: FreeVars -> FreeVars -> FreeVars+intersectsFVs :: FreeVars -> FreeVars -> Bool  isEmptyFVs :: NameSet -> Bool isEmptyFVs  = isEmptyNameSet@@ -139,6 +140,7 @@ delFV n s   = delFromNameSet s n delFVs ns s = delListFromNameSet s ns intersectFVs = intersectNameSet+intersectsFVs = intersectsNameSet  {- ************************************************************************
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@@ -22,8 +23,8 @@ -- package qualifier. data PkgQual   = NoPkgQual       -- ^ No package qualifier-  | ThisPkg  UnitId -- ^ Import from home-unit-  | OtherPkg UnitId -- ^ Import from another unit+  | ThisPkg  !UnitId -- ^ Import from home-unit+  | OtherPkg !UnitId -- ^ Import from another unit   deriving (Data, Ord, Eq)  instance Outputable RawPkgQual where@@ -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
@@ -4,22 +4,22 @@ module GHC.Types.RepType   (     -- * Code generator views onto Types-    UnaryType, NvUnaryType, isNvUnaryType,+    UnaryType, NvUnaryType, isNvUnaryRep,     unwrapType,      -- * Predicates on types     isZeroBitTy,      -- * Type representation for the code generator-    typePrimRep, typePrimRep1,-    runtimeRepPrimRep, typePrimRepArgs,+    typePrimRep, typePrimRep1, typePrimRepU,+    runtimeRepPrimRep,     PrimRep(..), primRepToRuntimeRep, primRepToType,     countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,-    tyConPrimRep, tyConPrimRep1,+    tyConPrimRep,     runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,      -- * Unboxed sum representation type-    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),+    ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..),     slotPrimRep, primRepSlot,      -- * Is this type known to be data?@@ -38,7 +38,7 @@ import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind   , vecRepDataConTyCon-  , liftedRepTy, unliftedRepTy, zeroBitRepTy+  , liftedRepTy, unliftedRepTy   , intRepDataConTy   , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy   , wordRepDataConTy@@ -76,22 +76,9 @@      --   UnaryType   : never an unboxed tuple or sum;      --                 can be Void# or (# #) -isNvUnaryType :: Type -> Bool-isNvUnaryType ty-  | [_] <- typePrimRep ty-  = True-  | otherwise-  = False---- INVARIANT: the result list is never empty.-typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]-typePrimRepArgs ty-  | [] <- reps-  = [VoidRep]-  | otherwise-  = reps-  where-    reps = typePrimRep ty+isNvUnaryRep :: [PrimRep] -> Bool+isNvUnaryRep [_] = True+isNvUnaryRep _ = False  -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including:@@ -124,12 +111,19 @@       | otherwise       = NS_Done +-- | Count the arity of a function post-unarisation, including zero-width arguments.+--+-- The post-unarisation arity may be larger than the arity of the original+-- function type. See Note [Unarisation]. countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _   = 0 countFunRepArgs n ty   | FunTy _ _ arg res <- unwrapType ty-  = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res+  = (length (typePrimRep arg) `max` 1)+    + countFunRepArgs (n - 1) res+    -- If typePrimRep returns [] that means a void arg,+    -- and we count 1 for that   | otherwise   = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -160,21 +154,18 @@      go repMarks repTys []   where     go (mark:marks) (ty:types) out_marks-      -- Zero-width argument, mark is irrelevant at runtime.-      |  -- pprTrace "VoidTy" (ppr ty) $-        (isZeroBitTy ty)-      = go marks types out_marks-      -- Single rep argument, e.g. Int-      -- Keep mark as-is-      | [_] <- reps-      = go marks types (mark:out_marks)-      -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)-      -- Make up one non-strict mark per runtime argument.-      | otherwise -- TODO: Assert real_reps /= null-      = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks)+      = case reps of+          -- Zero-width argument, mark is irrelevant at runtime.+          [] -> -- pprTrace "VoidTy" (ppr ty) $+                go marks types out_marks+          -- Single rep argument, e.g. Int+          -- Keep mark as-is+          [_] -> go marks types (mark:out_marks)+          -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)+          -- Make up one non-strict mark per runtime argument.+          _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks)       where         reps = typePrimRep ty-        real_reps = filter (not . isVoidRep) $ reps     go [] [] out_marks = reverse out_marks     go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) @@ -304,16 +295,17 @@   ppr FloatSlot       = text "FloatSlot"   ppr (VecSlot n e)   = text "VecSlot" <+> ppr n <+> ppr e -typeSlotTy :: UnaryType -> Maybe SlotTy-typeSlotTy ty = case typePrimRep ty of+repSlotTy :: [PrimRep] -> Maybe SlotTy+repSlotTy reps = case reps of                   [] -> Nothing                   [rep] -> Just (primRepSlot rep)-                  reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)+                  _ -> pprPanic "repSlotTy" (ppr reps)  primRepSlot :: PrimRep -> SlotTy-primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")-primRepSlot LiftedRep   = PtrLiftedSlot-primRepSlot UnliftedRep = PtrUnliftedSlot+primRepSlot (BoxedRep mlev) = case mlev of+  Nothing       -> panic "primRepSlot: levity polymorphic BoxedRep"+  Just Lifted   -> PtrLiftedSlot+  Just Unlifted -> PtrUnliftedSlot primRepSlot IntRep      = WordSlot primRepSlot Int8Rep     = WordSlot primRepSlot Int16Rep    = WordSlot@@ -330,8 +322,8 @@ primRepSlot (VecRep n e) = VecSlot n e  slotPrimRep :: SlotTy -> PrimRep-slotPrimRep PtrLiftedSlot   = LiftedRep-slotPrimRep PtrUnliftedSlot = UnliftedRep+slotPrimRep PtrLiftedSlot   = BoxedRep (Just Lifted)+slotPrimRep PtrUnliftedSlot = BoxedRep (Just Unlifted) slotPrimRep Word64Slot      = Word64Rep slotPrimRep WordSlot        = WordRep slotPrimRep DoubleSlot      = DoubleRep@@ -392,8 +384,7 @@ enumerates all the possibilities.  data PrimRep-  = VoidRep       -- See Note [VoidRep]-  | LiftedRep     -- ^ Lifted pointer+  = LiftedRep     -- ^ Lifted pointer   | UnliftedRep   -- ^ Unlifted pointer   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value@@ -442,19 +433,38 @@  Note [VoidRep] ~~~~~~~~~~~~~~-PrimRep contains a constructor VoidRep, while RuntimeRep does-not. Yet representations are often characterised by a list of PrimReps,-where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].)+PrimRep is used to denote one primitive representation.+Because of unboxed tuples and sums, the representation of a value+in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) -However, after the unariser, all identifiers have exactly one PrimRep, but-void arguments still exist. Thus, PrimRep includes VoidRep to describe these-binders. Perhaps post-unariser representations (which need VoidRep) should be-a different type than pre-unariser representations (which use a list and do-not need VoidRep), but we have what we have.+For example:+    typePrimRep Int#             = [IntRep]+    typePrimRep Int              = [LiftedRep]+    typePrimRep (# Int#, Int# #) = [IntRep,IntRep]+    typePrimRep (# #)            = []+    typePrimRep (State# s)       = [] -RuntimeRep instead uses TupleRep '[] to denote a void argument. When-converting a TupleRep '[] into a list of PrimReps, we get an empty list.+After the unariser, all identifiers have at most one PrimRep+(that is, the [PrimRep] for each identifier is empty or a singleton list).+More precisely: typePrimRep1 will succeed (not crash) on every binder+and argument type.+(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) +Thus, we have++1. typePrimRep :: Type -> [PrimRep]+   which returns the list++2. typePrimRepU :: Type -> PrimRep+   which asserts that the type has exactly one PrimRep and returns it++3. typePrimRep1 :: Type -> PrimOrVoidRep+   data PrimOrVoidRep = VoidRep | NVRep PrimRep+   which asserts that the type either has exactly one PrimRep or is void.++Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1,+which have analogous preconditions.+ Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep].@@ -525,7 +535,7 @@ GHC.Builtin.Types and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted list as the one argument to the extracted function. The extracted function is defined as prim_rep_fun within tupleRepDataCon in GHC.Builtin.Types. It takes one argument, decomposes-the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep+the promoted list (with extractPromotedList), and then recurses back to runtimeRepPrimRep to process the LiftedRep and WordRep, concatenating the results.  -}@@ -547,17 +557,22 @@ typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;+-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep]-typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep+typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of   []    -> VoidRep-  [rep] -> rep+  [rep] -> NVRep rep   _     -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep+typePrimRepU ty = case typePrimRep ty of+  [rep] -> rep+  _     -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty))+ -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep]@@ -568,15 +583,6 @@   where     res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or--- one 'PrimRep' output--- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]-tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep-tyConPrimRep1 tc = case tyConPrimRep tc of-  []    -> VoidRep-  [rep] -> rep-  _     -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))- -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep]@@ -604,8 +610,6 @@ -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation.------ The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty   | Just rr_ty' <- coreView rr_ty@@ -618,8 +622,7 @@  -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep].--- The @[PrimRep]@ is the final runtime representation /after/ unarisation--- and does not contain VoidRep.+-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep]@@ -635,9 +638,10 @@ -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of-  VoidRep       -> zeroBitRepTy-  LiftedRep     -> liftedRepTy-  UnliftedRep   -> unliftedRepTy+  BoxedRep mlev -> case mlev of+    Nothing       -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep"+    Just Lifted   -> liftedRepTy+    Just Unlifted -> unliftedRepTy   IntRep        -> intRepDataConTy   Int8Rep       -> int8RepDataConTy   Int16Rep      -> int16RepDataConTy@@ -689,9 +693,12 @@ -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty-  | [LiftedRep] <- typePrimRep ty+  -- Currently ghc has no unlifted functions.+  | definitelyUnliftedType ty+  = 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/SaneDouble.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++-- | Double datatype with saner instances+module GHC.Types.SaneDouble+  ( SaneDouble (..)+  )+where++import GHC.Prelude+import GHC.Utils.Binary+import GHC.Float (castDoubleToWord64, castWord64ToDouble)++-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'+-- that becomes a 'NaN', see instances for details on sanity.+newtype SaneDouble = SaneDouble+  { unSaneDouble :: Double+  }+  deriving (Fractional, Num)++instance Eq SaneDouble where+    (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)++instance Ord SaneDouble where+    compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)+        where fromNaN z | isNaN z = Nothing+                        | otherwise = Just z++instance Show SaneDouble where+    show (SaneDouble x) = show x++-- we need to preserve NaN and infinities, unfortunately the Binary instance for+-- Double does not do this+instance Binary SaneDouble where+  put_ bh (SaneDouble d)+    | isNaN d               = putByte bh 1+    | isInfinite d && d > 0 = putByte bh 2+    | isInfinite d && d < 0 = putByte bh 3+    | isNegativeZero d      = putByte bh 4+    | otherwise             = putByte bh 5 >> put_ bh (castDoubleToWord64 d)+  get bh = getByte bh >>= \case+    1 -> pure $ SaneDouble (0    / 0)+    2 -> pure $ SaneDouble (1    / 0)+    3 -> pure $ SaneDouble ((-1) / 0)+    4 -> pure $ SaneDouble (-0)+    5 -> SaneDouble . castWord64ToDouble <$> get bh+    n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)+
compiler/GHC/Types/SourceFile.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE PatternSynonyms #-}+ module GHC.Types.SourceFile-   ( HscSource(..)+   ( HscSource(HsBootFile, HsigFile, ..)+   , HsBootOrSig(..)    , hscSourceToIsBoot    , isHsBootOrSig-   , isHsigFile+   , isHsBootFile, isHsigFile    , hscSourceString    ) where@@ -10,46 +13,63 @@ import GHC.Prelude import GHC.Utils.Binary import GHC.Unit.Types+import Control.DeepSeq --- Note [HscSource types]--- ~~~~~~~~~~~~~~~~~~~~~~--- There are three types of source file for Haskell code:------      * HsSrcFile is an ordinary hs file which contains code,------      * HsBootFile is an hs-boot file, which is used to break---        recursive module imports (there will always be an---        HsSrcFile associated with it), and------      * HsigFile is an hsig file, which contains only type---        signatures and is used to specify signatures for---        modules.------ Syntactically, hs-boot files and hsig files are quite similar: they--- only include type signatures and must be associated with an--- actual HsSrcFile.  isHsBootOrSig allows us to abstract over code--- which is indifferent to which.  However, there are some important--- differences, mostly owing to the fact that hsigs are proper--- modules (you `import Sig` directly) whereas HsBootFiles are--- temporary placeholders (you `import {-# SOURCE #-} Mod).--- When we finish compiling the true implementation of an hs-boot,--- we replace the HomeModInfo with the real HsSrcFile.  An HsigFile, on the--- other hand, is never replaced (in particular, we *cannot* use the--- HomeModInfo of the original HsSrcFile backing the signature, since it--- will export too many symbols.)------ Additionally, while HsSrcFile is the only Haskell file--- which has *code*, we do generate .o files for HsigFile, because--- this is how the recompilation checker figures out if a file--- needs to be recompiled.  These are fake object files which--- should NOT be linked against.+{- Note [HscSource types]+~~~~~~~~~~~~~~~~~~~~~~~~~+There are three types of source file for Haskell code: +     * HsSrcFile is an ordinary hs file which contains code,++     * HsBootFile is an hs-boot file, which is used to break+       recursive module imports (there will always be an+       HsSrcFile associated with it), and++     * HsigFile is an hsig file, which contains only type+       signatures and is used to specify signatures for+       modules.++Syntactically, hs-boot files and hsig files are quite similar: they+only include type signatures and must be associated with an+actual HsSrcFile.  isHsBootOrSig allows us to abstract over code+which is indifferent to which.  However, there are some important+differences, mostly owing to the fact that hsigs are proper+modules (you `import Sig` directly) whereas HsBootFiles are+temporary placeholders (you `import {-# SOURCE #-} Mod).+When we finish compiling the true implementation of an hs-boot,+we replace the HomeModInfo with the real HsSrcFile.  An HsigFile, on the+other hand, is never replaced (in particular, we *cannot* use the+HomeModInfo of the original HsSrcFile backing the signature, since it+will export too many symbols.)++Additionally, while HsSrcFile is the only Haskell file+which has *code*, we do generate .o files for HsigFile, because+this is how the recompilation checker figures out if a file+needs to be recompiled.  These are fake object files which+should NOT be linked against.+-}++data HsBootOrSig+  = HsBoot -- ^ .hs-boot file+  | Hsig   -- ^ .hsig file+   deriving (Eq, Ord, Show)++instance NFData HsBootOrSig where+  rnf HsBoot = ()+  rnf Hsig = ()+ data HscSource-   = HsSrcFile  -- ^ .hs file-   | HsBootFile -- ^ .hs-boot file-   | HsigFile   -- ^ .hsig file+   -- | .hs file+   = HsSrcFile+   -- | .hs-boot or .hsig file+   | HsBootOrSig !HsBootOrSig    deriving (Eq, Ord, Show) +{-# COMPLETE HsSrcFile, HsBootFile, HsigFile #-}+pattern HsBootFile, HsigFile :: HscSource+pattern HsBootFile = HsBootOrSig HsBoot+pattern HsigFile   = HsBootOrSig Hsig+ -- | Tests if an 'HscSource' is a boot file, primarily for constructing elements -- of 'BuildModule'. We conflate signatures and modules because they are bound -- in the same namespace; only boot interfaces can be disambiguated with@@ -58,6 +78,10 @@ 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     put_ bh HsBootFile = putByte bh 1@@ -70,15 +94,18 @@             _ -> return HsigFile  hscSourceString :: HscSource -> String-hscSourceString HsSrcFile   = ""-hscSourceString HsBootFile  = "[boot]"-hscSourceString HsigFile    = "[sig]"+hscSourceString HsSrcFile  = ""+hscSourceString HsBootFile = "[boot]"+hscSourceString HsigFile   = "[sig]"  -- See Note [HscSource types] isHsBootOrSig :: HscSource -> Bool-isHsBootOrSig HsBootFile = True-isHsBootOrSig HsigFile   = True-isHsBootOrSig _          = False+isHsBootOrSig (HsBootOrSig _) = True+isHsBootOrSig HsSrcFile       = False++isHsBootFile :: HscSource -> Bool+isHsBootFile HsBootFile = True+isHsBootFile _          = False  isHsigFile :: HscSource -> Bool isHsigFile HsigFile = True
compiler/GHC/Types/SourceText.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}  -- | Source text --@@ -38,6 +41,7 @@ import Data.Data import GHC.Real ( Ratio(..) ) import GHC.Types.SrcLoc+import Control.DeepSeq  {- Note [Pragma source text]@@ -95,7 +99,7 @@   -- Note [Literal source text],[Pragma source text] data SourceText-   = SourceText String+   = SourceText FastString    | NoSourceText       -- ^ For when code is generated, e.g. TH,       -- deriving. The pretty printer will then make@@ -103,9 +107,14 @@    deriving (Data, Show, Eq )  instance Outputable SourceText where-  ppr (SourceText s) = text "SourceText" <+> text s+  ppr (SourceText s) = text "SourceText" <+> ftext s   ppr NoSourceText   = text "NoSourceText" +instance NFData SourceText where+    rnf = \case+        SourceText s -> rnf s+        NoSourceText -> ()+ instance Binary SourceText where   put_ bh NoSourceText = putByte bh 0   put_ bh (SourceText s) = do@@ -124,7 +133,7 @@ -- | Special combinator for showing string literals. pprWithSourceText :: SourceText -> SDoc -> SDoc pprWithSourceText NoSourceText     d = d-pprWithSourceText (SourceText src) _ = text src+pprWithSourceText (SourceText src) _ = ftext src  ------------------------------------------------ -- Literals@@ -143,7 +152,7 @@    deriving (Data, Show)  mkIntegralLit :: Integral a => a -> IntegralLit-mkIntegralLit i = IL { il_text = SourceText (show i_integer)+mkIntegralLit i = IL { il_text = SourceText (fsLit $ show i_integer)                      , il_neg = i < 0                      , il_value = i_integer }   where@@ -153,9 +162,9 @@ negateIntegralLit :: IntegralLit -> IntegralLit negateIntegralLit (IL text neg value)   = case text of-      SourceText ('-':src) -> IL (SourceText src)       False    (negate value)-      SourceText      src  -> IL (SourceText ('-':src)) True     (negate value)-      NoSourceText         -> IL NoSourceText          (not neg) (negate value)+      SourceText (unconsFS -> Just ('-',src)) -> IL (SourceText src)                False    (negate value)+      SourceText src                          -> IL (SourceText ('-' `consFS` src)) True     (negate value)+      NoSourceText                            -> IL NoSourceText          (not neg) (negate value)  -- | Fractional Literal --@@ -206,7 +215,7 @@   mkRationalWithExponentBase i e expBase  mkTHFractionalLit :: Rational -> FractionalLit-mkTHFractionalLit r =  FL { fl_text = SourceText (show (realToFrac r::Double))+mkTHFractionalLit r =  FL { fl_text = SourceText (fsLit $ show (realToFrac r::Double))                              -- Converting to a Double here may technically lose                              -- precision (see #15502). We could alternatively                              -- convert to a Rational for the most accuracy, but@@ -222,13 +231,14 @@ negateFractionalLit :: FractionalLit -> FractionalLit negateFractionalLit (FL text neg i e eb)   = case text of-      SourceText ('-':src) -> FL (SourceText src)       False (negate i) e eb-      SourceText      src  -> FL (SourceText ('-':src)) True  (negate i) e eb+      SourceText (unconsFS -> Just ('-',src))+                           -> FL (SourceText src)                False (negate i) e eb+      SourceText      src  -> FL (SourceText ('-' `consFS` src)) True  (negate i) e eb       NoSourceText         -> FL NoSourceText (not neg) (negate i) e eb  -- | The integer should already be negated if it's negative. integralFractionalLit :: Bool -> Integer -> FractionalLit-integralFractionalLit neg i = FL { fl_text = SourceText (show i)+integralFractionalLit neg i = FL { fl_text = SourceText (fsLit $ show i)                                  , fl_neg = neg                                  , fl_signi = i :% 1                                  , fl_exp = 0@@ -238,7 +248,7 @@ mkSourceFractionalLit :: String -> Bool -> Integer -> Integer                       -> FractionalExponentBase                       -> FractionalLit-mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff+mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText $ fsLit str) b (r :% 1) i ff  {- Note [fractional exponent bases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -258,7 +268,7 @@   compare = compare `on` il_value  instance Outputable IntegralLit where-  ppr (IL (SourceText src) _ _) = text src+  ppr (IL (SourceText src) _ _) = ftext src   ppr (IL NoSourceText _ value) = text (show value)  @@ -295,30 +305,17 @@                        { sl_st :: SourceText, -- literal raw source.                                               -- See Note [Literal source text]                          sl_fs :: FastString, -- literal string value-                         sl_tc :: Maybe RealSrcSpan -- Location of+                         sl_tc :: Maybe NoCommentsLocation+                                                    -- Location of                                                     -- possible                                                     -- trailing comma                        -- AZ: if we could have a LocatedA                        -- StringLiteral we would not need sl_tc, but                        -- that would cause import loops.--                       -- AZ:2: sl_tc should be an EpaAnchor, to allow-                       -- editing and reprinting the AST. Need a more-                       -- robust solution.-                        } deriving Data  instance Eq StringLiteral where   (StringLiteral _ a _) == (StringLiteral _ b _) = a == b  instance Outputable StringLiteral where-  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)--instance Binary StringLiteral where-  put_ bh (StringLiteral st fs _) = do-            put_ bh st-            put_ bh fs-  get bh = do-            st <- get bh-            fs <- get bh-            return (StringLiteral st fs Nothing)+  ppr sl = pprWithSourceText (sl_st sl) (doubleQuotes $ ftext $ sl_fs sl)
+ compiler/GHC/Types/SptEntry.hs view
@@ -0,0 +1,16 @@+module GHC.Types.SptEntry+  ( SptEntry(..)+  )+where++import GHC.Types.Var           ( Id )+import GHC.Fingerprint.Type    ( Fingerprint )+import GHC.Utils.Outputable++-- | An entry to be inserted into a module's static pointer table.+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+data SptEntry = SptEntry Id Fingerprint++instance Outputable SptEntry where+  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr+
compiler/GHC/Types/SrcLoc.hs view
@@ -64,6 +64,9 @@         isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan,         containsSpan, isNoSrcSpan, +        -- ** Predicates on RealSrcSpan+        isPointRealSpan,+         -- * StringBuffer locations         BufPos(..),         getBufPos,@@ -106,6 +109,10 @@         mkSrcSpanPs,         combineRealSrcSpans,         psLocatedToLocated,++        -- * Exact print locations+        EpaLocation'(..), NoCommentsLocation, NoComments(..),+        DeltaPos(..), deltaPos, getDeltaLine,     ) where  import GHC.Prelude@@ -216,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]@@ -366,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)@@ -423,16 +433,29 @@   json (RealSrcSpan rss _) = json rss  instance ToJson RealSrcSpan where-  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))-                                     , ("startLine", JSInt srcSpanSLine)-                                     , ("startCol", JSInt srcSpanSCol)-                                     , ("endLine", JSInt srcSpanELine)-                                     , ("endCol", JSInt srcSpanECol)+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)),+                                       ("start", start),+                                       ("end", end)                                      ]+    where start = JSObject [ ("line", JSInt srcSpanSLine),+                             ("column", JSInt srcSpanSCol) ]+          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 getBufSpan (UnhelpfulSpan _) = Strict.Nothing@@ -889,3 +912,70 @@  mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)++-- ---------------------------------------------------------------------+-- The following section contains basic types related to exact printing.+-- See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for+-- details.+-- This is only s subset, to prevent import loops. The balance are in+-- GHC.Parser.Annotation+-- ---------------------------------------------------------------------+++-- | The anchor for an exact print annotation. The Parser inserts the+-- @'EpaSpan'@ variant, giving the exact location of the original item+-- in the parsed source.  This can be replaced by the @'EpaDelta'@+-- version, to provide a position for the item relative to the end of+-- the previous item in the source.  This is useful when editing an+-- AST prior to exact printing the changed one.+-- The EpaDelta also contains the original @'SrcSpan'@ for use by+-- tools wanting to manipulate the AST after converting it using+-- ghc-exactprint' @'makeDeltaAst'@.++data EpaLocation' a = EpaSpan !SrcSpan+                    | EpaDelta !SrcSpan !DeltaPos !a+                    deriving (Data,Eq,Show)++type NoCommentsLocation = EpaLocation' NoComments++data NoComments = NoComments+  deriving (Data,Eq,Ord,Show)++-- | Spacing between output items when exact printing.  It captures+-- the spacing from the current print position on the page to the+-- position required for the thing about to be printed.  This is+-- either on the same line in which case is is simply the number of+-- spaces to emit, or it is some number of lines down, with a given+-- column offset.  The exact printing algorithm keeps track of the+-- column offset pertaining to the current anchor position, so the+-- `deltaColumn` is the additional spaces to add in this case.  See+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for+-- details.+data DeltaPos+  = SameLine { deltaColumn :: !Int }+  | DifferentLine+      { deltaLine   :: !Int, -- ^ deltaLine should always be > 0+        deltaColumn :: !Int+      } deriving (Show,Eq,Ord,Data)++-- | Smart constructor for a 'DeltaPos'. It preserves the invariant+-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.+deltaPos :: Int -> Int -> DeltaPos+deltaPos l c = case l of+  0 -> SameLine c+  _ -> DifferentLine l c++getDeltaLine :: DeltaPos -> Int+getDeltaLine (SameLine _) = 0+getDeltaLine (DifferentLine r _) = r++instance Outputable NoComments where+  ppr NoComments = text "NoComments"++instance (Outputable a) => Outputable (EpaLocation' a) where+  ppr (EpaSpan r) = text "EpaSpan" <+> ppr r+  ppr (EpaDelta s d cs) = text "EpaDelta" <+> ppr s <+> ppr d <+> ppr cs++instance Outputable DeltaPos where+  ppr (SameLine c) = text "SameLine" <+> ppr c+  ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
+ 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,10 +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 @@ -39,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, (<+>))  {- ********************************************************************* *                                                                      *@@ -105,9 +110,11 @@     -- the user.     ProfNote {       profNoteCC    :: CostCentre, -- ^ the cost centre+       profNoteCount :: !Bool,      -- ^ bump the entry count?       profNoteScope :: !Bool       -- ^ scopes over the enclosed expression                                    -- (i.e. not just a tick)+      -- Invariant: the False/False case never happens     }    -- | A "tick" used by HPC to track the execution of each@@ -125,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@@ -153,8 +160,8 @@   -- necessary to enable optimizations.   | SourceNote     { sourceSpan :: RealSrcSpan -- ^ Source covered-    , sourceName :: String      -- ^ Name for source location-                                --   (uses same names as CCs)+    , sourceName :: LexicalFastString  -- ^ Name for source location+                                       --   (uses same names as CCs)     }  deriving instance Eq (GenTickish 'TickishPassCore)@@ -167,7 +174,36 @@ 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, -- and the compiler should preserve the number of counting ticks as@@ -291,13 +327,15 @@ mkNoCount :: GenTickish pass -> GenTickish pass mkNoCount n | not (tickishCounts n)   = n             | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"-mkNoCount n@ProfNote{}                = n {profNoteCount = False}+mkNoCount n@ProfNote{}                = let n' = n {profNoteCount = False}+                                        in assert (profNoteCount n) n' mkNoCount _                           = panic "mkNoCount: Undefined split!"  mkNoScope :: GenTickish pass -> GenTickish pass mkNoScope n | tickishScoped n == NoScope  = n             | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"-mkNoScope n@ProfNote{}                    = n {profNoteScope = False}+mkNoScope n@ProfNote{}                    = let n' = n {profNoteScope = False}+                                            in assert (profNoteCount n) n' mkNoScope _                               = panic "mkNoScope: Undefined split!"  -- | Return @True@ if this source annotation compiles to some backend
compiler/GHC/Types/TyThing.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- | A global typecheckable-thing, essentially anything that has a name. module GHC.Types.TyThing    ( TyThing (..)@@ -15,7 +17,7 @@    , isImplicitTyThing    , tyThingParent_maybe    , tyThingsTyCoVars-   , tyThingAvailInfo+   , tyThingLocalGREs, tyThingGREInfo    , tyThingTyCon    , tyThingCoAxiom    , tyThingDataCon@@ -26,12 +28,14 @@  import GHC.Prelude +import GHC.Types.GREInfo import GHC.Types.Name+import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Types.Avail+import GHC.Types.Unique.Set  import GHC.Core.Class import GHC.Core.DataCon@@ -49,6 +53,11 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Class +import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import Data.List ( intersect )++ {- Note [ATyCon for classes] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -116,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@@ -257,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@@ -276,22 +286,90 @@               Nothing  -> tyCoVarsOfType $ tyConKind tc         ttToVarSet (ACoAxiom _)  = emptyVarSet --- | The Names that a TyThing should bring into scope.  Used to build--- the GlobalRdrEnv for the InteractiveContext.-tyThingAvailInfo :: TyThing -> [AvailInfo]-tyThingAvailInfo (ATyCon t)-   = case tyConClass_maybe t of-        Just c  -> [availTC n ((n : map getName (classMethods c)-                                 ++ map getName (classATs c))) [] ]-             where n = getName c-        Nothing -> [availTC n (n : map getName dcs) flds]-             where n    = getName t-                   dcs  = tyConDataCons t-                   flds = tyConFieldLabels t-tyThingAvailInfo (AConLike (PatSynCon p))-  = avail (getName p) : map availField (patSynFieldLabels p)-tyThingAvailInfo t-   = [avail (getName t)]+-- | The 'GlobalRdrElt's that a 'TyThing' should bring into scope.+-- Used to build the 'GlobalRdrEnv' for the InteractiveContext.+tyThingLocalGREs :: TyThing -> [GlobalRdrElt]+tyThingLocalGREs ty_thing =+  case ty_thing of+    ATyCon t+      | Just c <- tyConClass_maybe t+      -> myself NoParent+       : (  map (mkLocalVanillaGRE (ParentIs $ className c) . getName) (classMethods c)+         ++ map tc_GRE (classATs c) )+      | otherwise+      -> let dcs = tyConDataCons t+             par = ParentIs $ tyConName t+             mk_nm = DataConName . dataConName+         in myself NoParent+          : map (dc_GRE par) dcs+            +++            mkLocalFieldGREs par+               [ (mk_nm dc, con_info)+               | dc <- dcs+               , let con_info = conLikeConInfo (RealDataCon dc) ]+    AConLike con ->+      let (par, cons_flds) = case con of+            PatSynCon {} ->+              (NoParent, [(conLikeConLikeName con, conLikeConInfo con)])+              -- NB: NoParent for local pattern synonyms, as per+              -- Note [Parents] in GHC.Types.Name.Reader.+            RealDataCon dc1 ->+              (ParentIs $ tyConName $ dataConTyCon dc1+              , [ (DataConName $ dataConName $ dc, ConInfo conInfo (ConHasRecordFields (fld :| flds)))+                | dc <- tyConDataCons $ dataConTyCon dc1+                -- Go through all the data constructors of the parent TyCon,+                -- to ensure that all the record fields have the correct set+                -- of parent data constructors. See #23546.+                , let con_info = conLikeConInfo (RealDataCon dc)+                , ConInfo conInfo (ConHasRecordFields flds0) <- [con_info]+                , let flds1 = NE.toList flds0 `intersect` dataConFieldLabels dc+                , fld:flds <- [flds1]+                ])+      in myself par : mkLocalFieldGREs par cons_flds+    AnId id+      | RecSelId { sel_tycon = RecSelData tc } <- idDetails id+      -> [ myself (ParentIs $ tyConName tc) ]+      -- Fallback to NoParent for PatSyn record selectors,+      -- as per Note [Parents] in GHC.Types.Name.Reader.+    _ -> [ myself NoParent ]+  where+    tc_GRE :: TyCon -> GlobalRdrElt+    tc_GRE at = mkLocalTyConGRE+                     (fmap tyConName $ tyConFlavour at)+                     (tyConName at)+    dc_GRE :: Parent -> DataCon -> GlobalRdrElt+    dc_GRE par dc =+      let con_info = conLikeConInfo (RealDataCon dc)+      in mkLocalConLikeGRE par (DataConName $ dataConName dc, con_info)+    myself :: Parent -> GlobalRdrElt+    myself p = mkLocalGRE (tyThingGREInfo ty_thing) p (getName ty_thing)++-- | Obtain information pertinent to the renamer about a particular 'TyThing'.+--+-- This extracts out renamer information from typechecker information.+tyThingGREInfo :: TyThing -> GREInfo+tyThingGREInfo = \case+  AConLike con -> IAmConLike $ conLikeConInfo con+  AnId id -> case idDetails id of+    RecSelId { sel_tycon = parent, sel_fieldLabel = fl } ->+      let relevant_cons = case parent of+            RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps)+            RecSelData   tc ->+              let dcs = map RealDataCon $ tyConDataCons tc in+              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+       in IAmRecField $+            RecFieldInfo+              { recFieldLabel = fl+              , recFieldCons  = relevant_cons }+    _ -> Vanilla+  ATyCon tc ->+    IAmTyCon (fmap tyConName $ tyConFlavour tc)+  _ -> Vanilla  -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon
+ compiler/GHC/Types/TyThing/Ppr.hs view
@@ -0,0 +1,204 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing TyThings+--+-- (c) The GHC Team 2005+--+-----------------------------------------------------------------------------+++module GHC.Types.TyThing.Ppr (+        pprTyThing,+        pprTyThingInContext,+        pprTyThingLoc,+        pprTyThingInContextLoc,+        pprTyThingHdr,+        pprFamInst+  ) where++import GHC.Prelude++import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )+import GHC.Types.Name++import GHC.Core.Type    ( ForAllTyFlag(..), mkTyVarBinders )+import GHC.Core.Coercion.Axiom ( coAxiomTyCon )+import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp )++import GHC.Iface.Decl   ( tyThingToIfaceDecl )+import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+                        , showToHeader, pprIfaceDecl )++import GHC.Utils.Outputable++import Data.Maybe ( isJust )++-- -----------------------------------------------------------------------------+-- Pretty-printing entities that we get from the GHC API++{- Note [Pretty printing via Iface syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our general plan for pretty-printing+  - Types+  - TyCons+  - Classes+  - Pattern synonyms+  ...etc...++is to convert them to Iface syntax, and pretty-print that. For example+  - pprType converts a Type to an IfaceType, and pretty prints that.+  - pprTyThing converts the TyThing to an IfaceDecl,+    and pretty prints that.++So Iface syntax plays a dual role:+  - it's the internal version of an interface files+  - it's used for pretty-printing++Why do this?++* A significant reason is that we need to be able+  to pretty-print Iface syntax (to display Foo.hi), and it was a+  pain to duplicate masses of pretty-printing goop, esp for+  Type and IfaceType.++* When pretty-printing (a type, say), we want to tidy (with+  tidyType) to avoids having (forall a a. blah) where the two+  a's have different uniques.++  Alas, for type constructors, TyCon, tidying does not work well,+  because a TyCon includes DataCons which include Types, which mention+  TyCons. And tidying can't tidy a mutually recursive data structure+  graph, only trees.++* Interface files contains fast-strings, not uniques, so the very same+  tidying must take place when we convert to IfaceDecl. E.g.+  GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,+  Class etc) to an IfaceDecl.++  Bottom line: IfaceDecls are already 'tidy', so it's straightforward+  to print them.++* An alternative I once explored was to ensure that TyCons get type+  variables with distinct print-names. That's ok for type variables+  but less easy for kind variables. Processing data type declarations+  is already so complicated that I don't think it's sensible to add+  the extra requirement that it generates only "pretty" types and+  kinds.++Consequences:++- Iface syntax (and IfaceType) must contain enough information to+  print nicely.  Hence, for example, the IfaceAppArgs type, which+  allows us to suppress invisible kind arguments in types+  (see Note [Suppressing invisible arguments] in GHC.Iface.Type)++- In a few places we have info that is used only for pretty-printing,+  and is totally ignored when turning Iface syntax back into Core+  (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon+  stores a [IfaceAxBranch] that is used only for pretty-printing.++- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type++See #7730, #8776 for details   -}++--------------------+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.+pprFamInst :: FamInst -> SDoc+--  * For data instances we go via pprTyThing of the representational TyCon,+--    because there is already much cleverness associated with printing+--    data type declarations that I don't want to duplicate+--  * For type instances we print directly here; there is no TyCon+--    to give to pprTyThing+--+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes++pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })+  = pprTyThingInContextLoc (ATyCon rep_tc)++pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })+  = showWithLoc (pprDefinedAt (getName axiom)) $+    hang (text "type instance"+            <+> pprUserForAll (mkTyVarBinders Specified tvs)+                -- See Note [Printing foralls in type family instances]+                -- in GHC.Iface.Type+            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+       2 (equals <+> ppr rhs)++----------------------------+-- | Pretty-prints a 'TyThing' with its defining location.+pprTyThingLoc :: TyThing -> SDoc+pprTyThingLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThing showToHeader tyThing)++-- | Pretty-prints the 'TyThing' header. For functions and data constructors+-- the function is equivalent to 'pprTyThing' but for type constructors+-- and classes it prints only the header part of the declaration.+pprTyThingHdr :: TyThing -> SDoc+pprTyThingHdr = pprTyThing showToHeader++-- | Pretty-prints a 'TyThing' in context: that is, if the entity+-- is a data constructor, record selector, or class method, then+-- the entity's parent declaration is pretty-printed with irrelevant+-- parts omitted.+pprTyThingInContext :: ShowSub -> TyThing -> SDoc+pprTyThingInContext show_sub thing+  = case parents thing of+      -- If there are no parents print everything.+      [] -> print_it Nothing thing+      -- If `thing` has a parent, print the parent and only its child `thing`+      thing':rest -> let subs = map getOccName (thing:rest)+                         filt = (`elem` subs)+                     in print_it (Just filt) thing'+  where+    parents = go+      where+        go thing =+          case tyThingParent_maybe thing of+            Just parent -> parent : go parent+            Nothing     -> []++    print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc+    print_it mb_filt thing =+      pprTyThing (show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) thing++-- | Like 'pprTyThingInContext', but adds the defining location.+pprTyThingInContextLoc :: TyThing -> SDoc+pprTyThingInContextLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThingInContext showToHeader tyThing)++-- | Pretty-prints a 'TyThing'.+pprTyThing :: ShowSub -> TyThing -> SDoc+-- We pretty-print 'TyThing' via 'IfaceDecl'+-- See Note [Pretty printing via Iface syntax]+pprTyThing ss ty_thing+  = sdocOption sdocLinearTypes $ \show_linear_types ->+      pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)+  where+    ss' = case ss_how_much ss of+      ShowHeader (AltPpr Nothing)    -> ss { ss_how_much = ShowHeader ppr' }+      ShowSome filt (AltPpr Nothing) -> ss { ss_how_much = ShowSome filt ppr' }+      _                   -> ss++    ppr' = AltPpr $ ppr_bndr $ getName ty_thing++    ppr_bndr :: Name -> Maybe (OccName -> SDoc)+    ppr_bndr name+      | isBuiltInSyntax name || isJust (namePun_maybe name)+         = Nothing+      | otherwise+         = case nameModule_maybe name of+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->+               pprModulePrefix sty mod Nothing occ <> ppr occ+             Nothing  -> warnPprTrace True "pprTyThing" (ppr name) Nothing+             -- Nothing is unexpected here; TyThings have External names++showWithLoc :: SDoc -> SDoc -> SDoc+showWithLoc loc doc+    = hang doc 2 (char '\t' <> comment <+> loc)+                -- The tab tries to make them line up a bit+  where+    comment = text "--"
+ compiler/GHC/Types/TyThing/Ppr.hs-boot view
@@ -0,0 +1,11 @@+module GHC.Types.TyThing.Ppr (+        pprTyThing,+        pprTyThingInContext+  ) where++import GHC.Iface.Type       ( ShowSub )+import GHC.Types.TyThing    ( TyThing )+import GHC.Utils.Outputable ( SDoc )++pprTyThing :: ShowSub -> TyThing -> SDoc+pprTyThingInContext :: ShowSub -> TyThing -> SDoc
compiler/GHC/Types/TypeEnv.hs view
@@ -93,4 +93,3 @@  plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv plusTypeEnv env1 env2 = plusNameEnv env1 env2-
compiler/GHC/Types/Unique.hs view
@@ -18,7 +18,7 @@ -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns, MagicHash #-}+{-# LANGUAGE MagicHash #-}  module GHC.Types.Unique (         -- * Main data types@@ -205,6 +205,9 @@ instance Uniquable Int where   getUnique i = mkUniqueIntGrimily i +instance Uniquable Word64 where+  getUnique i = mkUniqueGrimily i+ instance Uniquable ModuleName where   getUnique (ModuleName nm) = getUnique nm @@ -243,12 +246,17 @@ -- is to get ABI compatible binaries given the same inputs and environment. -- The motivation behind that is that if the ABI doesn't change the -- binaries can be safely reused.--- Note that this is weaker than bit-for-bit identical binaries and getting--- bit-for-bit identical binaries is not a goal for now.--- This means that we don't care about nondeterminism that happens after--- the interface files are created, in particular we don't care about--- register allocation and code generation.--- To track progress on bit-for-bit determinism see #12262.+--+-- Besides ABI/interface determinism, we also guarantee bit-for-bit identical+-- binaries (when -fobject-determinism is given), also known as object+-- determinism (#12935)+--+-- To achieve this, we must take care to non-determinism in the code+-- generation, and, in particular, guarantee that the existing uniques are+-- renamed deterministically and new ones are produced deterministically too.+-- The overview of object determinism is given by Note [Object determinism].+-- References to this note identify code where the unique determinism may+-- impact object determinism more specifically.  eqUnique :: Unique -> Unique -> Bool eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2@@ -294,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/DFM.hs view
@@ -41,11 +41,12 @@         alterUDFM,         mapUDFM,         mapMaybeUDFM,+        mapMUDFM,         plusUDFM,-        plusUDFM_C,+        plusUDFM_C, plusUDFM_CK,         lookupUDFM, lookupUDFM_Directly,         elemUDFM,-        foldUDFM,+        foldUDFM, foldWithKeyUDFM,         eltsUDFM,         filterUDFM, filterUDFM_Directly,         isNullUDFM,@@ -55,6 +56,7 @@         equalKeysUDFM,         minusUDFM,         listToUDFM, listToUDFM_Directly,+        listToUDFM_C_Directly,         udfmMinusUFM, ufmMinusUDFM,         partitionUDFM,         udfmRestrictKeys,@@ -94,7 +96,7 @@ -- order then `udfmToList` returns them in deterministic order. -- -- There is an implementation cost: each element is given a serial number--- as it is added, and `udfmToList` sorts it's result by this serial+-- as it is added, and `udfmToList` sorts its result by this serial -- number. So you should only use `UniqDFM` if you need the deterministic -- property. --@@ -212,14 +214,23 @@  addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)+{-# INLINEABLE addListToUDFM #-}  addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)+{-# INLINEABLE addListToUDFM_Directly #-}  addListToUDFM_Directly_C   :: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)+{-# INLINEABLE addListToUDFM_Directly_C #-} +-- | Like 'addListToUDFM_Directly_C' but also passes the unique key to the combine function+addListToUDFM_Directly_CK+  :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt+addListToUDFM_Directly_CK f = foldl' (\m (k, v) -> addToUDFM_C_Directly (f k) m k v)+{-# INLINEABLE addListToUDFM_Directly_CK #-}+ delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i @@ -230,6 +241,15 @@   | i > j = insertUDFMIntoLeft_C f udfml udfmr   | otherwise = insertUDFMIntoLeft_C f udfmr udfml +-- | Like 'plusUDFM_C' but the combine function also receives the unique key+plusUDFM_CK :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt+plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j)+  -- we will use the upper bound on the tag as a proxy for the set size,+  -- to insert the smaller one into the bigger one+  | i > j = insertUDFMIntoLeft_CK f udfml udfmr+  | otherwise = insertUDFMIntoLeft_CK f udfmr udfml++ -- Note [Overflow on plusUDFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- There are multiple ways of implementing plusUDFM.@@ -278,6 +298,12 @@ insertUDFMIntoLeft_C f udfml udfmr =   addListToUDFM_Directly_C f udfml $ udfmToList udfmr +-- | Like 'insertUDFMIntoLeft_C', but the merge function also receives the unique key+insertUDFMIntoLeft_CK+  :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt+insertUDFMIntoLeft_CK f udfml udfmr =+  addListToUDFM_Directly_CK f udfml $ udfmToList udfmr+ lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m @@ -294,6 +320,12 @@ -- This INLINE prevents a regression in !10568 foldUDFM k z m = foldr k z (eltsUDFM m) +-- | Like 'foldUDFM' but the function also receives a key+foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a+{-# INLINE foldWithKeyUDFM #-}+-- This INLINE was copied from foldUDFM+foldWithKeyUDFM k z m = foldr (uncurry k) z (udfmToList m)+ -- | Performs a nondeterministic strict fold over the UniqDFM. -- It's O(n), same as the corresponding function on `UniqFM`. -- If you use this please provide a justification why it doesn't introduce@@ -393,6 +425,9 @@ listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM +listToUDFM_C_Directly :: (elt -> elt -> elt) -> [(Unique, elt)] -> UniqDFM key elt+listToUDFM_C_Directly f = foldl' (\m (u, v) -> addToUDFM_C_Directly f m u v) emptyUDFM+ -- | Apply a function to a particular element adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i@@ -425,6 +460,13 @@ -- Critical this is strict map, otherwise you get a big space leak when reloading -- in GHCi because all old ModDetails are retained (see pruneHomePackageTable). -- Modify with care.++{-# INLINEABLE mapMUDFM #-}+-- | 'mapM' for a 'UniqDFM'.+mapMUDFM :: Monad m => (elt1 -> m elt2) -> UniqDFM key elt1 -> m (UniqDFM key elt2)+mapMUDFM f (UDFM m i) = do+  m' <- traverse (traverse f) m+  return $ UDFM m' i  mapMaybeUDFM :: forall elt1 elt2 key.                 (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
+ compiler/GHC/Types/Unique/DSM.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE UnboxedTuples, PatternSynonyms, DerivingVia #-}+module GHC.Types.Unique.DSM+  (+  -- * Threading a deterministic supply+    DUniqSupply+  , UniqDSM(UDSM)+  , DUniqResult+  , pattern DUniqResult++  -- ** UniqDSM and DUniqSupply operations+  , getUniqueDSM+  , runUniqueDSM+  , takeUniqueFromDSupply+  , initDUniqSupply++  -- ** Tag operations+  , newTagDUniqSupply+  , getTagDUniqSupply++  -- * A transfomer threading a deterministic supply+  , UniqDSMT(UDSMT)++  -- ** UniqDSMT operations+  , runUDSMT+  , withDUS+  , hoistUDSMT+  , liftUDSMT++  -- ** Tags+  , setTagUDSMT++  -- * Monad class for deterministic supply threading+  , MonadGetUnique(..)+  , MonadUniqDSM(..)++  )+  where++import GHC.Exts (oneShot)+import GHC.Prelude+import GHC.Word+import Control.Monad.Fix+import GHC.Types.Unique+import qualified GHC.Utils.Monad.State.Strict as Strict+import qualified GHC.Types.Unique.Supply as USM+import Control.Monad.IO.Class++{-+Note [Deterministic Uniques in the CG]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC produces fully deterministic object code. To achieve this, there is a key+pass (detRenameCmmGroup) which renames all non-deterministic uniques in+the Cmm code right after StgToCmm. See Note [Object determinism] for the big+picture and some details.++The code generation pipeline that processes this renamed, deterministic, Cmm,+however, may still need to generate new uniques. If we were to resort to the+non-deterministic unique supply used in the rest of the compiler, our renaming+efforts would be for naught.++Therefore, after having renamed Cmm deterministically, we must ensure that all+uniques created by the code generation pipeline use a deterministic source of uniques.+Most often, this means don't use `UniqSM` in the Cmm passes, use `UniqDSM`:++`UniqDSM` is a pure state monad with an incrementing counter from which we+source new uniques. Unlike `UniqSM`, there's no way to `split` the supply, but+it turns out this was rarely really needed for code generation and migrating+from UniqSM to UniqDSM was easy.++Secondly, the `DUniqSupply` used to run a `UniqDSM` must be threaded through+all passes to guarantee uniques in different passes are unique amongst them+altogether.+Specifically, the same `DUniqSupply` must be threaded through the CG Streaming+pipeline, starting with Driver.Main calling `StgToCmm.codeGen`, `cmmPipeline`,+`cmmToRawCmm`, and `codeOutput` in sequence.++To thread resources through the `Stream` abstraction, we use the `UniqDSMT`+transformer on top of `IO` as the Monad underlying the Stream. `UniqDSMT` will+thread the `DUniqSupply` through every pass applied to the `Stream`, for every+element. We use @type CgStream = Stream (UniqDSMT IO)@ for the Stream used in+code generation which that carries through the deterministic unique supply.++Unlike non-deterministic unique supplies which can be split into supplies using+different tags, or where a new supply with a new tag can be brought from the+void, a `DUniqSupply` needs to be sampled iteratively. To use a different tag+during a specific pass (to more easily identify uniques created in it), the tag+should be manually set and then reset on the unique supply. There's also the+auxiliary `setTagUDSMT` which sets the tag for all uniques supplied in the given+action, and resets it implicitly.++See also Note [Object determinism] in GHC.StgToCmm+-}++-- See Note [Deterministic Uniques in the CG]+newtype DUniqSupply = DUS Word64 -- supply uniques iteratively+type DUniqResult result = (# result, DUniqSupply #)++pattern DUniqResult :: a -> DUniqSupply -> (# a, DUniqSupply #)+pattern DUniqResult x y = (# x, y #)+{-# COMPLETE DUniqResult #-}++-- | A monad which just gives the ability to obtain 'Unique's deterministically.+-- There's no splitting.+newtype UniqDSM result = UDSM' { unUDSM :: DUniqSupply -> DUniqResult result }+  deriving (Functor, Applicative, Monad) via (Strict.State DUniqSupply)++instance MonadFix UniqDSM where+  mfix m = UDSM (\us0 -> let (r,us1) = runUniqueDSM us0 (m r) in DUniqResult r us1)++-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern UDSM :: (DUniqSupply -> DUniqResult a) -> UniqDSM a+pattern UDSM m <- UDSM' m+  where+    UDSM m = UDSM' (oneShot $ \s -> m s)+{-# COMPLETE UDSM #-}++getUniqueDSM :: UniqDSM Unique+getUniqueDSM = UDSM (\(DUS us0) -> DUniqResult (mkUniqueGrimily us0) (DUS $ us0+1))++takeUniqueFromDSupply :: DUniqSupply -> (Unique, DUniqSupply)+takeUniqueFromDSupply d =+  case unUDSM getUniqueDSM d of+    DUniqResult x y -> (x, y)++-- | Initialize a deterministic unique supply with the given Tag and initial unique.+initDUniqSupply :: Char -> Word64 -> DUniqSupply+initDUniqSupply c firstUniq =+  let !tag = mkTag c+  in DUS (tag .|. firstUniq)++runUniqueDSM :: DUniqSupply -> UniqDSM a -> (a, DUniqSupply)+runUniqueDSM ds (UDSM f) =+  case f ds of+    DUniqResult uq us -> (uq, us)++-- | Set the tag of uniques generated from this deterministic unique supply+newTagDUniqSupply :: Char -> DUniqSupply -> DUniqSupply+newTagDUniqSupply c (DUS w) = DUS $ getKey $ newTagUnique (mkUniqueGrimily w) c++-- | Get the tag uniques generated from this deterministic unique supply would have+getTagDUniqSupply :: DUniqSupply -> Char+getTagDUniqSupply (DUS w) = fst $ unpkUnique (mkUniqueGrimily w)++-- | Get a unique from a monad that can access a unique supply.+--+-- Crucially, because 'MonadGetUnique' doesn't allow you to get the+-- 'UniqSupply' (unlike 'MonadUnique'), an instance such as 'UniqDSM' can use a+-- deterministic unique supply to return deterministic uniques without allowing+-- for the 'UniqSupply' to be shared.+class Monad m => MonadGetUnique m where+  getUniqueM :: m Unique++instance MonadGetUnique UniqDSM where+  getUniqueM = getUniqueDSM++-- non deterministic instance+instance MonadGetUnique USM.UniqSM where+  getUniqueM = USM.getUniqueM++--------------------------------------------------------------------------------+-- UniqDSMT+--------------------------------------------------------------------------------++-- | Transformer version of 'UniqDSM' to use when threading a deterministic+-- uniq supply over a Monad. Specifically, it is used in the `Stream` of Cmm+-- decls.+newtype UniqDSMT m result = UDSMT' (DUniqSupply -> m (result, DUniqSupply))+  deriving (Functor)++-- Similar to GHC.Utils.Monad.State.Strict, using Note [The one-shot state monad trick]+-- Using the one-shot trick is necessary for performance.+-- Using transfomer's strict `StateT` regressed some performance tests in 1-2%.+-- The one-shot trick here fixes those regressions.++pattern UDSMT :: (DUniqSupply -> m (result, DUniqSupply)) -> UniqDSMT m result+pattern UDSMT m <- UDSMT' m+  where+    UDSMT m = UDSMT' (oneShot $ \s -> m s)+{-# COMPLETE UDSMT #-}++instance Monad m => Applicative (UniqDSMT m) where+  pure x = UDSMT $ \s -> pure (x, s)+  UDSMT f <*> UDSMT x = UDSMT $ \s0 -> do+    (f', s1) <- f s0+    (x', s2) <- x s1+    pure (f' x', s2)++instance Monad m => Monad (UniqDSMT m) where+  UDSMT x >>= f = UDSMT $ \s0 -> do+    (x', s1) <- x s0+    case f x' of UDSMT y -> y s1++instance MonadIO m => MonadIO (UniqDSMT m) where+  liftIO x = UDSMT $ \s -> (,s) <$> liftIO x++instance Monad m => MonadGetUnique (UniqDSMT m) where+  getUniqueM = UDSMT $ \us -> do+    let (u, us') = takeUniqueFromDSupply us+    return (u, us')++-- | Set the tag of the running @UniqDSMT@ supply to the given tag and run an action with it.+-- All uniques produced in the given action will use this tag, until the tag is changed+-- again.+setTagUDSMT :: Monad m => Char {-^ Tag -} -> UniqDSMT m a -> UniqDSMT m a+setTagUDSMT tag (UDSMT act) = UDSMT $ \us -> do+  let origtag = getTagDUniqSupply us+      new_us  = newTagDUniqSupply tag us+  (a, us') <- act new_us+  let us'_origtag = newTagDUniqSupply origtag us'+      -- restore original tag+  return (a, us'_origtag)++-- | Like 'runUniqueDSM' but for 'UniqDSMT'+runUDSMT :: DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply)+runUDSMT dus (UDSMT st) = st dus++-- | Lift an IO action that depends on, and threads through, a unique supply+-- into UniqDSMT IO.+withDUS :: (DUniqSupply -> IO (a, DUniqSupply)) -> UniqDSMT IO a+withDUS f = UDSMT $ \us -> do+  (a, us') <- liftIO (f us)+  return (a, us')++-- | Change the monad underyling an applied @UniqDSMT@, i.e. transform a+-- @UniqDSMT m@ into a @UniqDSMT n@ given @m ~> n@.+hoistUDSMT :: (forall x. m x -> n x) -> UniqDSMT m a -> UniqDSMT n a+hoistUDSMT nt (UDSMT m) = UDSMT $ \s -> nt (m s)++-- | Lift a monadic action @m a@ into an @UniqDSMT m a@+liftUDSMT :: Functor m => m a -> UniqDSMT m a+liftUDSMT m = UDSMT $ \s -> (,s) <$> m++--------------------------------------------------------------------------------+-- MonadUniqDSM+--------------------------------------------------------------------------------++class (Monad m) => MonadUniqDSM m where+  -- | Lift a pure 'UniqDSM' action into a 'MonadUniqDSM' such as 'UniqDSMT'+  liftUniqDSM :: UniqDSM a -> m a++instance MonadUniqDSM UniqDSM where+  liftUniqDSM = id++instance Monad m => MonadUniqDSM (UniqDSMT m) where+  liftUniqDSM act = UDSMT $ \us -> pure $ runUniqueDSM us act
compiler/GHC/Types/Unique/DSet.hs view
@@ -33,7 +33,7 @@         lookupUniqDSet,         uniqDSetToList,         partitionUniqDSet,-        mapUniqDSet+        mapUniqDSet, strictFoldUniqDSet, mapMUniqDSet     ) where  import GHC.Prelude@@ -125,7 +125,22 @@  -- See Note [UniqSet invariant] in GHC.Types.Unique.Set mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b-mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList+mapUniqDSet f (UniqDSet m) = UniqDSet $ unsafeCastUDFMKey $ mapUDFM f m+  -- Simply apply `f` to each element, retaining all the structure unchanged.+  -- The identification of keys and elements prevents a derived Functor+  -- instance, but `unsafeCastUDFMKey` makes it possible to apply the strict+  -- mapping from DFM.++-- | Like 'mapUniqDSet' but for 'mapM'. Assumes the function we are mapping+-- over the 'UniqDSet' does not modify uniques, as per+-- Note [UniqSet invariant] in GHC.Types.Unique.Set.+mapMUniqDSet :: (Monad m, Uniquable b) => (a -> m b) -> UniqDSet a -> m (UniqDSet b)+mapMUniqDSet f (UniqDSet m) = UniqDSet . unsafeCastUDFMKey <$> mapMUDFM f m+{-# INLINEABLE mapMUniqDSet #-}++strictFoldUniqDSet :: (a -> r -> r) -> r -> UniqDSet a -> r+strictFoldUniqDSet k r s = foldl' (\ !r e -> k e r) r $+                           uniqDSetToList s  -- Two 'UniqDSet's are considered equal if they contain the same -- uniques.
compiler/GHC/Types/Unique/FM.hs view
@@ -44,7 +44,7 @@         addListToUFM,addListToUFM_C,         addToUFM_Directly,         addListToUFM_Directly,-        adjustUFM, alterUFM,+        adjustUFM, alterUFM, alterUFM_Directly,         adjustUFM_Directly,         delFromUFM,         delFromUFM_Directly,@@ -57,6 +57,7 @@         mergeUFM,         plusMaybeUFM_C,         plusUFMList,+        plusUFMListWith,         sequenceUFMList,         minusUFM,         minusUFM_C,@@ -64,11 +65,13 @@         intersectUFM_C,         disjointUFM,         equalKeysUFM,-        nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM,+        diffUFM,+        nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM,+        nonDetFoldWithKeyUFM,         nonDetStrictFoldUFM_Directly,         anyUFM, allUFM, seqEltsUFM,-        mapUFM, mapUFM_Directly,-        mapMaybeUFM,+        mapUFM, mapUFM_Directly, strictMapUFM,+        mapMaybeUFM, mapMaybeUFM_sameUnique, mapMaybeWithKeyUFM,         elemUFM, elemUFM_Directly,         filterUFM, filterUFM_Directly, partitionUFM,         sizeUFM,@@ -137,9 +140,11 @@  listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM+{-# INLINEABLE listToUFM #-}  listToUFM_Directly :: [(Unique, elt)] -> UniqFM key elt listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM+{-# INLINEABLE listToUFM_Directly #-}  listToIdentityUFM :: Uniquable key => [key] -> UniqFM key key listToIdentityUFM = foldl' (\m x -> addToUFM m x x) emptyUFM@@ -150,6 +155,7 @@   -> [(key, elt)]   -> UniqFM key elt listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM+{-# INLINEABLE listToUFM_C #-}  addToUFM :: Uniquable key => UniqFM key elt -> key -> elt  -> UniqFM key elt addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)@@ -165,10 +171,10 @@  addToUFM_C   :: Uniquable key-  => (elt -> elt -> elt)  -- old -> new -> result-  -> UniqFM key elt           -- old-  -> key -> elt           -- new-  -> UniqFM key elt           -- result+  => (elt -> elt -> elt)  -- ^ old -> new -> result+  -> UniqFM key elt       -- ^ old+  -> key -> elt           -- ^ new+  -> UniqFM key elt       -- ^ result -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v =   UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)@@ -177,9 +183,9 @@   :: Uniquable key   => (elt -> elts -> elts)  -- Add to existing   -> (elt -> elts)          -- New element-  -> UniqFM key elts            -- old+  -> UniqFM key elts        -- old   -> key -> elt             -- new-  -> UniqFM key elts            -- result+  -> UniqFM key elts        -- result addToUFM_Acc exi new (UFM m) k v =   UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) @@ -188,11 +194,11 @@ -- otherwise compute the element to add using the passed function. addToUFM_L   :: Uniquable key-  => (key -> elt -> elt -> elt) -- key,old,new+  => (key -> elt -> elt -> elt) -- ^ key,old,new   -> key   -> elt -- new   -> UniqFM key elt-  -> (Maybe elt, UniqFM key elt) -- old, result+  -> (Maybe elt, UniqFM key elt) -- ^ old, result addToUFM_L f k v (UFM m) =   coerce $     M.insertLookupWithKey@@ -203,12 +209,19 @@  alterUFM   :: Uniquable key-  => (Maybe elt -> Maybe elt)  -- How to adjust-  -> UniqFM key elt                -- old-  -> key                       -- new-  -> UniqFM key elt                -- result+  => (Maybe elt -> Maybe elt)  -- ^ How to adjust+  -> UniqFM key elt            -- ^ old+  -> key                       -- ^ new+  -> UniqFM key elt            -- ^ result alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) +alterUFM_Directly+  :: (Maybe elt -> Maybe elt)  -- ^ How to adjust+  -> UniqFM key elt            -- ^ old+  -> Unique                    -- ^ new+  -> UniqFM key elt            -- ^ result+alterUFM_Directly f (UFM m) k = UFM (M.alter f (getKey k) m)+ -- | Add elements to the map, combining existing values with inserted ones using -- the given function. addListToUFM_C@@ -227,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)@@ -323,6 +338,9 @@ plusUFMList :: [UniqFM key elt] -> UniqFM key elt plusUFMList = foldl' plusUFM emptyUFM +plusUFMListWith :: (elt -> elt -> elt) -> [UniqFM key elt] -> UniqFM key elt+plusUFMListWith f xs = unsafeIntMapToUFM $ M.unionsWith f (map ufmToIntMap xs)+ sequenceUFMList :: forall key elt. [UniqFM key elt] -> UniqFM key [elt] sequenceUFMList = foldr (plusUFM_CD2 cons) emptyUFM   where@@ -356,18 +374,39 @@ disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool disjointUFM (UFM x) (UFM y) = M.disjoint x y -foldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a-foldUFM k z (UFM m) = M.foldr k z m+-- | Fold over a 'UniqFM'.+--+-- Non-deterministic, unless the folding function is commutative+-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@).+nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a+nonDetFoldUFM f z (UFM m) = M.foldr f z m +-- | Like 'nonDetFoldUFM', but with the 'Unique' key as well.+nonDetFoldWithKeyUFM :: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a+nonDetFoldWithKeyUFM f z (UFM m) = M.foldrWithKey f' z m+  where+    f' k e a = f (mkUniqueGrimily k) e a+ mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM f (UFM m) = UFM (M.map f m)  mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2-mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m)+mapMaybeUFM = mapMaybeUFM_sameUnique +-- | Like 'Data.Map.mapMaybe', but you must ensure the passed-in function does+-- not modify the unique.+mapMaybeUFM_sameUnique :: (elt1 -> Maybe elt2) -> UniqFM key1 elt1 -> UniqFM key2 elt2+mapMaybeUFM_sameUnique f (UFM m) = UFM (M.mapMaybe f m)++mapMaybeWithKeyUFM :: (Unique -> elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2+mapMaybeWithKeyUFM f (UFM m) = UFM (M.mapMaybeWithKey (f . mkUniqueGrimily) m)+ mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . mkUniqueGrimily) m) +strictMapUFM :: (a -> b) -> UniqFM k a -> UniqFM k b+strictMapUFM f (UFM a) = UFM $ MS.map f a+ filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt filterUFM p (UFM m) = UFM (M.filter p m) @@ -411,7 +450,7 @@ allUFM p (UFM m) = M.foldr ((&&) . p) True m  seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> ()-seqEltsUFM seqElt = foldUFM (\v rest -> seqElt v `seq` rest) ()+seqEltsUFM seqElt = nonDetFoldUFM (\v rest -> seqElt v `seq` rest) ()  -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce@@ -492,6 +531,28 @@ -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2++-- | An edit on type @a@, relating an element of a container (like an entry in a+-- map or a line in a file) before and after.+data Edit a+  = Removed !a    -- ^ Element was removed from the container+  | Added !a      -- ^ Element was added to the container+  | Changed !a !a -- ^ Element was changed. Carries the values before and after+  deriving Eq++instance Outputable a => Outputable (Edit a) where+  ppr (Removed a) = text "-" <> ppr a+  ppr (Added a) = text "+" <> ppr a+  ppr (Changed l r) = ppr l <> text "->" <> ppr r++-- A very convient function to have for debugging:+-- | Computes the diff of two 'UniqFM's in terms of 'Edit's.+-- Equal points will not be present in the result map at all.+diffUFM :: Eq a => UniqFM key a -> UniqFM key a -> UniqFM key (Edit a)+diffUFM = mergeUFM both (mapUFM Removed) (mapUFM Added)+  where+    both x y | x == y    = Nothing+             | otherwise = Just $! Changed x y  -- Instances
compiler/GHC/Types/Unique/Map.hs view
@@ -30,20 +30,25 @@     plusUniqMap_C,     plusMaybeUniqMap_C,     plusUniqMapList,+    plusUniqMapListWith,     minusUniqMap,     intersectUniqMap,     intersectUniqMap_C,     disjointUniqMap,     mapUniqMap,     filterUniqMap,+    filterWithKeyUniqMap,     partitionUniqMap,     sizeUniqMap,     elemUniqMap,+    nonDetKeysUniqMap,+    nonDetEltsUniqMap,     lookupUniqMap,     lookupWithDefaultUniqMap,     anyUniqMap,     allUniqMap,-    nonDetEltsUniqMap,+    nonDetUniqMapToList,+    nonDetUniqMapToKeySet,     nonDetFoldUniqMap     -- Non-deterministic functions omitted ) where@@ -61,6 +66,8 @@ import Data.Data import Control.DeepSeq +import Data.Set (Set, fromList)+ -- | Maps indexed by 'Uniquable' keys newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) }     deriving (Data, Eq, Functor)@@ -192,6 +199,13 @@ plusUniqMapList :: [UniqMap k a] -> UniqMap k a plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs) +plusUniqMapListWith :: (a -> a -> a) -> [UniqMap k a] -> UniqMap k a+plusUniqMapListWith f xs = UniqMap $ plusUFMListWith go (coerce xs)+  where+    -- l and r keys will be identical so we choose the former+    go (l_key, l) (_r, r) = (l_key, f l r)+{-# INLINE plusUniqMapListWith #-}+ minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2 @@ -201,6 +215,7 @@ -- | Intersection with a combining function. intersectUniqMap_C :: (a -> b -> c) -> UniqMap k a -> UniqMap k b -> UniqMap k c intersectUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM_C (\(k, a) (_, b) -> (k, f a b)) m1 m2+{-# INLINE intersectUniqMap #-}  disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2@@ -211,6 +226,9 @@ filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m +filterWithKeyUniqMap :: (k -> a -> Bool) -> UniqMap k a -> UniqMap k a+filterWithKeyUniqMap f (UniqMap m) = UniqMap $ filterUFM (uncurry f) m+ partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a) partitionUniqMap f (UniqMap m) =     coerce $ partitionUFM (f . snd) m@@ -233,8 +251,21 @@ allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool allUniqMap f (UniqMap m) = allUFM (f . snd) m -nonDetEltsUniqMap :: UniqMap k a -> [(k, a)]-nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m+nonDetUniqMapToList :: UniqMap k a -> [(k, a)]+nonDetUniqMapToList (UniqMap m) = nonDetEltsUFM m+{-# INLINE nonDetUniqMapToList #-} +nonDetUniqMapToKeySet :: Ord k => UniqMap k a -> Set k+nonDetUniqMapToKeySet m = fromList (nonDetKeysUniqMap m)++nonDetKeysUniqMap :: UniqMap k a -> [k]+nonDetKeysUniqMap m = map fst (nonDetUniqMapToList m)+{-# INLINE nonDetKeysUniqMap #-}++nonDetEltsUniqMap :: UniqMap k a -> [a]+nonDetEltsUniqMap m = map snd (nonDetUniqMapToList m)+{-# INLINE nonDetEltsUniqMap #-}+ nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b-nonDetFoldUniqMap go z (UniqMap m) = foldUFM go z m+nonDetFoldUniqMap go z (UniqMap m) = nonDetFoldUFM go z m+{-# INLINE nonDetFoldUniqMap #-}
compiler/GHC/Types/Unique/Set.hs view
@@ -44,6 +44,27 @@         nonDetEltsUniqSet,         nonDetKeysUniqSet,         nonDetStrictFoldUniqSet,+        mapMaybeUniqSet_sameUnique,++        -- UniqueSet+        UniqueSet(..),+        nullUniqueSet,+        sizeUniqueSet,+        memberUniqueSet,+        emptyUniqueSet,+        singletonUniqueSet,+        insertUniqueSet,+        deleteUniqueSet,+        differenceUniqueSet,+        unionUniqueSet,+        unionsUniqueSet,+        intersectionUniqueSet,+        isSubsetOfUniqueSet,+        filterUniqueSet,+        foldlUniqueSet,+        foldrUniqueSet,+        elemsUniqueSet,+        fromListUniqueSet,     ) where  import GHC.Prelude@@ -55,6 +76,8 @@ import GHC.Utils.Outputable import Data.Data import qualified Data.Semigroup as Semi+import Control.DeepSeq+import qualified GHC.Data.Word64Set as S  -- Note [UniqSet invariant] -- ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -63,23 +86,29 @@ -- It means that to implement mapUniqSet you have to update -- both the keys and the values. +-- | Set of Uniquable values newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a a}                   deriving (Data, Semi.Semigroup, Monoid) +instance NFData a => NFData (UniqSet a) where+  rnf = forceUniqSet rnf+ emptyUniqSet :: UniqSet a emptyUniqSet = UniqSet emptyUFM  unitUniqSet :: Uniquable a => a -> UniqSet a unitUniqSet x = UniqSet $ unitUFM x x -mkUniqSet :: Uniquable a => [a]  -> UniqSet a+mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet = foldl' addOneToUniqSet emptyUniqSet+{-# INLINEABLE mkUniqSet #-}  addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)  addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a addListToUniqSet = foldl' addOneToUniqSet+{-# INLINEABLE addListToUniqSet #-}  delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)@@ -89,10 +118,12 @@  delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)+{-# INLINEABLE delListFromUniqSet #-}  delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a delListFromUniqSet_Directly (UniqSet s) l =     UniqSet (delListFromUFM_Directly s l)+{-# INLINEABLE delListFromUniqSet_Directly #-}  unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)@@ -175,6 +206,11 @@ mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet +-- | Like 'Data.Set.mapMaybe', but you must ensure the passed in function+-- does not change the 'Unique'.+mapMaybeUniqSet_sameUnique :: (a -> Maybe b) -> UniqSet a -> UniqSet b+mapMaybeUniqSet_sameUnique f (UniqSet a) = UniqSet $ mapMaybeUFM_sameUnique f a+ -- Two 'UniqSet's are considered equal if they contain the same -- uniques. instance Eq (UniqSet a) where@@ -186,7 +222,7 @@ -- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ -- assuming, without checking, that it maps each 'Unique' to a value -- that has that 'Unique'. See Note [UniqSet invariant].-unsafeUFMToUniqSet :: UniqFM  a a -> UniqSet a+unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a unsafeUFMToUniqSet = UniqSet  instance Outputable a => Outputable (UniqSet a) where@@ -196,3 +232,84 @@ -- It's OK to use nonDetUFMToList here because we only use it for -- pretty-printing. pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet++forceUniqSet :: (a -> ()) -> UniqSet a -> ()+forceUniqSet f (UniqSet fm) = seqEltsUFM f fm++--------------------------------------------------------+-- UniqueSet+--------------------------------------------------------++-- | Set of Unique values+--+-- Similar to 'UniqSet Unique' but with a more compact representation.+newtype UniqueSet = US { unUniqueSet :: S.Word64Set }+  deriving (Eq, Ord, Show, Semigroup, Monoid)++{-# INLINE nullUniqueSet #-}+nullUniqueSet :: UniqueSet -> Bool+nullUniqueSet (US s) = S.null s++{-# INLINE sizeUniqueSet #-}+sizeUniqueSet :: UniqueSet -> Int+sizeUniqueSet (US s) = S.size s++{-# INLINE memberUniqueSet #-}+memberUniqueSet :: Unique -> UniqueSet -> Bool+memberUniqueSet k (US s) = S.member (getKey k) s++{-# INLINE emptyUniqueSet #-}+emptyUniqueSet :: UniqueSet+emptyUniqueSet = US S.empty++{-# INLINE singletonUniqueSet #-}+singletonUniqueSet :: Unique -> UniqueSet+singletonUniqueSet k = US (S.singleton (getKey k))++{-# INLINE insertUniqueSet #-}+insertUniqueSet :: Unique -> UniqueSet -> UniqueSet+insertUniqueSet k (US s) = US (S.insert (getKey k) s)++{-# INLINE deleteUniqueSet #-}+deleteUniqueSet :: Unique -> UniqueSet -> UniqueSet+deleteUniqueSet k (US s) = US (S.delete (getKey k) s)++{-# INLINE unionUniqueSet #-}+unionUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet+unionUniqueSet (US x) (US y) = US (S.union x y)++{-# INLINE unionsUniqueSet #-}+unionsUniqueSet :: [UniqueSet] -> UniqueSet+unionsUniqueSet xs = US (S.unions (map unUniqueSet xs))++{-# INLINE differenceUniqueSet #-}+differenceUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet+differenceUniqueSet (US x) (US y) = US (S.difference x y)++{-# INLINE intersectionUniqueSet #-}+intersectionUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet+intersectionUniqueSet (US x) (US y) = US (S.intersection x y)++{-# INLINE isSubsetOfUniqueSet #-}+isSubsetOfUniqueSet :: UniqueSet -> UniqueSet -> Bool+isSubsetOfUniqueSet (US x) (US y) = S.isSubsetOf x y++{-# INLINE filterUniqueSet #-}+filterUniqueSet :: (Unique -> Bool) -> UniqueSet -> UniqueSet+filterUniqueSet f (US s) = US (S.filter (f . mkUniqueGrimily) s)++{-# INLINE foldlUniqueSet #-}+foldlUniqueSet :: (a -> Unique -> a) -> a -> UniqueSet -> a+foldlUniqueSet k z (US s) = S.foldl' (\a b -> k a (mkUniqueGrimily b)) z s++{-# INLINE foldrUniqueSet #-}+foldrUniqueSet :: (Unique -> b -> b) -> b -> UniqueSet -> b+foldrUniqueSet k z (US s) = S.foldr (k . mkUniqueGrimily) z s++{-# INLINE elemsUniqueSet #-}+elemsUniqueSet :: UniqueSet -> [Unique]+elemsUniqueSet (US s) = map mkUniqueGrimily (S.elems s)++{-# INLINE fromListUniqueSet #-}+fromListUniqueSet :: [Unique] -> UniqueSet+fromListUniqueSet ks = US (S.fromList (map getKey ks))
compiler/GHC/Types/Unique/Supply.hs view
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-}@@ -42,18 +42,24 @@ import Data.Word import GHC.Exts( Ptr(..), noDuplicate#, oneShot ) import Foreign.Storable+import GHC.Utils.Monad.State.Strict as Strict  #include "MachDeps.h" -#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) && WORD_SIZE_IN_BITS == 64-import GHC.Word( Word64(..) )-import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# )-#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-import GHC.Exts( wordToWord64# )+#if WORD_SIZE_IN_BITS != 64+#define NO_FETCH_ADD #endif++#if defined(NO_FETCH_ADD)+import GHC.Exts ( atomicCasWord64Addr#, eqWord64#, readWord64OffAddr# )+#else+import GHC.Exts( fetchAddWordAddr#, word64ToWord# ) #endif -#include "Unique.h"+import GHC.Exts ( Addr#, State#, Word64#, RealWorld )+import GHC.Int ( Int(..) )+import GHC.Word( Word64(..) )+import GHC.Exts( plusWord64#, int2Word#, wordToWord64# )  {- ************************************************************************@@ -165,8 +171,7 @@ benefits of threading the tag this *also* has the benefit of avoiding the tag getting captured in thunks, or being passed around at runtime. It does however come at the cost of having to use a fixed tag for all-code run in this Monad. But remember, the tag is purely cosmetic:-See Note [Uniques and tags].+code run in this Monad. The tag is mostly cosmetic: See Note [Uniques and tags].  NB: It's *not* an optimization to pass around the UniqSupply inside an IORef instead of the tag. While this would avoid frequent state updates@@ -197,9 +202,8 @@  mkSplitUniqSupply :: Char -> IO UniqSupply -- ^ Create a unique supply out of thin air.--- The "tag" (Char) supplied is purely cosmetic, making it easier--- to figure out where a Unique was born. See--- Note [Uniques and tags].+-- The "tag" (Char) supplied is mostly cosmetic, making it easier+-- to figure out where a Unique was born. See Note [Uniques and tags]. -- -- The payload part of the Uniques allocated from this UniqSupply are -- guaranteed distinct wrt all other supplies, regardless of their "tag".@@ -228,25 +232,37 @@         (# s4, MkSplitUniqSupply (tag .|. u) x y #)         }}}} --- If a word is not 64 bits then we would need a fetchAddWord64Addr# primitive,--- which does not exist. So we fall back on the C implementation in that case.--#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64-foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Word64+#if defined(NO_FETCH_ADD)+-- GHC currently does not provide this operation on 32-bit platforms,+-- hence the CAS-based implementation.+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld+                    -> (# State# RealWorld, Word64# #)+fetchAddWord64Addr# = go+  where+    go ptr inc s0 =+      case readWord64OffAddr# ptr 0# s0 of+        (# s1, n0 #) ->+          case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of+            (# s2, res #)+              | 1# <- res `eqWord64#` n0 -> (# s2, n0 #)+              | otherwise -> go ptr inc s2 #else+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld+                    -> (# State# RealWorld, Word64# #)+fetchAddWord64Addr# addr inc s0 =+    case fetchAddWordAddr# addr (word64ToWord# inc) s0 of+      (# s1, res #) -> (# s1, wordToWord64# res #)+#endif+ genSym :: IO Word64 genSym = do     let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1     let !(Ptr counter) = ghc_unique_counter64-    let !(Ptr inc_ptr) = ghc_unique_inc-    u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of-        (# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of+    I# inc# <- peek ghc_unique_inc+    let !inc = wordToWord64# (int2Word# inc#)+    u <- IO $ \s1 -> case fetchAddWord64Addr# counter inc s1 of             (# s2, val #) ->-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-                let !u = W64# (val `plusWord#` inc) .&. mask-#else-                let !u = W64# (wordToWord64# (val `plusWord#` inc)) .&. mask-#endif+                let !u = W64# (val `plusWord64#` inc) .&. mask                 in (# s2, u #) #if defined(DEBUG)     -- Uh oh! We will overflow next time a unique is requested.@@ -254,7 +270,6 @@     massert (u /= mask) #endif     return u-#endif  foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64 foreign import ccall unsafe "&ghc_unique_inc"       ghc_unique_inc       :: Ptr Int@@ -289,6 +304,8 @@ uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) +{-# INLINE splitUniqSupply #-}+ {- ************************************************************************ *                                                                      *@@ -305,12 +322,7 @@  -- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }---- See Note [The one-shot state monad trick] for why we don't derive this.-instance Functor UniqSM where-  fmap f (USM m) = mkUniqSM $ \us ->-      case m us of-        (# r, us' #) -> UniqResult (f r) us'+  deriving (Functor, Applicative, Monad) via (Strict.State UniqSupply)  -- | Smart constructor for 'UniqSM', as described in Note [The one-shot state -- monad trick].@@ -318,17 +330,6 @@ mkUniqSM f = USM (oneShot f) {-# INLINE mkUniqSM #-} -instance Monad UniqSM where-  (>>=) = thenUs-  (>>)  = (*>)--instance Applicative UniqSM where-    pure = returnUs-    (USM f) <*> (USM x) = mkUniqSM $ \us0 -> case f us0 of-                            UniqResult ff us1 -> case x us1 of-                              UniqResult xx us2 -> UniqResult (ff xx) us2-    (*>) = thenUs_- -- TODO: try to get rid of this instance instance MonadFail UniqSM where     fail = panic@@ -341,29 +342,11 @@ initUs_ :: UniqSupply -> UniqSM a -> a initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } -{-# INLINE thenUs #-}-{-# INLINE returnUs #-}-{-# INLINE splitUniqSupply #-}---- @thenUs@ is where we split the @UniqSupply@.- liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)  instance MonadFix UniqSM where     mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)--thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b-thenUs (USM expr) cont-  = mkUniqSM (\us0 -> case (expr us0) of-                   UniqResult result us1 -> unUSM (cont result) us1)--thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b-thenUs_ (USM expr) (USM cont)-  = mkUniqSM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })--returnUs :: a -> UniqSM a-returnUs result = mkUniqSM (\us -> UniqResult result us)  getUs :: UniqSM UniqSupply getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)
compiler/GHC/Types/Var.hs view
@@ -5,9 +5,9 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,-             PatternSynonyms, BangPatterns #-}+{-# LANGUAGE MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE DeriveFunctor #-}  -- | -- #name_types#@@ -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,@@ -61,7 +61,7 @@          -- ** Predicates         isId, isTyVar, isTcTyVar,-        isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar,+        isLocalVar, isLocalId, isLocalId_maybe, isCoVar, isNonCoVarId, isTyCoVar,         isGlobalId, isExportedId,         mustHaveLocalBinding, @@ -69,6 +69,8 @@         ForAllTyFlag(Invisible,Required,Specified,Inferred),         Specificity(..),         isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag,+        isSpecifiedForAllTyFlag,+        coreTyLamForAllTyFlag,          -- * FunTyFlag         FunTyFlag(..), isVisibleFunArg, isInvisibleFunArg, isFUNArg,@@ -80,7 +82,8 @@          -- * PiTyBinder         PiTyBinder(..), PiTyVarBinder,-        isInvisiblePiTyBinder, isVisiblePiTyBinder,+        isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder,+        isVisiblePiTyBinder,         isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder,         namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, @@ -90,10 +93,13 @@         binderVar, binderVars, binderFlag, binderFlags, binderType,         mkForAllTyBinder, mkForAllTyBinders,         mkTyVarBinder, mkTyVarBinders,-        isTyVarBinder,+        isVisibleForAllTyBinder, isInvisibleForAllTyBinder, isTyVarBinder,         tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,         mapVarBndr, mapVarBndrs, +        -- ** ExportFlag+        ExportFlag(..),+         -- ** Constructing TyVar's         mkTyVar, mkTcTyVar, @@ -123,8 +129,11 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain +import GHC.Hs.Specificity ()+import Language.Haskell.Syntax.Specificity+import Control.DeepSeq+ import Data.Data  {-@@ -197,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  @@ -317,7 +328,10 @@   * or defined at top level in the module being compiled   * always treated as a candidate by the free-variable finder -After CoreTidy, top-level LocalIds are turned into GlobalIds+In the output of CoreTidy, top level Ids are all GlobalIds, which are then+serialised into interface files. Do note however that CorePrep may introduce new+LocalIds for local floats (even at the top level). These will be visible in STG+and end up in generated code.  Note [Multiplicity of let binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -333,9 +347,12 @@ -}  instance Outputable Var where-  ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->+  ppr var = docWithStyle ppr_code ppr_normal+    where+      -- don't display debug info with Code style (#25255)+      ppr_code = ppr (varName var)+      ppr_normal sty = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->             getPprDebug $ \debug ->-            getPprStyle $ \sty ->             let               ppr_var = case var of                   (TyVar {})@@ -403,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,@@ -443,79 +464,6 @@  {- ********************************************************************* *                                                                      *-*                   ForAllTyFlag-*                                                                      *-********************************************************************* -}---- | ForAllTyFlag------ Is something required to appear in source Haskell ('Required'),--- permitted by request ('Specified') (visible type application), or--- prohibited entirely from appearing in source Haskell ('Inferred')?--- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep"-data ForAllTyFlag = Invisible Specificity-                  | Required-  deriving (Eq, Ord, Data)-  -- (<) on ForAllTyFlag means "is less visible than"---- | Whether an 'Invisible' argument may appear in source Haskell.-data Specificity = InferredSpec-                   -- ^ the argument may not appear in source Haskell, it is-                   -- only inferred.-                 | SpecifiedSpec-                   -- ^ the argument may appear in source Haskell, but isn't-                   -- required.-  deriving (Eq, Ord, Data)--pattern Inferred, Specified :: ForAllTyFlag-pattern Inferred  = Invisible InferredSpec-pattern Specified = Invisible SpecifiedSpec--{-# COMPLETE Required, Specified, Inferred #-}---- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell?-isVisibleForAllTyFlag :: ForAllTyFlag -> Bool-isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af)---- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell?-isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool-isInvisibleForAllTyFlag (Invisible {}) = True-isInvisibleForAllTyFlag Required       = False--isInferredForAllTyFlag :: ForAllTyFlag -> Bool--- More restrictive than isInvisibleForAllTyFlag-isInferredForAllTyFlag (Invisible InferredSpec) = True-isInferredForAllTyFlag _                        = False--instance Outputable ForAllTyFlag where-  ppr Required  = text "[req]"-  ppr Specified = text "[spec]"-  ppr Inferred  = text "[infrd]"--instance Binary Specificity where-  put_ bh SpecifiedSpec = putByte bh 0-  put_ bh InferredSpec  = putByte bh 1--  get bh = do-    h <- getByte bh-    case h of-      0 -> return SpecifiedSpec-      _ -> return InferredSpec--instance Binary ForAllTyFlag where-  put_ bh Required  = putByte bh 0-  put_ bh Specified = putByte bh 1-  put_ bh Inferred  = putByte bh 2--  get bh = do-    h <- getByte bh-    case h of-      0 -> return Required-      1 -> return Specified-      _ -> return Inferred--{- *********************************************************************-*                                                                      * *                   FunTyFlag *                                                                      * ********************************************************************* -}@@ -552,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@@ -618,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. @@ -687,10 +641,6 @@ * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis   Binders of a TyCon; see TyCon in GHC.Core.TyCon -* TyCon.TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis-  Binders of a PromotedDataCon-  See Note [Promoted GADT data constructors] in GHC.Core.TyCon- * IfaceType.IfaceForAllBndr     = VarBndr IfaceBndr ForAllTyFlag * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity * IfaceType.IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis@@ -698,18 +648,19 @@  data VarBndr var argf = Bndr var argf   -- See Note [The VarBndr type and its uses]-  deriving( Data )+  deriving( Data, Eq, Ord)  -- | Variable Binder -- -- A 'ForAllTyBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] -- -- A 'TyVarBinder' is a binder with only TyVar type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag-type InvisTyBinder  = VarBndr TyCoVar   Specificity-type ReqTyBinder    = VarBndr TyCoVar   ()+type InvisTyBinder  = VarBndr TyCoVar Specificity+type ReqTyBinder    = VarBndr TyCoVar ()  type TyVarBinder    = VarBndr TyVar   ForAllTyFlag type InvisTVBinder  = VarBndr TyVar   Specificity@@ -727,6 +678,12 @@ tyVarReqToBinder :: VarBndr a () -> VarBndr a ForAllTyFlag tyVarReqToBinder (Bndr tv _) = Bndr tv Required +isVisibleForAllTyBinder :: ForAllTyBinder -> Bool+isVisibleForAllTyBinder (Bndr _ vis) = isVisibleForAllTyFlag vis++isInvisibleForAllTyBinder :: ForAllTyBinder -> Bool+isInvisibleForAllTyBinder (Bndr _ vis) = isInvisibleForAllTyFlag vis+ binderVar :: VarBndr tv argf -> tv binderVar (Bndr v _) = v @@ -784,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 @@ -809,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@@ -819,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@@ -892,7 +855,7 @@   Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A ForAllTy (used for both types and kinds) contains a ForAllTyBinder.   Each ForAllTyBinder       Bndr a tvis@@ -915,8 +878,7 @@ |  tvis = Inferred:            f :: forall {a}. type    Arg not allowed:  f                                f :: forall {co}. type   Arg not allowed:  f |  tvis = Specified:           f :: forall a. type      Arg optional:     f  or  f @Int-|  tvis = Required:            T :: forall k -> type    Arg required:     T *-|    This last form is illegal in terms: See Note [No Required PiTyBinder in terms]+|  tvis = Required:            f :: forall k -> type    Arg required:     f (type Int) | | Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon |  cvis :: TyConBndrVis@@ -947,22 +909,28 @@      f3 :: forall a. a -> a; f3 x = x   So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified +* Required.  Function defn, with signature (explicit forall):+     f4 :: forall a -> a -> a; f4 (type _) x = x+  So f4 gets the type f4 :: forall a -> a -> a, with 'a' Required+  This is the experimental RequiredTypeArguments extension,+  see GHC Proposal #281 "Visible forall in types of terms"+ * Inferred.  Function defn, with signature (explicit forall), marked as inferred:-     f4 :: forall {a}. a -> a; f4 x = x-  So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred+     f5 :: forall {a}. a -> a; f5 x = x+  So f5 gets the type f5 :: forall {a}. a -> a, with 'a' Inferred   It's Inferred because the user marked it as such, even though it does appear-  in the user-written signature for f4+  in the user-written signature for f5  * Inferred/Specified.  Function signature with inferred kind polymorphism.-     f5 :: a b -> Int-  So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int+     f6 :: a b -> Int+  So 'f6' gets the type f6 :: forall {k} (a :: k -> Type) (b :: k). a b -> Int   Here 'k' is Inferred (it's not mentioned in the type),   but 'a' and 'b' are Specified.  * Specified.  Function signature with explicit kind polymorphism-     f6 :: a (b :: k) -> Int+     f7 :: a (b :: k) -> Int   This time 'k' is Specified, because it is mentioned explicitly,-  so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int+  so we get f7 :: forall (k :: Type) (a :: k -> Type) (b :: k). a b -> Int  * Similarly pattern synonyms:   Inferred - from inferred types (e.g. no pattern type signature)@@ -1022,7 +990,7 @@                const :: forall a b. a -> b -> a   Inferred: like Specified, but every binder is written in braces:-               f :: forall {k} (a:k). S k a -> Int+               f :: forall {k} (a :: k). S k a -> Int   Required: binders are put between `forall` and `->`:               T :: forall k -> *@@ -1034,19 +1002,6 @@  * Inferred variables correspond to "generalized" variables from the   Visible Type Applications paper (ESOP'16).--Note [No Required PiTyBinder in terms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't allow Required foralls for term variables, including pattern-synonyms and data constructors.  Why?  Because then an application-would need a /compulsory/ type argument (possibly without an "@"?),-thus (f Int); and we don't have concrete syntax for that.--We could change this decision, but Required, Named PiTyBinders are rare-anyway.  (Most are Anons.)--However the type of a term can (just about) have a required quantifier;-see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr. -}  @@ -1119,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) @@ -1248,6 +1203,10 @@ isLocalId :: Var -> Bool isLocalId (Id { idScope = LocalId _ }) = True isLocalId _                            = False++isLocalId_maybe :: Var -> Maybe ExportFlag+isLocalId_maybe (Id { idScope = LocalId ef }) = Just ef+isLocalId_maybe _                             = Nothing  -- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's -- These are the variables that we need to pay attention to when finding free
compiler/GHC/Types/Var.hs-boot view
@@ -1,22 +1,16 @@ {-# LANGUAGE NoPolyKinds #-} module GHC.Types.Var where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name-  -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports-  -- it does not seem to depend on anything. But it does! We must, for-  -- example, compile GHC.Types in the ghc-prim library first. So this-  -- otherwise-unnecessary import tells the build system that this module-  -- depends on GhcPrelude, which ensures that GHC.Type is built first.+import Language.Haskell.Syntax.Specificity (Specificity, ForAllTyFlag) -data ForAllTyFlag data FunTyFlag data Var instance NamedThing Var data VarBndr var argf-data Specificity type TyVar = Var type Id    = Var type TyCoVar = Id type TcTyVar = Var type InvisTVBinder = VarBndr TyVar Specificity+type TyVarBinder   = VarBndr TyVar ForAllTyFlag
compiler/GHC/Types/Var/Env.hs view
@@ -24,6 +24,7 @@         elemVarEnvByKey,         filterVarEnv, restrictVarEnv,         partitionVarEnv, varEnvDomain,+        nonDetStrictFoldVarEnv_Directly,          -- * Deterministic Var environments (maps)         DVarEnv, DIdEnv, DTyVarEnv,@@ -73,7 +74,8 @@          -- * TidyEnv and its operation         TidyEnv,-        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList+        emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList,+        mapMaybeDVarEnv     ) where  import GHC.Prelude@@ -318,25 +320,30 @@  rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but returns the new variable as well as the--- new environment+-- new environment.+-- Postcondition: the type of the returned Var is that of bR rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR-  = (RV2 { envL            = extendVarEnv envL bL new_b   -- See Note-         , envR            = extendVarEnv envR bR new_b   -- [Rebinding]+  = (RV2 { envL     = extendVarEnv envL bL new_b   -- See Note+         , envR     = extendVarEnv envR bR new_b   -- [Rebinding]          , in_scope = extendInScopeSet in_scope new_b }, new_b)   where         -- Find a new binder not in scope in either term-    new_b | not (bL `elemInScopeSet` in_scope) = bL-          | not (bR `elemInScopeSet` in_scope) = bR-          | otherwise                          = uniqAway' in_scope bL+        -- To avoid calling `uniqAway`, we try bL's Unique+        -- But we always return a Var whose type is that of bR+    new_b | not (bR `elemInScopeSet` in_scope) = bR+          | not (bL `elemInScopeSet` in_scope) = bR `setVarUnique` varUnique bL+          | otherwise                          = uniqAway' in_scope bR          -- Note [Rebinding]         -- ~~~~~~~~~~~~~~~~         -- If the new var is the same as the old one, note that-        -- the extendVarEnv *deletes* any current renaming+        -- the extendVarEnv *replaces* any current renaming         -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)         --+        --                        envL    envR          in_scope         --   Inside \x  \y      { [x->y], [y->y],       {y} }-        --       \x  \z         { [x->x], [y->y, z->x], {y,x} }+        --          \x  \z      { [x->z], [y->y, z->z], {y,z} }+        --          The envL binding [x->y] is replaced by [x->z]  rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used when there's a binder on the left@@ -464,7 +471,7 @@ delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env')   where-    occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs+    occ_env' = occ_env `delTidyOccEnvList` map getOccName vs     var_env' = var_env `delVarEnvList` vs  {-@@ -511,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@@ -530,6 +537,7 @@ elemVarEnv        :: Var -> VarEnv a -> Bool elemVarEnvByKey   :: Unique -> VarEnv a -> Bool disjointVarEnv    :: VarEnv a -> VarEnv a -> Bool+nonDetStrictFoldVarEnv_Directly :: (Unique -> a -> r -> r) -> r -> VarEnv a -> r  elemVarEnv       = elemUFM elemVarEnvByKey  = elemUFM_Directly@@ -543,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@@ -565,13 +575,14 @@ isEmptyVarEnv    = isNullUFM partitionVarEnv  = partitionUFM varEnvDomain     = domUFMUnVarSet+nonDetStrictFoldVarEnv_Directly = nonDetStrictFoldUFM_Directly   restrictVarEnv env vs = filterUFM_Directly keep env   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"@@ -645,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/Types/Var/Set.hs view
@@ -26,7 +26,7 @@         nonDetStrictFoldVarSet,          -- * Deterministic Var set types-        DVarSet, DIdSet, DTyVarSet, DTyCoVarSet,+        DVarSet, DIdSet, DTyVarSet, DCoVarSet, DTyCoVarSet,          -- ** Manipulating these sets         emptyDVarSet, unitDVarSet, mkDVarSet,@@ -38,7 +38,7 @@         isEmptyDVarSet, delDVarSet, delDVarSetList,         minusDVarSet,         nonDetStrictFoldDVarSet,-        filterDVarSet, mapDVarSet,+        filterDVarSet, mapDVarSet, strictFoldDVarSet,         dVarSetMinusVarSet, anyDVarSet, allDVarSet,         transCloDVarSet,         sizeDVarSet, seqDVarSet,@@ -232,6 +232,9 @@ -- | Deterministic Type Variable Set type DTyVarSet   = UniqDSet TyVar +-- | Deterministic Coercion Variable Set+type DCoVarSet   = UniqDSet CoVar+ -- | Deterministic Type or Coercion Variable Set type DTyCoVarSet = UniqDSet TyCoVar @@ -307,6 +310,9 @@  mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b mapDVarSet = mapUniqDSet++strictFoldDVarSet :: (a -> r -> r) -> r -> UniqDSet a -> r+strictFoldDVarSet = strictFoldUniqDSet  filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet filterDVarSet = filterUniqDSet
compiler/GHC/Unit.hs view
@@ -63,7 +63,7 @@  Certain libraries (ghc-prim, base, etc.) are known to the compiler and to the RTS as they provide some basic primitives.  Hence UnitIds of wired-in libraries-are fixed. Instead of letting Cabal chose the UnitId for these libraries, their+are fixed. Instead of letting Cabal choose the UnitId for these libraries, their .cabal file uses the following stanza to force it to a specific value:     ghc-options: -this-unit-id ghc-prim    -- taken from ghc-prim.cabal
compiler/GHC/Unit/Env.hs view
@@ -1,90 +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 GHC.Utils.Panic.Plain-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map import GHC.Utils.Misc (HasDebugCallStack)-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Utils.Outputable-import GHC.Utils.Panic (pprPanic)-import GHC.Unit.Module.ModIface-import GHC.Unit.Module-import qualified Data.Set as Set+import GHC.Utils.Panic +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.@@ -93,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] @@ -112,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",@@ -160,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 -> []@@ -182,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)} @@ -409,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@@ -465,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]@@ -596,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/External.hs view
@@ -28,9 +28,12 @@  import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch+import GHC.Types.DefaultEnv (DefaultEnv) import GHC.Types.TypeEnv import GHC.Types.Unique.DSet +import GHC.Linker.Types (Linkable)+ import Data.IORef  @@ -39,7 +42,7 @@ type PackageInstEnv          = InstEnv type PackageFamInstEnv       = FamInstEnv type PackageAnnEnv           = AnnEnv-type PackageCompleteMatches = CompleteMatches+type PackageCompleteMatches  = CompleteMatches  -- | Helps us find information about modules in the imported packages type PackageIfaceTable = ModuleEnv ModIface@@ -68,6 +71,7 @@   , eps_PIT              = emptyPackageIfaceTable   , eps_free_holes       = emptyInstalledModuleEnv   , eps_PTE              = emptyTypeEnv+  , eps_iface_bytecode   = emptyModuleEnv   , eps_inst_env         = emptyInstEnv   , eps_fam_inst_env     = emptyFamInstEnv   , eps_rule_base        = mkRuleBase builtinRules@@ -84,6 +88,7 @@                             , n_rules_in = length builtinRules                             , n_rules_out = 0                             }+  , eps_defaults         = emptyModuleEnv   }  @@ -139,6 +144,12 @@                 -- interface files we have sucked in. The domain of                 -- the mapping is external-package modules +        -- | If an interface was written with @-fwrite-if-simplified-core@, this+        -- will contain an IO action that compiles bytecode from core bindings.+        --+        -- See Note [Interface Files with Core Definitions]+        eps_iface_bytecode :: !(ModuleEnv (IO Linkable)),+         eps_inst_env     :: !PackageInstEnv,   -- ^ The total 'InstEnv' accumulated                                                -- from all the external-package modules         eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated@@ -154,7 +165,8 @@         eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external                                                          -- packages, keyed off the module that declared them -        eps_stats :: !EpsStats                 -- ^ Statistics about what was loaded from external packages+        eps_stats :: !EpsStats,                 -- ^ Statistics about what was loaded from external packages+        eps_defaults :: !(ModuleEnv DefaultEnv) -- ^ Default declarations exported by external packages   }  -- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.
compiler/GHC/Unit/Finder/Types.hs view
@@ -1,6 +1,7 @@ module GHC.Unit.Finder.Types    ( FinderCache (..)    , FinderCacheState+   , FileCacheState    , FindResult (..)    , InstalledFindResult (..)    , FinderOpts(..)@@ -9,11 +10,12 @@  import GHC.Prelude import GHC.Unit+import GHC.Data.OsPath import qualified Data.Map as M import GHC.Fingerprint import GHC.Platform.Ways+import GHC.Unit.Env -import Data.IORef import GHC.Data.FastString import qualified Data.Set as Set @@ -24,14 +26,23 @@ -- type FinderCacheState = InstalledModuleEnv InstalledFindResult type FileCacheState   = M.Map FilePath Fingerprint-data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)-                               , fcFileCache   :: (IORef FileCacheState)+data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()+                               -- ^ 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  :: InstalledModule -> InstalledFindResult -> IO ()+                               -- ^ Add a found location to the cache for the module.+                               , 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+                               -- cache. If the file doesn't exist, raise an IOException.                                }  data InstalledFindResult-  = InstalledFound ModLocation InstalledModule+  = InstalledFound ModLocation   | InstalledNoPackage UnitId-  | InstalledNotFound [FilePath] (Maybe UnitId)+  | InstalledNotFound [OsPath] (Maybe UnitId)  -- | The result of searching for an imported module. --@@ -70,7 +81,7 @@ -- -- Should be taken from 'DynFlags' via 'initFinderOpts'. data FinderOpts = FinderOpts-  { finder_importPaths :: [FilePath]+  { finder_importPaths :: [OsPath]       -- ^ Where are we allowed to look for Modules and Source files   , finder_lookupHomeInterfaces :: Bool       -- ^ When looking up a home module:@@ -88,17 +99,17 @@   , finder_enableSuggestions :: Bool       -- ^ If we encounter unknown modules, should we suggest modules       -- that have a similar name.-  , finder_workingDirectory :: Maybe FilePath+  , finder_workingDirectory :: Maybe OsPath   , finder_thisPackageName  :: Maybe FastString   , finder_hiddenModules    :: Set.Set ModuleName-  , finder_reexportedModules :: Set.Set ModuleName-  , finder_hieDir :: Maybe FilePath-  , finder_hieSuf :: String-  , finder_hiDir :: Maybe FilePath-  , finder_hiSuf :: String-  , finder_dynHiSuf :: String-  , finder_objectDir :: Maybe FilePath-  , finder_objectSuf :: String-  , finder_dynObjectSuf :: String-  , finder_stubDir :: Maybe FilePath-  } deriving Show+  , finder_reexportedModules :: M.Map ModuleName ModuleName -- Reverse mapping, if you are looking for this name then look for this module.+  , finder_hieDir :: Maybe OsPath+  , finder_hieSuf :: OsString+  , finder_hiDir :: Maybe OsPath+  , finder_hiSuf :: OsString+  , finder_dynHiSuf :: OsString+  , finder_objectDir :: Maybe OsPath+  , finder_objectSuf :: OsString+  , finder_dynObjectSuf :: OsString+  , finder_stubDir :: Maybe OsPath+  }
+ 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,23 +10,6 @@    , justBytecode    , justObjects    , bytecodeAndObjects-   , HomePackageTable-   , emptyHomePackageTable-   , lookupHpt-   , eltsHpt-   , filterHpt-   , allHpt-   , anyHpt-   , mapHpt-   , delFromHpt-   , addToHpt-   , addHomeModInfoToHpt-   , addListToHpt-   , lookupHptDirectly-   , lookupHptByModule-   , listToHpt-   , listHMIToHpt-   , pprHPT    ) where @@ -32,18 +17,13 @@  import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails-import GHC.Unit.Module -import GHC.Linker.Types ( Linkable(..), isObjectLinkable )--import GHC.Types.Unique-import GHC.Types.Unique.DFM+import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )  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@@ -90,17 +70,17 @@  justBytecode :: Linkable -> HomeModLinkable justBytecode lm =-  assertPpr (not (isObjectLinkable lm)) (ppr lm)+  assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)    $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }  justObjects :: Linkable -> HomeModLinkable justObjects lm =-  assertPpr (isObjectLinkable lm) (ppr lm)+  assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)    $ emptyHomeModInfoLinkable { homeMod_object = Just lm }  bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable bytecodeAndObjects bc o =-  assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o)+  assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)     (HomeModLinkable (Just bc) (Just o))  @@ -127,72 +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--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
@@ -234,10 +234,9 @@         -- will eventually be unused.         --         -- This change elevates the need to add custom hooks-        -- and handling specifically for the `rts` package for-        -- example in ghc-cabal.+        -- 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,28 +1,40 @@+{-# 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  import GHC.Prelude +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@@ -37,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`. --@@ -49,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).       --@@ -90,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@@ -102,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. --@@ -111,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@@ -131,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@@ -139,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           }@@ -159,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)@@ -186,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,@@ -229,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@@ -266,16 +333,16 @@             -- ^ 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     }   -- | A file upon which the module depends, e.g. a CPP #include, or using TH's   -- 'addDependentFile'   | UsageFile {-        usg_file_path  :: FilePath,+        usg_file_path  :: FastString,         -- ^ External file dependency. From a CPP #include or TH         -- addDependentFile. Should be absolute.         usg_file_hash  :: Fingerprint,@@ -324,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@@ -390,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@@ -488,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
@@ -6,6 +6,7 @@    , extendModuleEnvList_C, plusModuleEnv_C    , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv    , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv+   , alterModuleEnv    , partitionModuleEnv    , moduleEnvKeys, moduleEnvElts, moduleEnvToList    , unitModuleEnv, isEmptyModuleEnv@@ -146,6 +147,9 @@ partitionModuleEnv f (ModuleEnv e) = (ModuleEnv a, ModuleEnv b)   where     (a,b) = Map.partition f e++alterModuleEnv :: (Maybe a -> Maybe a) -> Module -> ModuleEnv a -> ModuleEnv a+alterModuleEnv f m (ModuleEnv e) = ModuleEnv (Map.alter f (NDModule m) e)  mkModuleEnv :: [(Module, a)] -> ModuleEnv a mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])
compiler/GHC/Unit/Module/Graph.hs view
@@ -2,386 +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--   , 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.Session--import GHC.Types.SourceFile ( hscSourceString )--import GHC.Unit.Module.ModSummary-import GHC.Unit.Types-import GHC.Utils.Outputable--import System.FilePath-import qualified Data.Map as Map-import GHC.Types.Unique.DSet-import qualified Data.Set as Set-import GHC.Unit.Module-import GHC.Linker.Static.Utils--import Data.Bifunctor-import Data.Either-import Data.Function-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 $ partitionEithers (map 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+-- | 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
@@ -13,10 +13,13 @@ import GHC.Types.Name.Reader import GHC.Types.SafeHaskell import GHC.Types.SrcLoc+import Data.Map (Map)  -- | Records the modules directly imported by a module for extracting e.g. -- usage information, and also to give better error message-type ImportedMods = ModuleEnv [ImportedBy]+type ImportedMods = Map Module [ImportedBy]+  -- We don't want to use a `ModuleEnv` since it would leak a non-deterministic+  -- order to the interface files when passed as a list to `mkUsageInfo`.  -- | If a module was "imported" by the user, we associate it with -- more detailed usage information 'ImportedModsVal'; a module@@ -39,6 +42,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
@@ -1,25 +1,40 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-} -- | Module location module GHC.Unit.Module.Location-   ( ModLocation(..)+   ( ModLocation+    ( ..+    , ml_hs_file+    , ml_hi_file+    , ml_dyn_hi_file+    , ml_obj_file+    , ml_dyn_obj_file+    , ml_hie_file+    )+   , pattern ModLocation    , addBootSuffix-   , addBootSuffix_maybe-   , addBootSuffixLocn_maybe    , addBootSuffixLocn    , addBootSuffixLocnOut    , removeBootSuffix+   , mkFileSrcSpan    ) where  import GHC.Prelude-import GHC.Unit.Types++import GHC.Data.OsPath+import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Data.FastString (mkFastString) +import qualified System.OsString as OsString+ -- | Module Location -- -- Where a module lives on the file system: the actual locations -- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them. ----- For a module in another unit, the ml_hs_file and ml_obj_file components of+-- For a module in another unit, the ml_hs_file_ospath and ml_obj_file_ospath components of -- ModLocation are undefined. -- -- The locations specified by a ModLocation may or may not@@ -38,31 +53,31 @@ -- boot suffixes in mkOneShotModLocation.  data ModLocation-   = ModLocation {-        ml_hs_file   :: Maybe FilePath,+   = OsPathModLocation {+        ml_hs_file_ospath   :: Maybe OsPath,                 -- ^ The source file, if we have one.  Package modules                 -- probably don't have source files. -        ml_hi_file   :: FilePath,+        ml_hi_file_ospath   :: OsPath,                 -- ^ Where the .hi file is, whether or not it exists                 -- yet.  Always of form foo.hi, even if there is an                 -- hi-boot file (we add the -boot suffix later) -        ml_dyn_hi_file :: FilePath,+        ml_dyn_hi_file_ospath :: OsPath,                 -- ^ Where the .dyn_hi file is, whether or not it exists                 -- yet. -        ml_obj_file  :: FilePath,+        ml_obj_file_ospath  :: OsPath,                 -- ^ Where the .o file is, whether or not it exists yet.                 -- (might not exist either because the module hasn't                 -- been compiled yet, or because it is part of a                 -- unit with a .a file) -        ml_dyn_obj_file :: FilePath,+        ml_dyn_obj_file_ospath :: OsPath,                 -- ^ Where the .dy file is, whether or not it exists                 -- yet. -        ml_hie_file  :: FilePath+        ml_hie_file_ospath  :: OsPath                 -- ^ Where the .hie file is, whether or not it exists                 -- yet.   } deriving Show@@ -71,46 +86,67 @@    ppr = text . show  -- | Add the @-boot@ suffix to .hs, .hi and .o files-addBootSuffix :: FilePath -> FilePath-addBootSuffix path = path ++ "-boot"+addBootSuffix :: OsPath -> OsPath+addBootSuffix path = path `mappend` os "-boot"  -- | Remove the @-boot@ suffix to .hs, .hi and .o files-removeBootSuffix :: FilePath -> FilePath-removeBootSuffix "-boot" = []-removeBootSuffix (x:xs)  = x : removeBootSuffix xs-removeBootSuffix []      = error "removeBootSuffix: no -boot suffix"----- | Add the @-boot@ suffix if the @Bool@ argument is @True@-addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath-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+removeBootSuffix :: OsPath -> OsPath+removeBootSuffix pathWithBootSuffix =+  case OsString.stripSuffix (os "-boot") pathWithBootSuffix of+    Just path -> path+    Nothing -> error "removeBootSuffix: no -boot suffix"  -- | Add the @-boot@ suffix to all file paths associated with the module addBootSuffixLocn :: ModLocation -> ModLocation addBootSuffixLocn locn-  = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)-         , ml_hi_file  = addBootSuffix (ml_hi_file locn)-         , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)-         , ml_obj_file = addBootSuffix (ml_obj_file locn)-         , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)-         , ml_hie_file = addBootSuffix (ml_hie_file 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 addBootSuffixLocnOut :: ModLocation -> ModLocation addBootSuffixLocnOut locn-  = locn { ml_hi_file  = addBootSuffix (ml_hi_file locn)-         , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)-         , ml_obj_file = addBootSuffix (ml_obj_file locn)-         , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)-         , ml_hie_file = addBootSuffix (ml_hie_file locn)+  = 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)          } +-- | Compute a 'SrcSpan' from a 'ModLocation'.+mkFileSrcSpan :: ModLocation -> SrcSpan+mkFileSrcSpan mod_loc+  = case ml_hs_file mod_loc of+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)+      Nothing        -> interactiveSrcSpan   -- Presumably +-- ----------------------------------------------------------------------------+-- Helpers for backwards compatibility+-- ----------------------------------------------------------------------------++{-# COMPLETE ModLocation #-}++pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation+pattern ModLocation+  { ml_hs_file+  , ml_hi_file+  , ml_dyn_hi_file+  , ml_obj_file+  , ml_dyn_obj_file+  , ml_hie_file+  } <- OsPathModLocation+    { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file)+    , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file)+    , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file)+    , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file)+    , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file)+    , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file)+    } where+      ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file+        = OsPathModLocation+          { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file+          , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file+          , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file+          , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file+          , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file+          , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file+          }
compiler/GHC/Unit/Module/ModDetails.hs view
@@ -10,6 +10,7 @@  import GHC.Types.Avail import GHC.Types.CompleteMatch+import GHC.Types.DefaultEnv import GHC.Types.TypeEnv import GHC.Types.Annotations ( Annotation ) @@ -23,6 +24,9 @@       -- ^ Local type environment for this particular module       -- Includes Ids, TyCons, PatSyns +   , md_defaults  :: !DefaultEnv+      -- ^ default declarations exported by this module+    , md_insts     :: InstEnv       -- ^ 'DFunId's for the instances in this module @@ -34,7 +38,7 @@       -- ^ Annotations present in this module: currently       -- they only annotate things also declared in this module -   , md_complete_matches :: [CompleteMatch]+   , md_complete_matches :: CompleteMatches       -- ^ Complete match pragmas for this module    } @@ -43,6 +47,7 @@ emptyModDetails = ModDetails    { md_types            = emptyTypeEnv    , md_exports          = []+   , md_defaults         = emptyDefaultEnv    , md_insts            = emptyInstEnv    , md_rules            = []    , md_fam_insts        = []
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@@ -27,6 +27,7 @@ import GHC.Types.Annotations ( Annotation ) import GHC.Types.Avail import GHC.Types.CompleteMatch+import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.ForeignStubs import GHC.Types.HpcInfo@@ -52,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**@@ -62,6 +62,7 @@                                          -- Used for creating interface files.         mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module                                          -- (includes TyCons for classes)+        mg_defaults  :: !DefaultEnv    , -- ^ Class defaults exported from this module         mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module         mg_fam_insts :: ![FamInst],                                          -- ^ Family instances declared in this module@@ -74,7 +75,7 @@         -- ^ Files to be compiled with the C compiler         mg_warns     :: !(Warnings GhcRn),  -- ^ Warnings declared in the module         mg_anns      :: [Annotation],    -- ^ Annotations declared in this module-        mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches+        mg_complete_matches :: CompleteMatches, -- ^ Complete Matches         mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module         mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module @@ -139,7 +140,6 @@         cg_foreign_files :: ![(ForeignSrcLang, FilePath)],         cg_dep_pkgs  :: !(Set UnitId),      -- ^ Dependent packages, used to                                             -- generate #includes for C code gen-        cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information         cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints         cg_spt_entries :: [SptEntry]                 -- ^ Static pointer table entries for static forms defined in
compiler/GHC/Unit/Module/ModIface.hs view
@@ -3,583 +3,1274 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}--module GHC.Unit.Module.ModIface-   ( ModIface-   , ModIface_ (..)-   , PartialModIface-   , ModIfaceBackend (..)-   , IfaceDeclExts-   , IfaceBackendExts-   , IfaceExport-   , WhetherHasOrphans-   , WhetherHasFamInst-   , 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.Types.Avail-import GHC.Types.Fixity-import GHC.Types.Fixity.Env-import GHC.Types.HpcInfo-import GHC.Types.Name-import GHC.Types.Name.Reader-import GHC.Types.SafeHaskell-import GHC.Types.SourceFile-import GHC.Types.Unique.DSet-import GHC.Types.Unique.FM--import GHC.Data.Maybe--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_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))-    -- ^ Cached lookup for 'mi_warns'-  , 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------ | 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.-data ModIface_ (phase :: ModIfacePhase)-  = ModIface {-        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--        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    :: (Warnings GhcRn),-                -- ^ 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_globals  :: !(Maybe GlobalRdrEnv),-                -- ^ Binds all the things defined at the top level 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.-     }--{--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 (ModIface {-                 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_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_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 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-        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 (ModIface {-                 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_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_globals     = Nothing,-                 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_warn_fn = mkIfaceWarnCache 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-  = ModIface { mi_module      = mod,-               mi_sig_of      = Nothing,-               mi_hsc_src     = HsSrcFile,-               mi_src_hash    = fingerprint0,-               mi_deps        = noDependencies,-               mi_usages      = [],-               mi_exports     = [],-               mi_used_th     = False,-               mi_fixities    = [],-               mi_warns       = NoWarnings,-               mi_anns        = [],-               mi_insts       = [],-               mi_fam_insts   = [],-               mi_rules       = [],-               mi_decls       = [],-               mi_extra_decls = Nothing,-               mi_globals     = 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_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_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 (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12-                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =-    rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`-    f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq`-    rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24-    `seq` ()---instance NFData (ModIfaceBackend) where-  rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)-    = 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` rnf f12 `seq` rnf f13---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---+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}++module GHC.Unit.Module.ModIface+   ( ModIface+   , 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_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
@@ -17,17 +17,24 @@    , msHsFilePath    , msObjFilePath    , msDynObjFilePath+   , msHsFileOsPath+   , msHiFileOsPath+   , msDynHiFileOsPath+   , msObjFileOsPath+   , msDynObjFileOsPath    , msDeps    , isBootSummary+   , isTemplateHaskellOrQQNonBoot    , findTarget    ) where  import GHC.Prelude +import qualified GHC.LanguageExtensions as LangExt import GHC.Hs -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Unit.Types import GHC.Unit.Module@@ -36,8 +43,10 @@ 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) import GHC.Data.StringBuffer ( StringBuffer )  import GHC.Utils.Fingerprint@@ -71,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.@@ -99,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@@ -140,29 +149,41 @@ -- 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 (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)+msDynObjFileOsPath ms = ml_dyn_obj_file_ospath (ms_location ms)+ -- | Did this 'ModSummary' originate from a hs-boot file? 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@@ -192,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/Module/Warnings.hs view
@@ -1,85 +1,268 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}  -- | Warnings for a module module GHC.Unit.Module.Warnings-   ( Warnings (..)+   ( WarningCategory(..)+   , mkWarningCategory+   , defaultWarningCategory+   , validWarningCategory+   , InWarningCategory(..)+   , fromWarningCategory++   , WarningCategorySet+   , emptyWarningCategorySet+   , completeWarningCategorySet+   , nullWarningCategorySet+   , elemWarningCategorySet+   , insertWarningCategorySet+   , deleteWarningCategorySet++   , Warnings (..)    , WarningTxt (..)+   , LWarningTxt+   , DeclWarnOccNames+   , ExportWarnNames+   , warningTxtCategory+   , warningTxtMessage+   , warningTxtSame    , pprWarningTxtForMsg-   , mkIfaceWarnCache+   , emptyWarn+   , mkIfaceDeclWarnCache+   , mkIfaceExportWarnCache    , emptyIfaceWarnCache-   , plusWarns+   , insertWarnDecls+   , insertWarnExports    ) where  import GHC.Prelude +import GHC.Data.FastString (FastString, mkFastString, unpackFS) import GHC.Types.SourceText import GHC.Types.Name.Occurrence+import GHC.Types.Name.Env+import GHC.Types.Name (Name) import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Unique.Set import GHC.Hs.Doc import GHC.Hs.Extension+import GHC.Parser.Annotation  import GHC.Utils.Outputable import GHC.Utils.Binary+import GHC.Unicode  import Language.Haskell.Syntax.Extension  import Data.Data+import Data.List (isPrefixOf) import GHC.Generics ( Generic )+import Control.DeepSeq ++{-+Note [Warning categories]+~~~~~~~~~~~~~~~~~~~~~~~~~+See GHC Proposal 541 for the design of the warning categories feature:+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst++A WARNING pragma may be annotated with a category such as "x-partial" written+after the 'in' keyword, like this:++    {-# WARNING in "x-partial" head "This function is partial..." #-}++This is represented by the 'Maybe (Located WarningCategory)' field in+'WarningTxt'.  The parser will accept an arbitrary string as the category name,+then the renamer (in 'rnWarningTxt') will check it contains only valid+characters, so we can generate a nicer error message than a parse error.++The corresponding warnings can then be controlled with the -Wx-partial,+-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags.  Such a flag is+distinguished from an 'unrecognisedWarning' by the flag parser testing+'validWarningCategory'.  The 'x-' prefix means we can still usually report an+unrecognised warning where the user has made a mistake.++A DEPRECATED pragma may not have a user-defined category, and is always treated+as belonging to the special category 'deprecations'.  Similarly, a WARNING+pragma without a category belongs to the 'deprecations' category.+Thus the '-Wdeprecations' flag will enable all of the following:++    {-# WARNING in "deprecations" foo "This function is deprecated..." #-}+    {-# WARNING foo "This function is deprecated..." #-}+    {-# DEPRECATED foo "This function is deprecated..." #-}++The '-Wwarnings-deprecations' flag is supported for backwards compatibility+purposes as being equivalent to '-Wdeprecations'.++The '-Wextended-warnings' warning group collects together all warnings with+user-defined categories, so they can be enabled or disabled+collectively. Moreover they are treated as being part of other warning groups+such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings').++'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal+warning categories, just as they do for the finite enumeration of 'WarningFlag's+built in to GHC.  These are represented as 'WarningCategorySet's to allow for+the possibility of them being infinite.++-}++data InWarningCategory+  = InWarningCategory+    { iwc_in :: !(EpToken "in"),+      iwc_st :: !SourceText,+      iwc_wc :: (LocatedE WarningCategory)+    } deriving Data++fromWarningCategory :: WarningCategory -> InWarningCategory+fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)+++-- See Note [Warning categories]+newtype WarningCategory = WarningCategory FastString+  deriving stock Data+  deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData)++mkWarningCategory :: FastString -> WarningCategory+mkWarningCategory = WarningCategory++-- | The @deprecations@ category is used for all DEPRECATED pragmas and for+-- WARNING pragmas that do not specify a category.+defaultWarningCategory :: WarningCategory+defaultWarningCategory = mkWarningCategory (mkFastString "deprecations")++-- | Is this warning category allowed to appear in user-defined WARNING pragmas?+-- It must either be the known category @deprecations@, or be a custom category+-- that begins with @x-@ and contains only valid characters (letters, numbers,+-- apostrophes and dashes).+validWarningCategory :: WarningCategory -> Bool+validWarningCategory cat@(WarningCategory c) =+    cat == defaultWarningCategory || ("x-" `isPrefixOf` s && all is_allowed s)+  where+    s = unpackFS c+    is_allowed c = isAlphaNum c || c == '\'' || c == '-'+++-- | A finite or infinite set of warning categories.+--+-- Unlike 'WarningFlag', there are (in principle) infinitely many warning+-- categories, so we cannot necessarily enumerate all of them. However the set+-- is constructed by adding or removing categories one at a time, so we can+-- represent it as either a finite set of categories, or a cofinite set (where+-- we store the complement).+data WarningCategorySet =+    FiniteWarningCategorySet   (UniqSet WarningCategory)+      -- ^ The set of warning categories is the given finite set.+  | CofiniteWarningCategorySet (UniqSet WarningCategory)+      -- ^ The set of warning categories is infinite, so the constructor stores+      -- its (finite) complement.++-- | The empty set of warning categories.+emptyWarningCategorySet :: WarningCategorySet+emptyWarningCategorySet = FiniteWarningCategorySet emptyUniqSet++-- | The set consisting of all possible warning categories.+completeWarningCategorySet :: WarningCategorySet+completeWarningCategorySet = CofiniteWarningCategorySet emptyUniqSet++-- | Is this set empty?+nullWarningCategorySet :: WarningCategorySet -> Bool+nullWarningCategorySet (FiniteWarningCategorySet s) = isEmptyUniqSet s+nullWarningCategorySet CofiniteWarningCategorySet{} = False++-- | Does this warning category belong to the set?+elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool+elemWarningCategorySet c (FiniteWarningCategorySet   s) =      c `elementOfUniqSet` s+elemWarningCategorySet c (CofiniteWarningCategorySet s) = not (c `elementOfUniqSet` s)++-- | Insert an element into a warning category set.+insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet+insertWarningCategorySet c (FiniteWarningCategorySet   s) = FiniteWarningCategorySet   (addOneToUniqSet   s c)+insertWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (delOneFromUniqSet s c)++-- | Delete an element from a warning category set.+deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet+deleteWarningCategorySet c (FiniteWarningCategorySet   s) = FiniteWarningCategorySet   (delOneFromUniqSet s c)+deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet   s c)++type LWarningTxt pass = XRec pass (WarningTxt pass)+ -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt pass    = WarningTxt-      (Located SourceText)-      [Located (WithHsDocIdentifiers StringLiteral pass)]+      (Maybe (LocatedE InWarningCategory))+        -- ^ Warning category attached to this WARNING pragma, if any;+        -- see Note [Warning categories]+      SourceText+      [LocatedE (WithHsDocIdentifiers StringLiteral pass)]    | DeprecatedTxt-      (Located SourceText)-      [Located (WithHsDocIdentifiers StringLiteral pass)]+      SourceText+      [LocatedE (WithHsDocIdentifiers StringLiteral pass)]   deriving Generic -deriving instance Eq (IdP pass) => Eq (WarningTxt pass)+-- | To which warning category does this WARNING or DEPRECATED pragma belong?+-- See Note [Warning categories].+warningTxtCategory :: WarningTxt pass -> WarningCategory+warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _  _ (L _ cat)))) _ _) = cat+warningTxtCategory _ = defaultWarningCategory++-- | The message that the WarningTxt was specified to output+warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)]+warningTxtMessage (WarningTxt _ _ m) = m+warningTxtMessage (DeprecatedTxt _ m) = m++-- | True if the 2 WarningTxts have the same category and messages+warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool+warningTxtSame w1 w2+  = warningTxtCategory w1 == warningTxtCategory w2+  && literal_message w1 == literal_message w2+  && same_type+  where+    literal_message :: WarningTxt p -> [StringLiteral]+    literal_message = map (hsDocString . unLoc) . warningTxtMessage+    same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True+              | WarningTxt {} <- w1, WarningTxt {} <- w2       = True+              | otherwise                                      = False++deriving instance Eq InWarningCategory++deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) -instance Outputable (WarningTxt pass) where-    ppr (WarningTxt    lsrc ws)-      = case unLoc lsrc of-          NoSourceText   -> pp_ws ws-          SourceText src -> text src <+> pp_ws ws <+> text "#-}"+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP -    ppr (DeprecatedTxt lsrc  ds)-      = case unLoc lsrc of-          NoSourceText   -> pp_ws ds-          SourceText src -> text src <+> pp_ws ds <+> text "#-}"+instance Outputable InWarningCategory where+  ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) -instance Binary (WarningTxt GhcRn) where-    put_ bh (WarningTxt s w) = do-            putByte bh 0-            put_ bh $ unLoc s-            put_ bh $ unLoc <$> w-    put_ bh (DeprecatedTxt s d) = do-            putByte bh 1-            put_ bh $ unLoc s-            put_ bh $ unLoc <$> d -    get bh = do-            h <- getByte bh-            case h of-              0 -> do s <- noLoc <$> get bh-                      w <- fmap noLoc  <$> get bh-                      return (WarningTxt s w)-              _ -> do s <- noLoc <$> get bh-                      d <- fmap noLoc <$> get bh-                      return (DeprecatedTxt s d)+instance Outputable (WarningTxt pass) where+    ppr (WarningTxt mcat lsrc ws)+      = case lsrc of+            NoSourceText   -> pp_ws ws+            SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"+        where+          ctg_doc = maybe empty (\ctg -> ppr ctg) mcat  -pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc+    ppr (DeprecatedTxt lsrc  ds)+      = case lsrc of+          NoSourceText   -> pp_ws ds+          SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"++pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws   = text "["@@ -88,20 +271,20 @@   pprWarningTxtForMsg :: WarningTxt p -> SDoc-pprWarningTxtForMsg (WarningTxt    _ ws)+pprWarningTxtForMsg (WarningTxt _ _ ws)                      = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds)                      = text "Deprecated:" <+>                        doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds))  --- | Warning information for a module+-- | Warning information from a module data Warnings pass-  = NoWarnings                          -- ^ Nothing deprecated-  | WarnAll (WarningTxt pass)                  -- ^ Whole module deprecated-  | WarnSome [(OccName,WarningTxt pass)]     -- ^ Some specific things deprecated+  = WarnSome (DeclWarnOccNames pass) -- ^ Names deprecated (may be empty)+             (ExportWarnNames pass)  -- ^ Exports deprecated (may be empty)+  | WarnAll (WarningTxt pass)        -- ^ Whole module deprecated -     -- Only an OccName is needed because+     -- For the module-specific names only an OccName is needed because      --    (1) a deprecation always applies to a binding      --        defined in the module in which the deprecation appears.      --    (2) deprecations are only reported outside the defining module.@@ -121,40 +304,44 @@      --      --        this is in contrast with fixity declarations, where we need to map      --        a Name to its fixity declaration.+     --+     -- For export deprecations we need to know where the symbol comes from, since+     -- we need to be able to check if the deprecated export that was imported is+     -- the same thing as imported by another import, which would not trigger+     -- a deprecation message. +-- | Deprecated declarations+type DeclWarnOccNames pass = [(OccName, WarningTxt pass)]++-- | Names that are deprecated as exports+type ExportWarnNames pass = [(Name, WarningTxt pass)]+ deriving instance Eq (IdP pass) => Eq (Warnings pass) -instance Binary (Warnings GhcRn) where-    put_ bh NoWarnings     = putByte bh 0-    put_ bh (WarnAll t) = do-            putByte bh 1-            put_ bh t-    put_ bh (WarnSome ts) = do-            putByte bh 2-            put_ bh ts+emptyWarn :: Warnings p+emptyWarn = WarnSome [] [] -    get bh = do-            h <- getByte bh-            case h of-              0 -> return NoWarnings-              1 -> do aa <- get bh-                      return (WarnAll aa)-              _ -> do aa <- get bh-                      return (WarnSome aa)+-- | Constructs the cache for the 'mi_decl_warn_fn' field of a 'ModIface'+mkIfaceDeclWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)+mkIfaceDeclWarnCache (WarnAll t) = \_ -> Just t+mkIfaceDeclWarnCache (WarnSome vs _) = lookupOccEnv (mkOccEnv vs) --- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'-mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)-mkIfaceWarnCache NoWarnings  = \_ -> Nothing-mkIfaceWarnCache (WarnAll t) = \_ -> Just t-mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)+-- | Constructs the cache for the 'mi_export_warn_fn' field of a 'ModIface'+mkIfaceExportWarnCache :: Warnings p -> Name -> Maybe (WarningTxt p)+mkIfaceExportWarnCache (WarnAll _) = const Nothing -- We do not want a double report of the module deprecation+mkIfaceExportWarnCache (WarnSome _ ds) = lookupNameEnv (mkNameEnv ds) -emptyIfaceWarnCache :: OccName -> Maybe (WarningTxt p)+emptyIfaceWarnCache :: name -> Maybe (WarningTxt p) emptyIfaceWarnCache _ = Nothing -plusWarns :: Warnings p -> Warnings p -> Warnings p-plusWarns d NoWarnings = d-plusWarns NoWarnings d = d-plusWarns _ (WarnAll t) = WarnAll t-plusWarns (WarnAll t) _ = WarnAll t-plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)+insertWarnDecls :: Warnings p                -- ^ Existing warnings+                -> [(OccName, WarningTxt p)] -- ^ New declaration deprecations+                -> Warnings p                -- ^ Updated warnings+insertWarnDecls ws@(WarnAll _) _        = ws+insertWarnDecls (WarnSome wns wes) wns' = WarnSome (wns ++ wns') wes +insertWarnExports :: Warnings p             -- ^ Existing warnings+                  -> [(Name, WarningTxt p)] -- ^ New export deprecations+                  -> Warnings p             -- ^ Updated warnings+insertWarnExports ws@(WarnAll _) _ = ws+insertWarnExports (WarnSome wns wes) wes' = WarnSome wns (wes ++ wes')
compiler/GHC/Unit/Module/WholeCoreBindings.hs view
@@ -1,17 +1,39 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE DuplicateRecordFields #-}+ module GHC.Unit.Module.WholeCoreBindings where -import GHC.Unit.Types (Module)-import GHC.Unit.Module.Location+import GHC.Cmm.CLabel+import GHC.Driver.DynFlags (DynFlags (targetPlatform), initSDocContext)+import GHC.ForeignSrcLang (ForeignSrcLang (..)) import GHC.Iface.Syntax+import GHC.Prelude+import GHC.Types.ForeignStubs+import GHC.Unit.Module.Location+import GHC.Unit.Types (Module)+import GHC.Utils.Binary+import GHC.Utils.Error (debugTraceMsg)+import GHC.Utils.Logger (Logger)+import GHC.Utils.Outputable+import GHC.Utils.Panic (panic, pprPanic)+import GHC.Utils.TmpFs +import Control.DeepSeq (NFData (..))+import Data.Traversable (for)+import Data.Word (Word8)+import Data.Maybe (fromMaybe)+import System.FilePath (takeExtension)+ {- Note [Interface Files with Core Definitions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  A interface file can optionally contain the definitions of all core bindings, this is enabled by the flag `-fwrite-if-simplified-core`. This provides everything needed in addition to the normal ModIface and ModDetails-to restart compilation after typechecking to generate bytecode. The `fi_bindings` field+to restart compilation after typechecking to generate bytecode. The `wcb_bindings` field is stored in the normal interface file and the other fields populated whilst loading the interface file. @@ -24,14 +46,14 @@    the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also    allows us to convert the WholeCoreBindings into multiple different linkables if we so desired. -2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCO linkable. This step combines together+2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCOs linkable. This step combines together    all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to-   create the linkable. The linkable created is a "LoadedBCOs" linkable, which-   was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazilly.+   create the linkable. The linkable created is a "LazyBCOs" linkable, which+   was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazily.    Using the `BCOs` constructor directly here leads to the bytecode being forced    too eagerly. -3. Then when bytecode is needed, the LoadedBCOs value is inspected and unpacked and+3. Then when bytecode is needed, the LazyBCOs value is inspected and unpacked and    the linkable is used as before.  The flag `-fwrite-if-simplified-core` determines whether the extra information is written@@ -40,8 +62,55 @@ of the interface file agree with the optimisation level as reported by the interface file. +The lifecycle differs beyond laziness depending on the provenance of a module.+In all cases, the main consumer for interface bytecode is 'get_link_deps', which+traverses a splice's or GHCi expression's dependencies and collects the needed+build artifacts, which can be objects or bytecode, depending on the build+settings.++1. In make mode, all eligible modules are part of the dependency graph.+   Their interfaces are loaded unconditionally and in dependency order by the+   compilation manager, and each module's bytecode is prepared before its+   dependents are compiled, in one of two ways:++   - If the interface file for a module is missing or out of sync with its+     source, it is recompiled and bytecode is generated directly and+     immediately, not involving 'WholeCoreBindings' (in 'runHscBackendPhase').++   - If the interface file is up to date, no compilation is performed, and a+     lazy thunk generating bytecode from interface Core bindings is created in+     'compileOne'', which will only be compiled if a downstream module contains+     a splice that depends on it, as described above.++   In both cases, the bytecode 'Linkable' is stored in a 'HomeModLinkable' in+   the Home Unit Graph, lazy or not.++2. In oneshot mode, which compiles individual modules without a shared home unit+   graph, a previously compiled module is not reprocessed as described for make+   mode above.+   When 'get_link_deps' encounters a dependency on a local module, it requests+   its bytecode from the External Package State, who loads the interface+   on-demand.++   Since the EPS stores interfaces for all package dependencies in addition to+   local modules in oneshot mode, it has a substantial memory footprint.+   We try to curtail that by extracting important data into specialized fields+   in the EPS, and retaining only a few fields of 'ModIface' by overwriting the+   others with bottom values.++   In order to avoid keeping around all of the interface's components needed for+   compiling bytecode, we instead store an IO action in 'eps_iface_bytecode'.+   When 'get_link_deps' evaluates this action, the result is not retained in the+   EPS, but stored in 'LoaderState', where it may eventually get evicted to free+   up the memory.+   This IO action retains the dehydrated Core bindings from the interface in its+   closure.+   Like the bytecode 'Linkable' stored in 'LoaderState', this is preferable to+   storing the intermediate representation as rehydrated Core bindings, since+   the latter have a significantly greater memory footprint.+ Note [Size of Interface Files with Core Definitions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  How much overhead does `-fwrite-if-simplified-core` add to a typical interface file? As an experiment I compiled the `Cabal` library and `ghc` library (Aug 22) with@@ -60,4 +129,375 @@             { wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ serialised tidied core bindings.             , wcb_module   :: Module  -- ^ The module which the bindings are for             , wcb_mod_location :: ModLocation -- ^ The location where the sources reside.+              -- | Stubs for foreign declarations and files added via+              -- 'GHC.Internal.TH.Syntax.addForeignFilePath'.+            , wcb_foreign :: IfaceForeign             }++{-+Note [Foreign stubs and TH bytecode linking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Foreign declarations may introduce additional build products called "stubs" that+contain wrappers for the exposed functions.+For example, consider a foreign import of a C function named @main_loop@ from+the file @bindings.h@ in the module @CLibrary@:++@+foreign import capi "bindings.h main_loop" mainLoop :: IO Int+@++GHC will generate a snippet of C code containing a wrapper:++@+#include "bindings.h"+HsInt ghczuwrapperZC0ZCmainZCCLibraryZCmainzuloop(void) {return main_loop();}+@++Wrappers like these are generated as 'ForeignStubs' by the desugarer in+'dsForeign' and stored in the various @*Guts@ types; until they are compiled to+temporary object files in 'runHscBackendPhase' during code generation and+ultimately merged into the final object file for the module, @CLibrary.o@.++This creates some problems with @-fprefer-byte-code@, which allows splices to+execute bytecode instead of native code for dependencies that provide it.+Usually, when some TH code depends on @CLibrary@, the linker would look for+@CLibrary.o@ and load that before executing the splice, but with this flag, it+will first attempt to load bytecode from @CLibrary.hi@ and compile it in-memory.++Problem 1:++Code for splices is loaded from interfaces in the shape of Core bindings+(see 'WholeCoreBindings'), rather than from object files.+Those Core bindings are intermediate build products that do not contain the+module's stubs, since those are separated from the Haskell code before Core is+generated and only compiled and linked into the final object when native code is+generated.++Therefore, stubs have to be stored separately in interface files.+Unfortunately, the type 'ForeignStubs' contains 'CLabel', which is a huge type+with several 'Unique's used mainly by C--.+Luckily, the only constructor used for foreign stubs is 'ModuleLabel', which+contains the name of a foreign declaration's initializer, if it has one.+So we convert a 'CLabel' to 'CStubLabel' in 'encodeIfaceForeign' and store only+the simplified data.++Problem 2:++Given module B, which contains a splice that executes code from module A, both+in the home package, consider these different circumstances:++1. In make mode, both modules are recompiled+2. In make mode, only B is recompiled+3. In oneshot mode, B is compiled++In case 1, 'runHscBackendPhase' directly generates bytecode from the 'CgGuts'+that the main pipeline produced and stores it in the 'HomeModLinkable' that is+one of its build products.+The stubs are merged into a single object and added to the 'HomeModLinkable' in+'hscGenBackendPipeline'.++In case 2, 'hscRecompStatus' short-circuits the pipeline while checking A, since+the module is up to date.+Nevertheless, it calls 'checkByteCode', which extracts Core bindings from A's+interface and adds them to the 'HomeModLinkable'.+No stubs are generated in this case, since the desugarer wasn't run!++In both of these cases, 'compileOne'' proceeds to call 'initWholeCoreBindings',+applied to the 'HomeModLinkable', to compile Core bindings (lazily) to bytecode,+which is then written back to the 'HomeModLinkable'.+If the 'HomeModLinkable' already contains bytecode (case 1), this is a no-op.+Otherwise, the stub objects from the interface are compiled to objects in+'generateByteCode' and added to the 'HomeModLinkable' as well.++Case 3 is not implemented yet (!13042).++Problem 3:++In all three cases, the final step before splice execution is linking.++The function 'getLinkDeps' is responsible for assembling all of a splice's+dependencies, looking up imported modules in the HPT and EPS, collecting all+'HomeModLinkable's and object files that it can find.++However, since splices are executed in the interpreter, the 'Way' of the current+build may differ from the interpreter's.+For example, the current GHC invocation might be building a static binary, but+the internal interpreter requires dynamic linking; or profiling might be+enabled.+To adapt to the interpreter's 'Way', 'getLinkDeps' substitutes all object files'+extensions with that corresponding to that 'Way' – e.g. changing @.o@ to+@.dyn_o@, which requires dependencies to be built with @-dynamic[-too]@, which+in turn is enforced after downsweep in 'GHC.Driver.Make.enableCodeGenWhen'.++This doesn't work for stub objects, though – they are compiled to temporary+files with mismatching names, so simply switching out the suffix would refer to+a nonexisting file.+Even if that wasn't an issue, they are compiled for the session's 'Way', not its+associated module's, so the dynamic variant wouldn't be available when building+only static outputs.++To mitigate this, we instead build foreign objects specially for the+interpreter, updating the build flags in 'compile_for_interpreter' to use the+interpreter's way.++Problem 4:++Foreign code may have dependencies on Haskell code.++Both foreign exports and @StaticPointers@ produce stubs that contain @extern@+declarations of values referring to STG closures.+When those stub objects are loaded, the undefined symbols need to be provided to+the linker.++I have no insight into how this works, and whether we could provide the memory+address of a BCO as a ccall symbol while linking, so it's unclear at the moment+what to do about this.++In addition to that, those objects would also have to be loaded _after_+bytecode, and therefore 'DotO' would have to be marked additionally to separate+them from those that are loaded before.+If mutual dependencies between BCOs and foreign code are possible, this will be+much more diffcult though.++Problem 5:++TH allows splices to add arbitrary files as additional linker inputs.++Using the method `qAddForeignFilePath`, a foreign source file or a precompiled+object file can be added to the current modules dependencies.+These files will be processed by the pipeline and linked into the final object.++Since the files may be temporarily created from a string, we have to read their+contents in 'encodeIfaceForeign' and store them in the interface as well, and+write them to temporary files when loading bytecode in 'decodeIfaceForeign'.+-}++-- | Wrapper for avoiding a dependency on 'Binary' and 'NFData' in 'CLabel'.+newtype IfaceCLabel = IfaceCLabel CStubLabel++instance Binary IfaceCLabel where+  get bh = do+    csl_is_initializer <- get bh+    csl_module <- get bh+    csl_name <- get bh+    pure (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name})++  put_ bh (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) = do+    put_ bh csl_is_initializer+    put_ bh csl_module+    put_ bh csl_name++instance NFData IfaceCLabel where+  rnf (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) =+    rnf csl_is_initializer `seq` rnf csl_module `seq` rnf csl_name++instance Outputable IfaceCLabel where+  ppr (IfaceCLabel l) = ppr l++-- | Simplified encoding of 'GHC.Types.ForeignStubs.ForeignStubs' for interface+-- serialization.+--+-- See Note [Foreign stubs and TH bytecode linking]+data IfaceCStubs =+  IfaceCStubs {+    header :: String,+    source :: String,+    initializers :: [IfaceCLabel],+    finalizers :: [IfaceCLabel]+  }++instance Outputable IfaceCStubs where+  ppr IfaceCStubs {header, source, initializers, finalizers} =+    vcat [+      hang (text "header:") 2 (vcat (text <$> lines header)),+      hang (text "source:") 2 (vcat (text <$> lines source)),+      hang (text "initializers:") 2 (ppr initializers),+      hang (text "finalizers:") 2 (ppr finalizers)+    ]++-- | 'Binary' 'put_' for 'ForeignSrcLang'.+binary_put_ForeignSrcLang :: WriteBinHandle -> ForeignSrcLang -> IO ()+binary_put_ForeignSrcLang bh lang =+  put_ @Word8 bh $ case lang of+    LangC -> 0+    LangCxx -> 1+    LangObjc -> 2+    LangObjcxx -> 3+    LangAsm -> 4+    LangJs -> 5+    RawObject -> 6++-- | 'Binary' 'get' for 'ForeignSrcLang'.+binary_get_ForeignSrcLang :: ReadBinHandle -> IO ForeignSrcLang+binary_get_ForeignSrcLang bh = do+  b <- getByte bh+  pure $ case b of+    0 -> LangC+    1 -> LangCxx+    2 -> LangObjc+    3 -> LangObjcxx+    4 -> LangAsm+    5 -> LangJs+    6 -> RawObject+    _ -> panic "invalid Binary value for ForeignSrcLang"++instance Binary IfaceCStubs where+  get bh = do+    header <- get bh+    source <- get bh+    initializers <- get bh+    finalizers <- get bh+    pure IfaceCStubs {..}++  put_ bh IfaceCStubs {..} = do+    put_ bh header+    put_ bh source+    put_ bh initializers+    put_ bh finalizers++instance NFData IfaceCStubs where+  rnf IfaceCStubs {..} =+    rnf header+    `seq`+    rnf source+    `seq`+    rnf initializers+    `seq`+    rnf finalizers++-- | A source file added from Template Haskell using 'qAddForeignFilePath', for+-- storage in interfaces.+--+-- See Note [Foreign stubs and TH bytecode linking]+data IfaceForeignFile =+  IfaceForeignFile {+    -- | The language is specified by the user.+    lang :: ForeignSrcLang,++    -- | The contents of the file, which will be written to a temporary file+    -- when loaded from an interface.+    source :: String,++    -- | The extension used by the user is preserved, to avoid confusing+    -- external tools with an unexpected @.c@ file or similar.+    extension :: FilePath+  }++instance Outputable IfaceForeignFile where+  ppr IfaceForeignFile {lang, source} =+    hang (text (show lang) <> colon) 2 (vcat (text <$> lines source))++instance Binary IfaceForeignFile where+  get bh = do+    lang <- binary_get_ForeignSrcLang bh+    source <- get bh+    extension <- get bh+    pure IfaceForeignFile {lang, source, extension}++  put_ bh IfaceForeignFile {lang, source, extension} = do+    binary_put_ForeignSrcLang bh lang+    put_ bh source+    put_ bh extension++instance NFData IfaceForeignFile where+  rnf IfaceForeignFile {lang, source, extension} =+    lang `seq` rnf source `seq` rnf extension++data IfaceForeign =+  IfaceForeign {+    stubs :: Maybe IfaceCStubs,+    files :: [IfaceForeignFile]+  }++instance Outputable IfaceForeign where+  ppr IfaceForeign {stubs, files} =+    hang (text "stubs:") 2 (maybe (text "empty") ppr stubs) $$+    vcat (ppr <$> files)++emptyIfaceForeign :: IfaceForeign+emptyIfaceForeign = IfaceForeign {stubs = Nothing, files = []}++-- | Convert foreign stubs and foreign files to a format suitable for writing to+-- interfaces.+--+-- See Note [Foreign stubs and TH bytecode linking]+encodeIfaceForeign ::+  Logger ->+  DynFlags ->+  ForeignStubs ->+  [(ForeignSrcLang, FilePath)] ->+  IO IfaceForeign+encodeIfaceForeign logger dflags foreign_stubs lang_paths = do+  files <- read_foreign_files+  stubs <- encode_stubs foreign_stubs+  let iff = IfaceForeign {stubs, files}+  debugTraceMsg logger 3 $+    hang (text "Encoding foreign data for iface:") 2 (ppr iff)+  pure iff+  where+    -- We can't just store the paths, since files may have been generated with+    -- GHC session lifetime in 'GHC.Internal.TH.Syntax.addForeignSource'.+    read_foreign_files =+      for lang_paths $ \ (lang, path) -> do+        source <- readFile path+        pure IfaceForeignFile {lang, source, extension = takeExtension path}++    encode_stubs = \case+      NoStubs ->+        pure Nothing+      ForeignStubs (CHeader header) (CStub source inits finals) ->+        pure $ Just IfaceCStubs {+          header = render header,+          source = render source,+          initializers = encode_label <$> inits,+          finalizers = encode_label <$> finals+        }++    encode_label clabel =+      fromMaybe (invalid_label clabel) (IfaceCLabel <$> cStubLabel clabel)++    invalid_label clabel =+      pprPanic+      "-fwrite-if-simplified-core is incompatible with this foreign stub:"+      (pprCLabel (targetPlatform dflags) clabel)++    render = renderWithContext (initSDocContext dflags PprCode)++-- | Decode serialized foreign stubs and foreign files.+--+-- See Note [Foreign stubs and TH bytecode linking]+decodeIfaceForeign ::+  Logger ->+  TmpFs ->+  TempDir ->+  IfaceForeign ->+  IO (ForeignStubs, [(ForeignSrcLang, FilePath)])+decodeIfaceForeign logger tmpfs tmp_dir iff@IfaceForeign {stubs, files} = do+  debugTraceMsg logger 3 $+    hang (text "Decoding foreign data from iface:") 2 (ppr iff)+  lang_paths <- for files $ \ IfaceForeignFile {lang, source, extension} -> do+    f <- newTempName logger tmpfs tmp_dir TFL_GhcSession extension+    writeFile f source+    pure (lang, f)+  pure (maybe NoStubs decode_stubs stubs, lang_paths)+  where+    decode_stubs IfaceCStubs {header, source, initializers, finalizers} =+      ForeignStubs+      (CHeader (text header))+      (CStub (text source) (labels initializers) (labels finalizers))++    labels ls = [fromCStubLabel l | IfaceCLabel l <- ls]++instance Binary IfaceForeign where+  get bh = do+    stubs <- get bh+    files <- get bh+    pure IfaceForeign {stubs, files}++  put_ bh IfaceForeign {stubs, files} = do+    put_ bh stubs+    put_ bh files++instance NFData IfaceForeign where+  rnf IfaceForeign {stubs, files} = rnf stubs `seq` rnf files
compiler/GHC/Unit/State.hs view
@@ -1,8 +1,6 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}  -- | Unit manipulation module GHC.Unit.State (@@ -68,15 +66,15 @@         pprUnitInfoForUser,         pprModuleMap,         pprWithUnitState,+        pprRawUnitIds,          -- * Utils-        unwireUnit,-        implicitPackageDeps)+        unwireUnit) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Platform import GHC.Platform.Ways@@ -92,6 +90,8 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet+import GHC.Types.Unique.Map+import GHC.Types.Unique import GHC.Types.PkgQual  import GHC.Utils.Misc@@ -111,15 +111,11 @@ import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper )-import Data.List ( intersperse, partition, sortBy, isSuffixOf )-import Data.Map (Map)+import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn ) import Data.Set (Set) import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup-import qualified Data.Map as Map-import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set-import GHC.LanguageExtensions import Control.Applicative  -- ---------------------------------------------------------------------------@@ -271,7 +267,7 @@ type PreloadUnitClosure = UniqSet UnitId  -- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.-type VisibilityMap = Map Unit UnitVisibility+type VisibilityMap = UniqMap Unit UnitVisibility  -- | 'UnitVisibility' records the various aspects of visibility of a particular -- 'Unit'.@@ -285,7 +281,7 @@       -- ^ The package name associated with the 'Unit'.  This is used       -- to implement legacy behavior where @-package foo-0.1@ implicitly       -- hides any packages named @foo@-    , uv_requirements :: Map ModuleName (Set InstantiatedModule)+    , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)       -- ^ The signatures which are contributed to the requirements context       -- from this unit ID.     , uv_explicit :: Maybe PackageArg@@ -309,7 +305,7 @@           { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2           , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2           , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)-          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)+          , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1)           , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2           } @@ -318,7 +314,7 @@              { uv_expose_all = False              , uv_renamings = []              , uv_package_name = First Nothing-             , uv_requirements = Map.empty+             , uv_requirements = emptyUniqMap              , uv_explicit = Nothing              }     mappend = (Semigroup.<>)@@ -369,9 +365,13 @@         autoLink          | not (gopt Opt_AutoLinkPackages dflags) = []-         -- By default we add base & 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 /=) [baseUnitId, 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@@ -418,7 +418,7 @@ -- origin for a given 'Module'  type ModuleNameProvidersMap =-    Map ModuleName (Map Module ModuleOrigin)+    UniqMap ModuleName (UniqMap Module ModuleOrigin)  data UnitState = UnitState {   -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted@@ -442,10 +442,10 @@   packageNameMap            :: UniqFM PackageName UnitId,    -- | A mapping from database unit keys to wired in unit ids.-  wireMap :: Map UnitId UnitId,+  wireMap :: UniqMap UnitId UnitId,    -- | A mapping from wired in unit ids to unit keys from the database.-  unwireMap :: Map UnitId UnitId,+  unwireMap :: UniqMap UnitId UnitId,    -- | The units we're going to link in eagerly.  This list   -- should be in reverse dependency order; that is, a unit@@ -475,7 +475,7 @@   -- and @r[C=\<A>]:C@.   --   -- There's an entry in this map for each hole in our home library.-  requirementContext :: Map ModuleName [InstantiatedModule],+  requirementContext :: UniqMap ModuleName [InstantiatedModule],    -- | Indicate if we can instantiate units on-the-fly.   --@@ -486,17 +486,17 @@  emptyUnitState :: UnitState emptyUnitState = UnitState {-    unitInfoMap = Map.empty,+    unitInfoMap    = emptyUniqMap,     preloadClosure = emptyUniqSet,     packageNameMap = emptyUFM,-    wireMap   = Map.empty,-    unwireMap = Map.empty,-    preloadUnits = [],-    explicitUnits = [],+    wireMap        = emptyUniqMap,+    unwireMap      = emptyUniqMap,+    preloadUnits   = [],+    explicitUnits  = [],     homeUnitDepends = [],-    moduleNameProvidersMap = Map.empty,-    pluginModuleNameProvidersMap = Map.empty,-    requirementContext = Map.empty,+    moduleNameProvidersMap       = emptyUniqMap,+    pluginModuleNameProvidersMap = emptyUniqMap,+    requirementContext           = emptyUniqMap,     allowVirtualUnits = False     } @@ -509,7 +509,7 @@ instance Outputable u => Outputable (UnitDatabase u) where   ppr (UnitDatabase fp _u) = text "DB:" <+> text fp -type UnitInfoMap = Map UnitId UnitInfo+type UnitInfoMap = UniqMap UnitId UnitInfo  -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo@@ -525,20 +525,20 @@ lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of    HoleUnit   -> error "Hole unit"-   RealUnit i -> Map.lookup (unDefinite i) pkg_map+   RealUnit i -> lookupUniqMap pkg_map (unDefinite i)    VirtUnit i       | allowOnTheFlyInst       -> -- lookup UnitInfo of the indefinite unit to be instantiated and          -- instantiate it on-the-fly          fmap (renameUnitInfo pkg_map closure (instUnitInsts i))-           (Map.lookup (instUnitInstanceOf i) pkg_map)+           (lookupUniqMap pkg_map (instUnitInstanceOf i))        | otherwise       -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite          -- units. Even if they are real, installed units, they can't use the          -- `RealUnit` constructor (it is reserved for definite units) so we use          -- the `VirtUnit` constructor.-         Map.lookup (virtualUnitId i) pkg_map+         lookupUniqMap pkg_map (virtualUnitId i)  -- | Find the unit we know about with the given unit id, if any lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo@@ -546,7 +546,7 @@  -- | Find the unit we know about with the given unit id, if any lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo-lookupUnitId' db uid = Map.lookup uid db+lookupUnitId' db uid = lookupUniqMap db uid   -- | Looks up the given unit in the unit state, panicking if it is not found@@ -580,12 +580,12 @@ resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId resolvePackageImport unit_st mn pn = do   -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)-  providers <- Map.filter originVisible <$> Map.lookup mn (moduleNameProvidersMap unit_st)+  providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn   -- 2. Get the UnitIds of the candidates-  let candidates_uid = concatMap to_uid $ Map.assocs providers+  let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers   -- 3. Get the package names of the candidates   let candidates_units = map (\ui -> ((unitPackageName ui), unitId ui))-                              $ mapMaybe (\uid -> Map.lookup uid (unitInfoMap unit_st)) candidates_uid+                              $ mapMaybe (\uid -> lookupUniqMap (unitInfoMap unit_st) uid) candidates_uid   -- 4. Check to see if the PackageName helps us disambiguate any candidates.   lookup pn candidates_units @@ -611,23 +611,22 @@ -- with module holes). -- mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap-mkUnitInfoMap infos = foldl' add Map.empty infos+mkUnitInfoMap infos = foldl' add emptyUniqMap infos   where    mkVirt      p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p))    add pkg_map p       | not (null (unitInstantiations p))-      = Map.insert (mkVirt p) p-         $ Map.insert (unitId p) p-         $ pkg_map+      = addToUniqMap (addToUniqMap pkg_map (mkVirt p) p)+                     (unitId p) p       | otherwise-      = Map.insert (unitId p) p pkg_map+      = addToUniqMap pkg_map (unitId p) p  -- | Get a list of entries from the unit database.  NB: be careful with -- this function, although all units in this map are "visible", this -- does not imply that the exposed-modules of the unit are available -- (they may have been thinned or renamed). listUnitInfo :: UnitState -> [UnitInfo]-listUnitInfo state = Map.elems (unitInfoMap state)+listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)  -- ---------------------------------------------------------------------------- -- Loading the unit db files and building up the unit state@@ -915,20 +914,20 @@            -- This method is responsible for computing what our            -- inherited requirements are.            reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid-                | otherwise                 = Map.empty+                | otherwise                 = emptyUniqMap             collectHoles uid = case uid of-             HoleUnit       -> Map.empty-             RealUnit {}    -> Map.empty -- definite units don't have holes+             HoleUnit       -> emptyUniqMap+             RealUnit {}    -> emptyUniqMap -- definite units don't have holes              VirtUnit indef ->-                  let local = [ Map.singleton+                  let local = [ unitUniqMap                                   (moduleName mod)                                   (Set.singleton $ Module indef mod_name)                               | (mod_name, mod) <- instUnitInsts indef                               , isHoleModule mod ]                       recurse = [ collectHoles (moduleUnit mod)                                 | (_, mod) <- instUnitInsts indef ]-                  in Map.unionsWith Set.union $ local ++ recurse+                  in plusUniqMapListWith Set.union $ local ++ recurse             uv = UnitVisibility                 { uv_expose_all = b@@ -937,7 +936,7 @@                 , uv_requirements = reqs                 , uv_explicit = Just arg                 }-           vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared+           vm' = addToUniqMap_C mappend vm_cleared (mkUnit p) uv            -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`            -- (or if p-0.1 was registered in the pkgdb as exposed: True),            -- the second package flag would override the first one and you@@ -961,7 +960,7 @@            vm_cleared | no_hide_others = vm                       -- NB: renamings never clear                       | (_:_) <- rns = vm-                      | otherwise = Map.filterWithKey+                      | otherwise = filterWithKeyUniqMap                             (\k uv -> k == mkUnit p                                    || First (Just n) /= uv_package_name uv) vm          _ -> panic "applyPackageFlag"@@ -969,7 +968,7 @@     HidePackage str ->        case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of          Left ps  -> Failed (PackageFlagErr flag ps)-         Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)+         Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps)  -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages.  Furthermore, any packages it returns are *renamed*@@ -985,7 +984,7 @@   = let ps = mapMaybe (finder arg) pkgs     in if null ps         then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))-                            (Map.elems unusable))+                            (nonDetEltsUniqMap unusable))         else Right (sortByPreference prec_map ps)   where     finder (PackageArg str) p@@ -1010,7 +1009,7 @@   = let matches = matching arg         (ps,rest) = partition matches pkgs     in if null ps-        then Left (filter (matches.fst) (Map.elems unusable))+        then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))         else Right (sortByPreference prec_map ps, rest)  -- | Rename a 'UnitInfo' according to some module instantiation.@@ -1064,8 +1063,8 @@ compareByPreference prec_map pkg pkg'   = case comparing unitPackageVersion pkg pkg' of         GT -> GT-        EQ | Just prec  <- Map.lookup (unitId pkg)  prec_map-           , Just prec' <- Map.lookup (unitId pkg') prec_map+        EQ | Just prec  <- lookupUniqMap prec_map (unitId pkg)+           , Just prec' <- lookupUniqMap prec_map (unitId pkg')            -- Prefer the unit from the later DB flag (i.e., higher            -- precedence)            -> compare prec prec'@@ -1089,9 +1088,9 @@ -- ----------------------------------------------------------------------------- -- Wired-in units ----- See Note [Wired-in units] in GHC.Unit.Module+-- See Note [Wired-in units] in GHC.Unit.Types -type WiringMap = Map UnitId UnitId+type WiringMap = UniqMap UnitId UnitId  findWiredInUnits    :: Logger@@ -1105,7 +1104,7 @@ findWiredInUnits logger prec_map pkgs vis_map = do   -- Now we must find our wired-in units, and rename them to   -- their canonical names (eg. base-1.0 ==> base), as described-  -- in Note [Wired-in units] in GHC.Unit.Module+  -- in Note [Wired-in units] in GHC.Unit.Types   let         matches :: UnitInfo -> UnitId -> Bool         pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)@@ -1131,7 +1130,7 @@         findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound]           where                 all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]-                all_exposed_ps = [ p | p <- all_ps, Map.member (mkUnit p) vis_map ]+                all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ]                  try ps = case sortByPreference prec_map ps of                     p:_ -> Just <$> pick p@@ -1157,8 +1156,8 @@   let         wired_in_pkgs = catMaybes mb_wired_in_pkgs -        wiredInMap :: Map UnitId UnitId-        wiredInMap = Map.fromList+        wiredInMap :: UniqMap UnitId UnitId+        wiredInMap = listToUniqMap           [ (unitId realUnitInfo, wiredInUnitId)           | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs           , not (unitIsIndefinite realUnitInfo)@@ -1166,7 +1165,7 @@          updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs           where upd_pkg pkg-                  | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap+                  | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg)                   = pkg { unitId         = wiredInUnitId                         , unitInstanceOf = wiredInUnitId                            -- every non instantiated unit is an instance of@@ -1188,7 +1187,7 @@  -- Helper functions for rewiring Module and Unit.  These -- rewrite Units of modules in wired-in packages to the form known to the--- compiler, as described in Note [Wired-in units] in GHC.Unit.Module.+-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in GHC.Builtin.Names.@@ -1207,18 +1206,17 @@  upd_wired_in :: WiringMap -> UnitId -> UnitId upd_wired_in wiredInMap key-    | Just key' <- Map.lookup key wiredInMap = key'+    | Just key' <- lookupUniqMap wiredInMap key = key'     | otherwise = key  updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap-updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)-  where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of+updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap)+  where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of                     Nothing -> vm-                    Just r -> Map.insert (RealUnit (Definite to)) r-                                (Map.delete (RealUnit (Definite from)) vm)-+                    Just r -> addToUniqMap (delFromUniqMap vm (RealUnit (Definite from)))+                              (RealUnit (Definite to)) r --- ----------------------------------------------------------------------------+  -- ----------------------------------------------------------------------------  -- | The reason why a unit is unusable. data UnusableUnitReason@@ -1245,7 +1243,7 @@     ppr (IgnoredDependencies uids)  = brackets (text "ignored" <+> ppr uids)     ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) -type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason)+type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)  pprReason :: SDoc -> UnusableUnitReason -> SDoc pprReason pref reason = case reason of@@ -1275,7 +1273,7 @@             nest 2 (hsep (map (ppr . unitId) vs))  reportUnusable :: Logger -> UnusableUnits -> IO ()-reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)+reportUnusable logger pkgs = mapM_ report (nonDetUniqMapToList pkgs)   where     report (ipid, (_, reason)) =        debugTraceMsg logger 2 $@@ -1289,14 +1287,15 @@  -- | A reverse dependency index, mapping an 'UnitId' to -- the 'UnitId's which have a dependency on it.-type RevIndex = Map UnitId [UnitId]+type RevIndex = UniqMap UnitId [UnitId]  -- | Compute the reverse dependency index of a unit database. reverseDeps :: UnitInfoMap -> RevIndex-reverseDeps db = Map.foldl' go Map.empty db+reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db   where-    go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg)-    go' from r to = Map.insertWith (++) to [from] r+    go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex+    go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg)+    go' from r to = addToUniqMap_C (++) r to [from]  -- | Given a list of 'UnitId's to remove, a database, -- and a reverse dependency index (as computed by 'reverseDeps'),@@ -1310,10 +1309,10 @@   where     go [] (m,pkgs) = (m,pkgs)     go (uid:uids) (m,pkgs)-        | Just pkg <- Map.lookup uid m-        = case Map.lookup uid index of-            Nothing    -> go uids (Map.delete uid m, pkg:pkgs)-            Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)+        | Just pkg <- lookupUniqMap m uid+        = case lookupUniqMap index uid of+            Nothing    -> go uids (delFromUniqMap m uid, pkg:pkgs)+            Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs)         | otherwise         = go uids (m,pkgs) @@ -1322,7 +1321,7 @@ depsNotAvailable :: UnitInfoMap                  -> UnitInfo                  -> [UnitId]-depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg)+depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg)  -- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in -- 'unitAbiDepends' which correspond to units that do not exist, OR have@@ -1333,7 +1332,7 @@ depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg   where     abiMatch (dep_uid, abi)-        | Just dep_pkg <- Map.lookup dep_uid pkg_map+        | Just dep_pkg <- lookupUniqMap pkg_map dep_uid         = unitAbiHash dep_pkg == abi         | otherwise         = False@@ -1342,7 +1341,7 @@ -- Ignore units  ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits-ignoreUnits flags pkgs = Map.fromList (concatMap doit flags)+ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags)   where   doit (IgnorePackage str) =      case partition (matchingStr str) pkgs of@@ -1362,7 +1361,7 @@ -- the command line.  We use this mapping to make sure we prefer -- units that were defined later on the command line, if there -- is an ambiguity.-type UnitPrecedenceMap = Map UnitId Int+type UnitPrecedenceMap = UniqMap UnitId Int  -- | Given a list of databases, merge them together, where -- units with the same unit id in later databases override@@ -1370,7 +1369,7 @@ -- makes sense (that's done by 'validateDatabase'). mergeDatabases :: Logger -> [UnitDatabase UnitId]                -> IO (UnitInfoMap, UnitPrecedenceMap)-mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]+mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]   where     merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do       debugTraceMsg logger 2 $@@ -1382,22 +1381,22 @@       return (pkg_map', prec_map')      where       db_map = mk_pkg_map db-      mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))+      mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p))        -- The set of UnitIds which appear in both db and pkgs.  These are the       -- ones that get overridden.  Compute this just to give some       -- helpful debug messages at -v2       override_set :: Set UnitId-      override_set = Set.intersection (Map.keysSet db_map)-                                      (Map.keysSet pkg_map)+      override_set = Set.intersection (nonDetUniqMapToKeySet db_map)+                                      (nonDetUniqMapToKeySet pkg_map)        -- Now merge the sets together (NB: in case of duplicate,       -- first argument preferred)       pkg_map' :: UnitInfoMap-      pkg_map' = Map.union db_map pkg_map+      pkg_map' = pkg_map `plusUniqMap` db_map        prec_map' :: UnitPrecedenceMap-      prec_map' = Map.union (Map.map (const i) db_map) prec_map+      prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map)  -- | Validates a database, removing unusable units from it -- (this includes removing units that the user has explicitly@@ -1420,39 +1419,45 @@      -- Helper function     mk_unusable mk_err dep_matcher m uids =-      Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))-                   | pkg <- uids ]+      listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))+                    | pkg <- uids+                    ]      -- Find broken units     directly_broken = filter (not . null . depsNotAvailable pkg_map1)-                             (Map.elems pkg_map1)+                             (nonDetEltsUniqMap pkg_map1)     (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1     unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken      -- Find recursive units     sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)-                            | pkg <- Map.elems pkg_map2 ]+                            | pkg <- nonDetEltsUniqMap pkg_map2 ]     getCyclicSCC (CyclicSCC vs) = map unitId vs     getCyclicSCC (AcyclicSCC _) = []     (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2     unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic      -- Apply ignore flags-    directly_ignored = ignoreUnits ignore_flags (Map.elems pkg_map3)-    (pkg_map4, ignored) = removeUnits (Map.keys directly_ignored) index pkg_map3+    directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3)+    (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3     unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored      -- Knock out units whose dependencies don't agree with ABI     -- (i.e., got invalidated due to shadowing)     directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)-                               (Map.elems pkg_map4)+                               (nonDetEltsUniqMap pkg_map4)     (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4     unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed -    unusable = directly_ignored `Map.union` unusable_ignored-                                `Map.union` unusable_broken-                                `Map.union` unusable_cyclic-                                `Map.union` unusable_shadowed+    -- combine all unusables. The order is important for shadowing.+    -- plusUniqMapList folds using plusUFM which is right biased (opposite of+    -- Data.Map.union) so the head of the list should be the least preferred+    unusable = plusUniqMapList [ unusable_shadowed+                               , unusable_cyclic+                               , unusable_broken+                               , unusable_ignored+                               , directly_ignored+                               ]  -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit@@ -1551,7 +1556,7 @@   -- or not packages are visible or not)   pkgs1 <- mayThrowUnitErr             $ foldM (applyTrustFlag prec_map unusable)-                 (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))+                 (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))   let prelim_pkg_db = mkUnitInfoMap pkgs1    --@@ -1591,17 +1596,16 @@                             -- default, because it's almost assuredly not                             -- what you want (no mix-in linking has occurred).                             if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p-                               then Map.insert (mkUnit p)+                               then addToUniqMap vm (mkUnit p)                                                UnitVisibility {                                                  uv_expose_all = True,                                                  uv_renamings = [],                                                  uv_package_name = First (Just (fsPackageName p)),-                                                 uv_requirements = Map.empty,+                                                 uv_requirements = emptyUniqMap,                                                  uv_explicit = Nothing                                                }-                                               vm                                else vm)-                         Map.empty pkgs1+                         emptyUniqMap pkgs1    --   -- Compute a visibility map according to the command-line flags (-package,@@ -1629,9 +1633,9 @@     case unitConfigFlagsPlugins cfg of         -- common case; try to share the old vis_map         [] | not hide_plugin_pkgs -> return vis_map-           | otherwise -> return Map.empty+           | otherwise -> return emptyUniqMap         _ -> do let plugin_vis_map1-                        | hide_plugin_pkgs = Map.empty+                        | hide_plugin_pkgs = emptyUniqMap                         -- Use the vis_map PRIOR to wired in,                         -- because otherwise applyPackageFlag                         -- won't work.@@ -1660,9 +1664,9 @@   -- The requirement context is directly based off of this: we simply   -- look for nested unit IDs that are directly fed holes: the requirements   -- of those units are precisely the ones we need to track-  let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- Map.toList vis_map]-      req_ctx = Map.map (Set.toList)-              $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))+  let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]+      req_ctx = mapUniqMap (Set.toList)+              $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))     --@@ -1675,11 +1679,11 @@   -- NB: preload IS important even for type-checking, because we   -- need the correct include path to be set.   ---  let preload1 = Map.keys (Map.filter (isJust . uv_explicit) vis_map)+  let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)        -- add default preload units if they can be found in the db       basicLinkedUnits = fmap (RealUnit . Definite)-                         $ filter (flip Map.member pkg_db)+                         $ filter (flip elemUniqMap pkg_db)                          $ unitConfigAutoLink cfg       preload3 = ordNub $ (basicLinkedUnits ++ preload1) @@ -1690,7 +1694,7 @@    let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map       mod_map2 = mkUnusableModuleNameProvidersMap unusable-      mod_map = Map.union mod_map1 mod_map2+      mod_map = mod_map2 `plusUniqMap` mod_map1    -- Force the result to avoid leaking input parameters   let !state = UnitState@@ -1703,7 +1707,7 @@          , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map          , packageNameMap               = pkgname_map          , wireMap                      = wired_map-         , unwireMap                    = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]+         , unwireMap                    = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]          , requirementContext           = req_ctx          , allowVirtualUnits            = unitConfigAllowVirtual cfg          }@@ -1726,7 +1730,7 @@ -- that it was recorded as in the package database. unwireUnit :: UnitState -> Unit -> Unit unwireUnit state uid@(RealUnit (Definite def_uid)) =-    maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state))+    maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid) unwireUnit _ uid = uid  -- -----------------------------------------------------------------------------@@ -1761,36 +1765,35 @@     -- entries for every definite (for non-Backpack) and     -- indefinite (for Backpack) package, so that we get the     -- hidden entries we need.-    Map.foldlWithKey extend_modmap emptyMap vis_map_extended+    nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended  where-  vis_map_extended = Map.union vis_map {- preferred -} default_vis+  vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map -  default_vis = Map.fromList+  default_vis = listToUniqMap                   [ (mkUnit pkg, mempty)-                  | pkg <- Map.elems pkg_map+                  | (_, pkg) <- nonDetUniqMapToList pkg_map                   -- Exclude specific instantiations of an indefinite                   -- package                   , unitIsIndefinite pkg || null (unitInstantiations pkg)                   ] -  emptyMap = Map.empty+  emptyMap = emptyUniqMap   setOrigins m os = fmap (const os) m-  extend_modmap modmap uid-    UnitVisibility { uv_expose_all = b, uv_renamings = rns }+  extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap     = addListTo modmap theBindings    where     pkg = unit_lookup uid -    theBindings :: [(ModuleName, Map Module ModuleOrigin)]+    theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)]     theBindings = newBindings b rns      newBindings :: Bool                 -> [(ModuleName, ModuleName)]-                -> [(ModuleName, Map Module ModuleOrigin)]+                -> [(ModuleName, UniqMap Module ModuleOrigin)]     newBindings e rns  = es e ++ hiddens ++ map rnBinding rns      rnBinding :: (ModuleName, ModuleName)-              -> (ModuleName, Map Module ModuleOrigin)+              -> (ModuleName, UniqMap Module ModuleOrigin)     rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)      where origEntry = case lookupUFM esmap orig of             Just r -> r@@ -1799,7 +1802,7 @@                         (text "package flag: could not find module name" <+>                             ppr orig <+> text "in package" <+> ppr pk))) -    es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]+    es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]     es e = do      (m, exposedReexport) <- exposed_mods      let (pk', m', origin') =@@ -1809,7 +1812,7 @@               (pk', m', fromReexportedModules e pkg)      return (m, mkModMap pk' m' origin') -    esmap :: UniqFM ModuleName (Map Module ModuleOrigin)+    esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin)     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will                                  -- be overwritten @@ -1825,10 +1828,10 @@ -- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap mkUnusableModuleNameProvidersMap unusables =-    Map.foldl' extend_modmap Map.empty unusables+    nonDetFoldUniqMap extend_modmap emptyUniqMap unusables  where-    extend_modmap modmap (unit_info, reason) = addListTo modmap bindings-      where bindings :: [(ModuleName, Map Module ModuleOrigin)]+    extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings+      where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]             bindings = exposed ++ hidden              origin_reexport =  ModUnusable (UnusableUnit unit reason True)@@ -1863,16 +1866,16 @@ -- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks -- when reloading modules in GHCi (see #4029). This ensures that each -- value is forced before installing into the map.-addListTo :: (Monoid a, Ord k1, Ord k2)-          => Map k1 (Map k2 a)-          -> [(k1, Map k2 a)]-          -> Map k1 (Map k2 a)+addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2)+          => UniqMap k1 (UniqMap k2 a)+          -> [(k1, UniqMap k2 a)]+          -> UniqMap k1 (UniqMap k2 a) addListTo = foldl' merge-  where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m+  where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v  -- | Create a singleton module mapping-mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin-mkModMap pkg mod = Map.singleton (mkModule pkg mod)+mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin+mkModMap pkg mod = unitUniqMap (mkModule pkg mod)   -- -----------------------------------------------------------------------------@@ -1887,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@@ -1950,10 +1952,10 @@                             -> PkgQual                             -> LookupResult lookupModuleWithSuggestions' pkgs mod_map m mb_pn-  = case Map.lookup m mod_map of+  = case lookupUniqMap mod_map m of         Nothing -> LookupNotFound suggestions         Just xs ->-          case foldl' classify ([],[],[], []) (Map.toList xs) of+          case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of             ([], [], [], []) -> LookupNotFound suggestions             (_, _, _, [(m, o)])             -> LookupFound m (mod_unit m, o)             (_, _, _, exposed@(_:_))        -> LookupMultiple exposed@@ -2011,8 +2013,8 @@     all_mods :: [(String, ModuleSuggestion)]     -- All modules     all_mods = sortBy (comparing fst) $         [ (moduleNameString m, suggestion)-        | (m, e) <- Map.toList (moduleNameProvidersMap pkgs)-        , suggestion <- map (getSuggestion m) (Map.toList e)+        | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)+        , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)         ]     getSuggestion name (mod, origin) =         (if originVisible origin then SuggestVisible else SuggestHidden)@@ -2020,8 +2022,8 @@  listVisibleModuleNames :: UnitState -> [ModuleName] listVisibleModuleNames state =-    map fst (filter visible (Map.toList (moduleNameProvidersMap state)))-  where visible (_, ms) = any originVisible (Map.elems ms)+    map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))+  where visible (_, ms) = anyUniqMap originVisible ms  -- | Takes a list of UnitIds (and their "parent" dependency, used for error -- messages), and returns the list with dependencies included, in reverse@@ -2032,7 +2034,7 @@ -- | Similar to closeUnitDeps but takes a list of already loaded units as an -- additional argument. closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]-closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps+closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps  -- | Add a UnitId and those it depends on (recursively) to the given list of -- UnitIds if they are not already in it. Return a list in reverse dependency@@ -2043,9 +2045,10 @@ -- error message ("dependency of <PARENT>"). add_unit :: UnitInfoMap             -> [UnitId]-            -> (UnitId,Maybe UnitId)+            -> UnitId+            -> Maybe UnitId             -> MaybeErr UnitErr [UnitId]-add_unit pkg_map ps (p, mb_parent)+add_unit pkg_map ps p mb_parent   | p `elem` ps = return ps     -- Check if we've already added this unit   | otherwise   = case lookupUnitId' pkg_map p of       Nothing   -> Failed (CloseUnitErr p mb_parent)@@ -2054,8 +2057,8 @@          ps' <- foldM add_unit_key ps (unitDepends info)          return (p : ps')         where-          add_unit_key ps key-            = add_unit pkg_map ps (key, Just p)+          add_unit_key xs key+            = add_unit pkg_map xs key (Just p)  data UnitErr   = CloseUnitErr !UnitId !(Maybe UnitId)@@ -2099,7 +2102,7 @@ -- to form @mod_name@, or @[]@ if this is not a requirement. requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] requirementMerges pkgstate mod_name =-    fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))+  fromMaybe [] (lookupUniqMap (requirementContext pkgstate) mod_name)  -- ----------------------------------------------------------------------------- @@ -2154,9 +2157,9 @@ -- | Show the mapping of modules to where they come from. pprModuleMap :: ModuleNameProvidersMap -> SDoc pprModuleMap mod_map =-  vcat (map pprLine (Map.toList mod_map))+  vcat (map pprLine (nonDetUniqMapToList mod_map))     where-      pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))+      pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e)))       pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc       pprEntry m (m',o)         | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o)@@ -2268,10 +2271,6 @@    { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)    }) --- | Add package dependencies on the wired-in packages we use-implicitPackageDeps :: DynFlags -> [UnitId]-implicitPackageDeps dflags-   = [thUnitId | xopt TemplateHaskellQuotes dflags]-   -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but-   -- it is possible to not depend on base (for example, see `ghc-prim`)-+-- | 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,23 +58,21 @@    , Definite (..)       -- * Wired-in units-   , primUnitId-   , bignumUnitId-   , baseUnitId+   , ghcInternalUnitId    , rtsUnitId-   , thUnitId    , mainUnitId    , thisGhcUnitId    , interactiveUnitId+   , interactiveGhciUnitId+   , interactiveSessionUnitId -   , primUnit-   , bignumUnit-   , baseUnit+   , ghcInternalUnit    , rtsUnit-   , thUnit    , mainUnit    , thisGhcUnit    , interactiveUnit+   , interactiveGhciUnit+   , interactiveSessionUnit     , isInteractiveModule    , wiredInUnitIds@@ -99,17 +95,18 @@ import GHC.Utils.Encoding import GHC.Utils.Fingerprint import GHC.Utils.Misc+import GHC.Settings.Config (cProjectUnitId) -import Control.DeepSeq+import Control.DeepSeq (NFData(..)) import Data.Data-import Data.List (sortBy )+import Data.List (sortBy) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS 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@@ -148,7 +145,8 @@  instance Binary a => Binary (GenModule a) where   put_ bh (Module p n) = put_ bh p >> put_ bh n-  get bh = do p <- get bh; n <- get bh; return (Module p n)+  -- Module has strict fields, so use $! in order not to allocate a thunk+  get bh = do p <- get bh; n <- get bh; return $! Module p n  instance NFData (GenModule a) where   rnf (Module unit name) = unit `seq` name `seq` ()@@ -166,7 +164,7 @@ instance Outputable InstantiatedUnit where   ppr = pprInstantiatedUnit -pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc+pprInstantiatedUnit :: InstantiatedUnit -> SDoc pprInstantiatedUnit uid =       -- getPprStyle $ \sty ->       pprUnitId cid <>@@ -180,8 +178,6 @@      where       cid   = instUnitInstanceOf uid       insts = instUnitInsts uid-{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-}-{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) --@@ -203,14 +199,13 @@    unitFS HoleUnit                = holeFS  pprModule :: IsLine doc => Module -> doc-pprModule mod@(Module p n) = docWithContext (doc . sdocStyle)+pprModule mod@(Module p n) = docWithStyle code doc  where-  doc sty-    | codeStyle sty =-        (if p == mainUnit+  code = (if p == mainUnit                 then empty -- never qualify the main package in code                 else ztext (zEncodeFS (unitFS p)) <> char '_')             <> pprModuleName n+  doc sty     | qualModule sty mod =         case p of           HoleUnit -> angleBrackets (pprModuleName n)@@ -319,13 +314,14 @@     cid   <- get bh     insts <- get bh     let fs = mkInstantiatedUnitHash cid insts-    return InstantiatedUnit {-            instUnitInstanceOf = cid,-            instUnitInsts = insts,-            instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),-            instUnitFS = fs,-            instUnitKey = getUnique fs-           }+    -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk+    return $! InstantiatedUnit {+                instUnitInstanceOf = cid,+                instUnitInsts = insts,+                instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+                instUnitFS = fs,+                instUnitKey = getUnique fs+              }  instance IsUnitId u => Eq (GenUnit u) where   uid1 == uid2 = unitUnique uid1 == unitUnique uid2@@ -352,12 +348,10 @@ instance Outputable Unit where    ppr pk = pprUnit pk -pprUnit :: IsLine doc => Unit -> doc+pprUnit :: Unit -> SDoc pprUnit (RealUnit (Definite d)) = pprUnitId d pprUnit (VirtUnit uid) = pprInstantiatedUnit uid pprUnit HoleUnit       = ftext holeFS-{-# SPECIALIZE pprUnit :: Unit -> SDoc #-}-{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  instance Show Unit where     show = unitString@@ -373,10 +367,12 @@   put_ bh HoleUnit =     putByte bh 2   get bh = do b <- getByte bh-              case b of+              u <- case b of                 0 -> fmap RealUnit (get bh)                 1 -> fmap VirtUnit (get bh)                 _ -> pure HoleUnit+              -- Unit has strict fields that need forcing; otherwise we allocate a thunk.+              pure $! u  -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName@@ -517,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)@@ -535,12 +534,8 @@ instance Outputable UnitId where     ppr = pprUnitId -pprUnitId :: IsLine doc => UnitId -> doc-pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs)-                        -- see Note [Pretty-printing UnitId] in GHC.Unit-                        -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable-{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-}-{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+pprUnitId :: UnitId -> SDoc+pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs)  -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated@@ -596,27 +591,25 @@  -} -bignumUnitId, primUnitId, baseUnitId, rtsUnitId,-  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId+ghcInternalUnitId, rtsUnitId,+  mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId -bignumUnit, primUnit, baseUnit, rtsUnit,-  thUnit, mainUnit, thisGhcUnit, interactiveUnit  :: Unit+ghcInternalUnit, rtsUnit,+  mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit -primUnitId        = UnitId (fsLit "ghc-prim")-bignumUnitId      = UnitId (fsLit "ghc-bignum")-baseUnitId        = UnitId (fsLit "base")+ghcInternalUnitId = UnitId (fsLit "ghc-internal") rtsUnitId         = UnitId (fsLit "rts")-thisGhcUnitId     = UnitId (fsLit "ghc")+thisGhcUnitId     = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id] interactiveUnitId = UnitId (fsLit "interactive")-thUnitId          = UnitId (fsLit "template-haskell")+interactiveGhciUnitId = UnitId (fsLit "interactive-ghci")+interactiveSessionUnitId = UnitId (fsLit "interactive-session") -thUnit            = RealUnit (Definite thUnitId)-primUnit          = RealUnit (Definite primUnitId)-bignumUnit        = RealUnit (Definite bignumUnitId)-baseUnit          = RealUnit (Definite baseUnitId)+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,14 +622,52 @@  wiredInUnitIds :: [UnitId] wiredInUnitIds =-   [ primUnitId-   , bignumUnitId-   , baseUnitId+   [ ghcInternalUnitId    , rtsUnitId-   , thUnitId-   , thisGhcUnitId    ]+   -- NB: ghc is no longer part of the wired-in units since its unit-id, given+   -- by hadrian or cabal, is no longer overwritten and now matches both the+   -- cProjectUnitId defined in build-time-generated module GHC.Version, and+   -- the unit key.+   --+   -- See also Note [About units], taking into consideration ghc is still a+   -- wired-in unit but whose unit-id no longer needs special handling because+   -- we take care that it matches the unit key. +{-+Note [GHC's Unit Id]+~~~~~~~~~~~~~~~~~~~~+Previously, the unit-id of ghc-the-library was fixed as `ghc`.+This was done primarily because the compiler must know the unit-id of+some packages (including ghc) a-priori to define wired-in names.++However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed+to `ghc` might result in subtle bugs when different ghc's interact.++A good example of this is having GHC_A load a plugin compiled by GHC_B,+where GHC_A and GHC_B are linked to ghc-libraries that are ABI+incompatible. Without a distinction between the unit-id of the ghc library+GHC_A is linked against and the ghc library the plugin it is loading was+compiled against, we can't check compatibility.++Now, we give a better unit-id to ghc (`ghc-version-hash`) by++(1) Not setting -this-unit-id fixed to `ghc` in `ghc.cabal`, but rather by having+    (1.1) Hadrian pass the new unit-id with -this-unit-id for stage0-1+    (1.2) Cabal pass the unit-id it computes to ghc, which it already does by default++(2) Adding a definition to `GHC.Settings.Config` whose value is the new+unit-id. This is crucial to define the wired-in name of the GHC unit+(`thisGhcUnitId`) which *must* match the value of the -this-unit-id flag.+(Where `GHC.Settings.Config` is a module generated by the build system which,+be it either hadrian or cabal, knows exactly the unit-id it passed with -this-unit-id)++Note that we also ensure the ghc's unit key matches its unit id, both when+hadrian or cabal is building ghc. This way, we no longer need to add `ghc` to+the WiringMap, and that's why 'wiredInUnitIds' no longer includes+'thisGhcUnitId'.+-}+ --------------------------------------------------------------------- -- Boot Modules ---------------------------------------------------------------------@@ -653,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@@ -675,6 +695,9 @@   -- the Ord instance must ensure that we first sort by Module and then by   -- 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
compiler/GHC/Utils/Binary.hs view
@@ -1,1516 +1,2165 @@  {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UnboxedTuples #-}--{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}-#if MIN_VERSION_base(4,16,0)-#define HAS_TYPELITCHAR-#endif--- We always optimise this, otherwise performance of a non-optimised--- compiler is severely affected------- (c) The University of Glasgow 2002-2006------ Binary I/O library, with special tweaks for GHC------ Based on the nhc98 Binary library, which is copyright--- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.--- Under the terms of the license for that software, we must tell you--- where you can obtain the original version of the Binary library, namely---     http://www.cs.york.ac.uk/fp/nhc98/--module GHC.Utils.Binary-  ( {-type-}  Bin,-    {-class-} Binary(..),-    {-type-}  BinHandle,-    SymbolTable, Dictionary,--   BinData(..), dataHandle, handleData,-   unsafeUnpackBinBuffer,--   openBinMem,---   closeBin,--   seekBin,-   tellBin,-   castBin,-   withBinBuffer,--   foldGet,--   writeBinMem,-   readBinMem,-   readBinMemN,--   putAt, getAt,-   forwardPut, forwardPut_, forwardGet,--   -- * For writing instances-   putByte,-   getByte,--   -- * Variable length encodings-   putULEB128,-   getULEB128,-   putSLEB128,-   getSLEB128,--   -- * Fixed length encoding-   FixedLengthEncoding(..),--   -- * Lazy Binary I/O-   lazyGet,-   lazyPut,-   lazyGetMaybe,-   lazyPutMaybe,--   -- * User data-   UserData(..), getUserData, setUserData,-   newReadState, newWriteState, noUserData,--   -- * String table ("dictionary")-   putDictionary, getDictionary, putFS,-   FSTable, initFSTable, getDictFastString, putDictFastString,--   -- * Newtype wrappers-   BinSpan(..), BinSrcSpan(..), BinLocated(..)-  ) where--import GHC.Prelude--import Language.Haskell.Syntax.Module.Name (ModuleName(..))--import {-# SOURCE #-} GHC.Types.Name (Name)-import GHC.Data.FastString-import GHC.Utils.Panic.Plain-import GHC.Types.Unique.FM-import GHC.Data.FastMutInt-import GHC.Utils.Fingerprint-import GHC.Types.SrcLoc-import GHC.Types.Unique-import qualified GHC.Data.Strict as Strict--import Control.DeepSeq-import Foreign hiding (shiftL, shiftR, void)-import Data.Array-import Data.Array.IO-import Data.Array.Unsafe-import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BS-import qualified Data.ByteString.Unsafe   as BS-import Data.IORef-import Data.Char                ( ord, chr )-import Data.List.NonEmpty       ( NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Set                 ( Set )-import qualified Data.Set as Set-import Data.Time-import Data.List (unfoldr)-import Control.Monad            ( when, (<$!>), unless, forM_, void )-import System.IO as IO-import System.IO.Unsafe         ( unsafeInterleaveIO )-import System.IO.Error          ( mkIOError, eofErrorType )-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--type BinArray = ForeignPtr Word8--#if !MIN_VERSION_base(4,15,0)-unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b-unsafeWithForeignPtr = withForeignPtr-#endif-------------------------------------------------------------------- BinData------------------------------------------------------------------data BinData = BinData Int BinArray--instance NFData BinData where-  rnf (BinData sz _) = rnf sz--instance Binary BinData where-  put_ bh (BinData sz dat) = do-    put_ bh sz-    putPrim bh sz $ \dest ->-      unsafeWithForeignPtr dat $ \orig ->-        copyBytes dest orig sz-  ---  get bh = do-    sz <- get bh-    dat <- mallocForeignPtrBytes sz-    getPrim bh sz $ \orig ->-      unsafeWithForeignPtr dat $ \dest ->-        copyBytes dest orig sz-    return (BinData sz dat)--dataHandle :: BinData -> IO BinHandle-dataHandle (BinData size bin) = do-  ixr <- newFastMutInt 0-  szr <- newFastMutInt size-  binr <- newIORef bin-  return (BinMem noUserData ixr szr binr)--handleData :: BinHandle -> IO BinData-handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr-------------------------------------------------------------------- BinHandle------------------------------------------------------------------data BinHandle-  = BinMem {                     -- binary data stored in an unboxed array-     bh_usr :: UserData,         -- sigh, need parameterized modules :-)-     _off_r :: !FastMutInt,      -- the current offset-     _sz_r  :: !FastMutInt,      -- size of the array (cached)-     _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))-    }-        -- XXX: should really store a "high water mark" for dumping out-        -- the binary data to a file.--getUserData :: BinHandle -> UserData-getUserData bh = bh_usr bh--setUserData :: BinHandle -> UserData -> BinHandle-setUserData bh us = bh { bh_usr = us }---- | Get access to the underlying buffer.-withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a-withBinBuffer (BinMem _ ix_r _ arr_r) action = do-  arr <- readIORef arr_r-  ix <- readFastMutInt ix_r-  action $ BS.fromForeignPtr arr 0 ix--unsafeUnpackBinBuffer :: ByteString -> IO BinHandle-unsafeUnpackBinBuffer (BS.BS arr len) = do-  arr_r <- newIORef arr-  ix_r <- newFastMutInt 0-  sz_r <- newFastMutInt len-  return (BinMem noUserData ix_r sz_r arr_r)-------------------------------------------------------------------- Bin------------------------------------------------------------------newtype Bin a = BinPtr Int-  deriving (Eq, Ord, Show, Bounded)--castBin :: Bin a -> Bin b-castBin (BinPtr i) = BinPtr i-------------------------------------------------------------------- class Binary-------------------------------------------------------------------- | Do not rely on instance sizes for general types,--- we use variable length encoding for many of them.-class Binary a where-    put_   :: BinHandle -> a -> IO ()-    put    :: BinHandle -> a -> IO (Bin a)-    get    :: BinHandle -> IO a--    -- define one of put_, put.  Use of put_ is recommended because it-    -- is more likely that tail-calls can kick in, and we rarely need the-    -- position return value.-    put_ bh a = do _ <- put bh a; return ()-    put bh a  = do p <- tellBin bh; put_ bh a; return p--putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()-putAt bh p x = do seekBin bh p; put_ bh x; return ()--getAt  :: Binary a => BinHandle -> Bin a -> IO a-getAt bh p = do seekBin bh p; get bh--openBinMem :: Int -> IO BinHandle-openBinMem size- | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"- | otherwise = do-   arr <- mallocForeignPtrBytes size-   arr_r <- newIORef arr-   ix_r <- newFastMutInt 0-   sz_r <- newFastMutInt size-   return (BinMem noUserData ix_r sz_r arr_r)--tellBin :: BinHandle -> IO (Bin a)-tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)--seekBin :: BinHandle -> Bin a -> IO ()-seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do-  sz <- readFastMutInt sz_r-  if (p >= sz)-        then do expandBin h p; writeFastMutInt ix_r p-        else writeFastMutInt ix_r p---- | SeekBin but without calling expandBin-seekBinNoExpand :: BinHandle -> Bin a -> IO ()-seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do-  sz <- readFastMutInt sz_r-  if (p >= sz)-        then panic "seekBinNoExpand: seek out of range"-        else writeFastMutInt ix_r p--writeBinMem :: BinHandle -> FilePath -> IO ()-writeBinMem (BinMem _ ix_r _ arr_r) fn = do-  h <- openBinaryFile fn WriteMode-  arr <- readIORef arr_r-  ix  <- readFastMutInt ix_r-  unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix-  hClose h--readBinMem :: FilePath -> IO BinHandle-readBinMem filename = do-  withBinaryFile filename ReadMode $ \h -> do-    filesize' <- hFileSize h-    let filesize = fromIntegral filesize'-    readBinMem_ filesize h--readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle)-readBinMemN size filename = do-  withBinaryFile filename ReadMode $ \h -> do-    filesize' <- hFileSize h-    let filesize = fromIntegral filesize'-    if filesize < size-      then pure Nothing-      else Just <$> readBinMem_ size h--readBinMem_ :: Int -> Handle -> IO BinHandle-readBinMem_ filesize h = do-  arr <- mallocForeignPtrBytes filesize-  count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize-  when (count /= filesize) $-       error ("Binary.readBinMem: only read " ++ show count ++ " bytes")-  arr_r <- newIORef arr-  ix_r <- newFastMutInt 0-  sz_r <- newFastMutInt filesize-  return (BinMem noUserData ix_r sz_r arr_r)---- expand the size of the array to include a specified offset-expandBin :: BinHandle -> Int -> IO ()-expandBin (BinMem _ _ sz_r arr_r) !off = do-   !sz <- readFastMutInt sz_r-   let !sz' = getSize sz-   arr <- readIORef arr_r-   arr' <- mallocForeignPtrBytes sz'-   withForeignPtr arr $ \old ->-     withForeignPtr arr' $ \new ->-       copyBytes new old sz-   writeFastMutInt sz_r sz'-   writeIORef arr_r arr'-   where-    getSize :: Int -> Int-    getSize !sz-      | sz > off-      = sz-      | otherwise-      = getSize (sz * 2)--foldGet-  :: Binary a-  => Word -- n elements-  -> BinHandle-  -> b -- initial accumulator-  -> (Word -> a -> b -> IO b)-  -> IO b-foldGet n bh init_b f = go 0 init_b-  where-    go i b-      | i == n    = return b-      | otherwise = do-          a <- get bh-          b' <- f i a b-          go (i+1) b'----- -------------------------------------------------------------------------------- Low-level reading/writing of bytes---- | Takes a size and action writing up to @size@ bytes.---   After the action has run advance the index to the buffer---   by size bytes.-putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()-putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do-  ix <- readFastMutInt ix_r-  sz <- readFastMutInt sz_r-  when (ix + size > sz) $-    expandBin h (ix + size)-  arr <- readIORef arr_r-  unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)-  writeFastMutInt ix_r (ix + size)---- -- | Similar to putPrim but advances the index by the actual number of--- -- bytes written.--- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO ()--- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do---   ix <- readFastMutInt ix_r---   sz <- readFastMutInt sz_r---   when (ix + size > sz) $---     expandBin h (ix + size)---   arr <- readIORef arr_r---   written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)---   writeFastMutInt ix_r (ix + written)--getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a-getPrim (BinMem _ ix_r sz_r arr_r) size f = do-  ix <- readFastMutInt ix_r-  sz <- readFastMutInt sz_r-  when (ix + size > sz) $-      ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)-  arr <- readIORef arr_r-  w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)-    -- This is safe WRT #17760 as we we guarantee that the above line doesn't-    -- diverge-  writeFastMutInt ix_r (ix + size)-  return w--putWord8 :: BinHandle -> Word8 -> IO ()-putWord8 h !w = putPrim h 1 (\op -> poke op w)--getWord8 :: BinHandle -> IO Word8-getWord8 h = getPrim h 1 peek--putWord16 :: BinHandle -> Word16 -> IO ()-putWord16 h w = putPrim h 2 (\op -> do-  pokeElemOff op 0 (fromIntegral (w `shiftR` 8))-  pokeElemOff op 1 (fromIntegral (w .&. 0xFF))-  )--getWord16 :: BinHandle -> IO Word16-getWord16 h = getPrim h 2 (\op -> do-  w0 <- fromIntegral <$> peekElemOff op 0-  w1 <- fromIntegral <$> peekElemOff op 1-  return $! w0 `shiftL` 8 .|. w1-  )--putWord32 :: BinHandle -> Word32 -> IO ()-putWord32 h w = putPrim h 4 (\op -> do-  pokeElemOff op 0 (fromIntegral (w `shiftR` 24))-  pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))-  pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))-  pokeElemOff op 3 (fromIntegral (w .&. 0xFF))-  )--getWord32 :: BinHandle -> IO Word32-getWord32 h = getPrim h 4 (\op -> do-  w0 <- fromIntegral <$> peekElemOff op 0-  w1 <- fromIntegral <$> peekElemOff op 1-  w2 <- fromIntegral <$> peekElemOff op 2-  w3 <- fromIntegral <$> peekElemOff op 3--  return $! (w0 `shiftL` 24) .|.-            (w1 `shiftL` 16) .|.-            (w2 `shiftL` 8)  .|.-            w3-  )--putWord64 :: BinHandle -> Word64 -> IO ()-putWord64 h w = putPrim h 8 (\op -> do-  pokeElemOff op 0 (fromIntegral (w `shiftR` 56))-  pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))-  pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))-  pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))-  pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))-  pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))-  pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))-  pokeElemOff op 7 (fromIntegral (w .&. 0xFF))-  )--getWord64 :: BinHandle -> IO Word64-getWord64 h = getPrim h 8 (\op -> do-  w0 <- fromIntegral <$> peekElemOff op 0-  w1 <- fromIntegral <$> peekElemOff op 1-  w2 <- fromIntegral <$> peekElemOff op 2-  w3 <- fromIntegral <$> peekElemOff op 3-  w4 <- fromIntegral <$> peekElemOff op 4-  w5 <- fromIntegral <$> peekElemOff op 5-  w6 <- fromIntegral <$> peekElemOff op 6-  w7 <- fromIntegral <$> peekElemOff op 7--  return $! (w0 `shiftL` 56) .|.-            (w1 `shiftL` 48) .|.-            (w2 `shiftL` 40) .|.-            (w3 `shiftL` 32) .|.-            (w4 `shiftL` 24) .|.-            (w5 `shiftL` 16) .|.-            (w6 `shiftL` 8)  .|.-            w7-  )--putByte :: BinHandle -> Word8 -> IO ()-putByte bh !w = putWord8 bh w--getByte :: BinHandle -> IO Word8-getByte h = getWord8 h---- -------------------------------------------------------------------------------- Encode numbers in LEB128 encoding.--- Requires one byte of space per 7 bits of data.------ There are signed and unsigned variants.--- Do NOT use the unsigned one for signed values, at worst it will--- result in wrong results, at best it will lead to bad performance--- when coercing negative values to an unsigned type.------ We mark them as SPECIALIZE as it's extremely critical that they get specialized--- to their specific types.------ TODO: Each use of putByte performs a bounds check,---       we should use putPrimMax here. However it's quite hard to return---       the number of bytes written into putPrimMax without allocating an---       Int for it, while the code below does not allocate at all.---       So we eat the cost of the bounds check instead of increasing allocations---       for now.---- Unsigned numbers-{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-}-{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-}-putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()-putULEB128 bh w =-#if defined(DEBUG)-    (if w < 0 then panic "putULEB128: Signed number" else id) $-#endif-    go w-  where-    go :: a -> IO ()-    go w-      | w <= (127 :: a)-      = putByte bh (fromIntegral w :: Word8)-      | otherwise = do-        -- bit 7 (8th bit) indicates more to come.-        let !byte = setBit (fromIntegral w) 7 :: Word8-        putByte bh byte-        go (w `unsafeShiftR` 7)--{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-}-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-}-getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a-getULEB128 bh =-    go 0 0-  where-    go :: Int -> a -> IO a-    go shift w = do-        b <- getByte bh-        let !hasMore = testBit b 7-        let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a-        if hasMore-            then do-                go (shift+7) val-            else-                return $! val---- Signed numbers-{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-}-{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-}-putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()-putSLEB128 bh initial = go initial-  where-    go :: a -> IO ()-    go val = do-        let !byte = fromIntegral (clearBit val 7) :: Word8-        let !val' = val `unsafeShiftR` 7-        let !signBit = testBit byte 6-        let !done =-                -- Unsigned value, val' == 0 and last value can-                -- be discriminated from a negative number.-                ((val' == 0 && not signBit) ||-                -- Signed value,-                 (val' == -1 && signBit))--        let !byte' = if done then byte else setBit byte 7-        putByte bh byte'--        unless done $ go val'--{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-}-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-}-getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a-getSLEB128 bh = do-    (val,shift,signed) <- go 0 0-    if signed && (shift < finiteBitSize val )-        then return $! ((complement 0 `unsafeShiftL` shift) .|. val)-        else return val-    where-        go :: Int -> a -> IO (a,Int,Bool)-        go shift val = do-            byte <- getByte bh-            let !byteVal = fromIntegral (clearBit byte 7) :: a-            let !val' = val .|. (byteVal `unsafeShiftL` shift)-            let !more = testBit byte 7-            let !shift' = shift+7-            if more-                then go (shift') val'-                else do-                    let !signed = testBit byte 6-                    return (val',shift',signed)---- -------------------------------------------------------------------------------- Fixed length encoding instances---- Sometimes words are used to represent a certain bit pattern instead--- of a number. Using FixedLengthEncoding we will write the pattern as--- is to the interface file without the variable length encoding we usually--- apply.---- | Encode the argument in it's full length. This is different from many default--- binary instances which make no guarantee about the actual encoding and--- might do things use variable length encoding.-newtype FixedLengthEncoding a-  = FixedLengthEncoding { unFixedLength :: a }-  deriving (Eq,Ord,Show)--instance Binary (FixedLengthEncoding Word8) where-  put_ h (FixedLengthEncoding x) = putByte h x-  get h = FixedLengthEncoding <$> getByte h--instance Binary (FixedLengthEncoding Word16) where-  put_ h (FixedLengthEncoding x) = putWord16 h x-  get h = FixedLengthEncoding <$> getWord16 h--instance Binary (FixedLengthEncoding Word32) where-  put_ h (FixedLengthEncoding x) = putWord32 h x-  get h = FixedLengthEncoding <$> getWord32 h--instance Binary (FixedLengthEncoding Word64) where-  put_ h (FixedLengthEncoding x) = putWord64 h x-  get h = FixedLengthEncoding <$> getWord64 h---- -------------------------------------------------------------------------------- Primitive Word writes--instance Binary Word8 where-  put_ bh !w = putWord8 bh w-  get  = getWord8--instance Binary Word16 where-  put_ = putULEB128-  get  = getULEB128--instance Binary Word32 where-  put_ = putULEB128-  get  = getULEB128--instance Binary Word64 where-  put_ = putULEB128-  get = getULEB128---- -------------------------------------------------------------------------------- Primitive Int writes--instance Binary Int8 where-  put_ h w = put_ h (fromIntegral w :: Word8)-  get h    = do w <- get h; return $! (fromIntegral (w::Word8))--instance Binary Int16 where-  put_ = putSLEB128-  get = getSLEB128--instance Binary Int32 where-  put_ = putSLEB128-  get = getSLEB128--instance Binary Int64 where-  put_ h w = putSLEB128 h w-  get h    = getSLEB128 h---- -------------------------------------------------------------------------------- Instances for standard types--instance Binary () where-    put_ _ () = return ()-    get  _    = return ()--instance Binary Bool where-    put_ bh b = putByte bh (fromIntegral (fromEnum b))-    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))--instance Binary Char where-    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)-    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))--instance Binary Int where-    put_ bh i = put_ bh (fromIntegral i :: Int64)-    get  bh = do-        x <- get bh-        return $! (fromIntegral (x :: Int64))--instance Binary a => Binary [a] where-    put_ bh l = do-        let len = length l-        put_ bh len-        mapM_ (put_ bh) l-    get bh = do-        len <- get bh :: IO Int -- Int is variable length encoded so only-                                -- one byte for small lists.-        let loop 0 = return []-            loop n = do a <- get bh; as <- loop (n-1); return (a:as)-        loop len---- | 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--instance Binary a => Binary (NonEmpty a) where-    put_ bh = put_ bh . NonEmpty.toList-    get bh = NonEmpty.fromList <$> get bh--instance (Ix a, Binary a, Binary b) => Binary (Array a b) where-    put_ bh arr = do-        put_ bh $ bounds arr-        put_ bh $ elems arr-    get bh = do-        bounds <- get bh-        xs <- get bh-        return $ listArray bounds xs--instance (Binary a, Binary b) => Binary (a,b) where-    put_ bh (a,b) = do put_ bh a; put_ bh b-    get bh        = do a <- get bh-                       b <- get bh-                       return (a,b)--instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where-    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c-    get bh          = do a <- get bh-                         b <- get bh-                         c <- get bh-                         return (a,b,c)--instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where-    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d-    get bh            = do a <- get bh-                           b <- get bh-                           c <- get bh-                           d <- get bh-                           return (a,b,c,d)--instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where-    put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;-    get bh               = do a <- get bh-                              b <- get bh-                              c <- get bh-                              d <- get bh-                              e <- get bh-                              return (a,b,c,d,e)--instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where-    put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;-    get bh                  = do a <- get bh-                                 b <- get bh-                                 c <- get bh-                                 d <- get bh-                                 e <- get bh-                                 f <- get bh-                                 return (a,b,c,d,e,f)--instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where-    put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g-    get bh                  = do a <- get bh-                                 b <- get bh-                                 c <- get bh-                                 d <- get bh-                                 e <- get bh-                                 f <- get bh-                                 g <- get bh-                                 return (a,b,c,d,e,f,g)--instance Binary a => Binary (Maybe a) where-    put_ bh Nothing  = putByte bh 0-    put_ bh (Just a) = do putByte bh 1; put_ bh a-    get bh           = do h <- getWord8 bh-                          case h of-                            0 -> return Nothing-                            _ -> do x <- get bh; return (Just x)--instance Binary a => Binary (Strict.Maybe a) where-    put_ bh Strict.Nothing = putByte bh 0-    put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a-    get bh =-      do h <- getWord8 bh-         case h of-           0 -> return Strict.Nothing-           _ -> do x <- get bh; return (Strict.Just x)--instance (Binary a, Binary b) => Binary (Either a b) where-    put_ bh (Left  a) = do putByte bh 0; put_ bh a-    put_ bh (Right b) = do putByte bh 1; put_ bh b-    get bh            = do h <- getWord8 bh-                           case h of-                             0 -> do a <- get bh ; return (Left a)-                             _ -> do b <- get bh ; return (Right b)--instance Binary UTCTime where-    put_ bh u = do put_ bh (utctDay u)-                   put_ bh (utctDayTime u)-    get bh = do day <- get bh-                dayTime <- get bh-                return $ UTCTime { utctDay = day, utctDayTime = dayTime }--instance Binary Day where-    put_ bh d = put_ bh (toModifiedJulianDay d)-    get bh = do i <- get bh-                return $ ModifiedJulianDay { toModifiedJulianDay = i }--instance Binary DiffTime where-    put_ bh dt = put_ bh (toRational dt)-    get bh = do r <- get bh-                return $ fromRational r--{--Finally - a reasonable portable Integer instance.--We used to encode values in the Int32 range as such,-falling back to a string of all things. In either case-we stored a tag byte to discriminate between the two cases.--This made some sense as it's highly portable but also not very-efficient.--However GHC stores a surprisingly large number off large Integer-values. In the examples looked at between 25% and 50% of Integers-serialized were outside of the Int32 range.--Consider a valie like `2724268014499746065`, some sort of hash-actually generated by GHC.-In the old scheme this was encoded as a list of 19 chars. This-gave a size of 77 Bytes, one for the length of the list and 76-since we encode chars as Word32 as well.--We can easily do better. The new plan is:--* Start with a tag byte-  * 0 => Int64 (LEB128 encoded)-  * 1 => Negative large integer-  * 2 => Positive large integer-* Followed by the value:-  * Int64 is encoded as usual-  * Large integers are encoded as a list of bytes (Word8).-    We use Data.Bits which defines a bit order independent of the representation.-    Values are stored LSB first.--This means our example value `2724268014499746065` is now only 10 bytes large.-* One byte tag-* One byte for the length of the [Word8] list.-* 8 bytes for the actual date.--The new scheme also does not depend in any way on-architecture specific details.--We still use this scheme even with LEB128 available,-as it has less overhead for truly large numbers. (> maxBound :: Int64)--The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal--}--instance Binary Integer where-    put_ bh i-      | i >= lo64 && i <= hi64 = do-          putWord8 bh 0-          put_ bh (fromIntegral i :: Int64)-      | otherwise = do-          if i < 0-            then putWord8 bh 1-            else putWord8 bh 2-          put_ bh (unroll $ abs i)-      where-        lo64 = fromIntegral (minBound :: Int64)-        hi64 = fromIntegral (maxBound :: Int64)-    get bh = do-      int_kind <- getWord8 bh-      case int_kind of-        0 -> fromIntegral <$!> (get bh :: IO Int64)-        -- Large integer-        1 -> negate <$!> getInt-        2 -> getInt-        _ -> panic "Binary Integer - Invalid byte"-        where-          getInt :: IO Integer-          getInt = roll <$!> (get bh :: IO [Word8])--unroll :: Integer -> [Word8]-unroll = unfoldr step-  where-    step 0 = Nothing-    step i = Just (fromIntegral i, i `shiftR` 8)--roll :: [Word8] -> Integer-roll   = foldl' unstep 0 . reverse-  where-    unstep a b = a `shiftL` 8 .|. fromIntegral b---    {--    -- This code is currently commented out.-    -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for-    -- discussion.--    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)-    put_ bh (J# s# a#) = do-        putByte bh 1-        put_ bh (I# s#)-        let sz# = sizeofByteArray# a#  -- in *bytes*-        put_ bh (I# sz#)  -- in *bytes*-        putByteArray bh a# sz#--    get bh = do-        b <- getByte bh-        case b of-          0 -> do (I# i#) <- get bh-                  return (S# i#)-          _ -> do (I# s#) <- get bh-                  sz <- get bh-                  (BA a#) <- getByteArray bh sz-                  return (J# s# a#)--putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()-putByteArray bh a s# = loop 0#-  where loop n#-           | n# ==# s# = return ()-           | otherwise = do-                putByte bh (indexByteArray a n#)-                loop (n# +# 1#)--getByteArray :: BinHandle -> Int -> IO ByteArray-getByteArray bh (I# sz) = do-  (MBA arr) <- newByteArray sz-  let loop n-           | n ==# sz = return ()-           | otherwise = do-                w <- getByte bh-                writeByteArray arr n w-                loop (n +# 1#)-  loop 0#-  freezeByteArray arr-    -}--{--data ByteArray = BA ByteArray#-data MBA = MBA (MutableByteArray# RealWorld)--newByteArray :: Int# -> IO MBA-newByteArray sz = IO $ \s ->-  case newByteArray# sz s of { (# s, arr #) ->-  (# s, MBA arr #) }--freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray-freezeByteArray arr = IO $ \s ->-  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->-  (# s, BA arr #) }--writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()-writeByteArray arr i (W8# w) = IO $ \s ->-  case writeWord8Array# arr i w s of { s ->-  (# s, () #) }--indexByteArray :: ByteArray# -> Int# -> Word8-indexByteArray a# n# = W8# (indexWord8Array# a# n#)---}-instance (Binary a) => Binary (Ratio a) where-    put_ bh (a :% b) = do put_ bh a; put_ bh b-    get bh = do a <- get bh; b <- get bh; return (a :% b)---- Instance uses fixed-width encoding to allow inserting--- Bin placeholders in the stream.-instance Binary (Bin a) where-  put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)-  get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))----- -------------------------------------------------------------------------------- Forward reading/writing---- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B--- by using a forward reference-forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b)-forwardPut bh put_A put_B = do-  -- write placeholder pointer to A-  pre_a <- tellBin bh-  put_ bh pre_a--  -- write B-  r_b <- put_B--  -- update A's pointer-  a <- tellBin bh-  putAt bh pre_a a-  seekBinNoExpand bh a--  -- write A-  r_a <- put_A r_b-  pure (r_a,r_b)--forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO ()-forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B---- | Read a value stored using a forward reference-forwardGet :: BinHandle -> IO a -> IO a-forwardGet bh get_A = do-    -- read forward reference-    p <- get bh -- a BinPtr-    -- store current position-    p_a <- tellBin bh-    -- go read the forward value, then seek back-    seekBinNoExpand bh p-    r <- get_A-    seekBinNoExpand bh p_a-    pure r---- -------------------------------------------------------------------------------- Lazy reading/writing--lazyPut :: Binary a => BinHandle -> a -> IO ()-lazyPut bh a = do-    -- output the obj with a ptr to skip over it:-    pre_a <- tellBin bh-    put_ bh pre_a       -- save a slot for the ptr-    put_ bh a           -- dump the object-    q <- tellBin bh     -- q = ptr to after object-    putAt bh pre_a q    -- fill in slot before a with ptr to q-    seekBin bh q        -- finally carry on writing at q--lazyGet :: Binary a => BinHandle -> IO a-lazyGet bh = do-    p <- get bh -- a BinPtr-    p_a <- tellBin bh-    a <- unsafeInterleaveIO $ do-        -- NB: Use a fresh off_r variable in the child thread, for thread-        -- safety.-        off_r <- newFastMutInt 0-        getAt bh { _off_r = off_r } p_a-    seekBin bh p -- skip over the object for now-    return a---- | Serialize the constructor strictly but lazily serialize a value inside a--- 'Just'.------ This way we can check for the presence of a value without deserializing the--- value itself.-lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO ()-lazyPutMaybe bh Nothing  = putWord8 bh 0-lazyPutMaybe bh (Just x) = do-  putWord8 bh 1-  lazyPut bh x---- | Deserialize a value serialized by 'lazyPutMaybe'.-lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a)-lazyGetMaybe bh = do-  h <- getWord8 bh-  case h of-    0 -> pure Nothing-    _ -> Just <$> lazyGet bh---- -------------------------------------------------------------------------------- UserData--- --------------------------------------------------------------------------------- | Information we keep around during interface file--- serialization/deserialization. Namely we keep the functions for serializing--- and deserializing 'Name's and 'FastString's. We do this because we actually--- use serialization in two distinct settings,------ * When serializing interface files themselves------ * When computing the fingerprint of an IfaceDecl (which we computing by---   hashing its Binary serialization)------ These two settings have different needs while serializing Names:------ * Names in interface files are serialized via a symbol table (see Note---   [Symbol table representation of names] in "GHC.Iface.Binary").------ * During fingerprinting a binding Name is serialized as the OccName and a---   non-binding Name is serialized as the fingerprint of the thing they---   represent. See Note [Fingerprinting IfaceDecls] for further discussion.----data UserData =-   UserData {-        -- for *deserialising* only:-        ud_get_name :: BinHandle -> IO Name,-        ud_get_fs   :: BinHandle -> IO FastString,--        -- for *serialising* only:-        ud_put_nonbinding_name :: BinHandle -> Name -> IO (),-        -- ^ serialize a non-binding 'Name' (e.g. a reference to another-        -- binding).-        ud_put_binding_name :: BinHandle -> Name -> IO (),-        -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)-        ud_put_fs   :: BinHandle -> FastString -> IO ()-   }--newReadState :: (BinHandle -> IO Name)   -- ^ how to deserialize 'Name's-             -> (BinHandle -> IO FastString)-             -> UserData-newReadState get_name get_fs-  = UserData { ud_get_name = get_name,-               ud_get_fs   = get_fs,-               ud_put_nonbinding_name = undef "put_nonbinding_name",-               ud_put_binding_name    = undef "put_binding_name",-               ud_put_fs   = undef "put_fs"-             }--newWriteState :: (BinHandle -> Name -> IO ())-                 -- ^ how to serialize non-binding 'Name's-              -> (BinHandle -> Name -> IO ())-                 -- ^ how to serialize binding 'Name's-              -> (BinHandle -> FastString -> IO ())-              -> UserData-newWriteState put_nonbinding_name put_binding_name put_fs-  = UserData { ud_get_name = undef "get_name",-               ud_get_fs   = undef "get_fs",-               ud_put_nonbinding_name = put_nonbinding_name,-               ud_put_binding_name    = put_binding_name,-               ud_put_fs   = put_fs-             }--noUserData :: UserData-noUserData = UserData-  { ud_get_name            = undef "get_name"-  , ud_get_fs              = undef "get_fs"-  , ud_put_nonbinding_name = undef "put_nonbinding_name"-  , ud_put_binding_name    = undef "put_binding_name"-  , ud_put_fs              = undef "put_fs"-  }--undef :: String -> a-undef s = panic ("Binary.UserData: no " ++ s)-------------------------------------------------------------- The Dictionary------------------------------------------------------------type Dictionary = Array Int FastString -- The dictionary-                                       -- Should be 0-indexed--putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()-putDictionary bh sz dict = do-  put_ bh sz-  mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))-    -- It's OK to use nonDetEltsUFM here because the elements have indices-    -- that array uses to create order--getDictionary :: BinHandle -> IO Dictionary-getDictionary bh = do-  sz <- get bh :: IO Int-  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)-  forM_ [0..(sz-1)] $ \i -> do-    fs <- getFS bh-    writeArray mut_arr i fs-  unsafeFreeze mut_arr--getDictFastString :: Dictionary -> BinHandle -> IO FastString-getDictFastString dict bh = do-    j <- get bh-    return $! (dict ! fromIntegral (j :: Word32))---initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)-initFSTable bh = do-  dict_next_ref <- newFastMutInt 0-  dict_map_ref <- newIORef emptyUFM-  let bin_dict = FSTable-        { fs_tab_next = dict_next_ref-        , fs_tab_map  = dict_map_ref-        }-  let put_dict = do-        fs_count <- readFastMutInt dict_next_ref-        dict_map  <- readIORef dict_map_ref-        putDictionary bh fs_count dict_map-        pure fs_count--  -- BinHandle with FastString writing support-  let ud = getUserData bh-  let ud_fs = ud { ud_put_fs = putDictFastString bin_dict }-  let bh_fs = setUserData bh ud_fs--  return (bh_fs,bin_dict,put_dict)--putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()-putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh--allocateFastString :: FSTable -> FastString -> IO Word32-allocateFastString FSTable { fs_tab_next = j_r-                           , fs_tab_map  = out_r-                           } f = do-    out <- readIORef out_r-    let !uniq = getUnique f-    case lookupUFM_Directly out uniq of-        Just (j, _)  -> return (fromIntegral j :: Word32)-        Nothing -> do-           j <- readFastMutInt j_r-           writeFastMutInt j_r (j + 1)-           writeIORef out_r $! addToUFM_Directly out uniq (j, f)-           return (fromIntegral j :: Word32)---- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to--- avoid a collision and copy to avoid a dependency.-data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use-                       , fs_tab_map  :: !(IORef (UniqFM FastString (Int,FastString)))-                                -- indexed by FastString-  }--------------------------------------------------------------- The Symbol Table-------------------------------------------------------------- On disk, the symbol table is an array of IfExtName, when--- reading it in we turn it into a SymbolTable.--type SymbolTable = Array Int Name-------------------------------------------------------------- Reading and writing FastStrings------------------------------------------------------------putFS :: BinHandle -> FastString -> IO ()-putFS bh fs = putBS bh $ bytesFS fs--getFS :: BinHandle -> IO FastString-getFS bh = do-  l  <- get bh :: IO Int-  getPrim bh l (\src -> pure $! mkFastStringBytes src l )--putBS :: BinHandle -> ByteString -> IO ()-putBS bh bs =-  BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do-    put_ bh l-    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)--getBS :: BinHandle -> IO ByteString-getBS bh = do-  l <- get bh :: IO Int-  BS.create l $ \dest -> do-    getPrim bh l (\src -> copyBytes dest src l)--instance Binary ByteString where-  put_ bh f = putBS bh f-  get bh = getBS bh--instance Binary FastString where-  put_ bh f =-    case getUserData bh of-        UserData { ud_put_fs = put_fs } -> put_fs bh f--  get bh =-    case getUserData bh of-        UserData { ud_get_fs = get_fs } -> get_fs bh--deriving instance Binary NonDetFastString-deriving instance Binary LexicalFastString--instance Binary Fingerprint where-  put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2-  get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)--instance Binary ModuleName where-  put_ bh (ModuleName fs) = put_ bh fs-  get bh = do fs <- get bh; return (ModuleName fs)---- instance Binary FunctionOrData where---     put_ bh IsFunction = putByte bh 0---     put_ bh IsData     = putByte bh 1---     get bh = do---         h <- getByte bh---         case h of---           0 -> return IsFunction---           1 -> return IsData---           _ -> panic "Binary FunctionOrData"---- instance Binary TupleSort where---     put_ bh BoxedTuple      = putByte bh 0---     put_ bh UnboxedTuple    = putByte bh 1---     put_ bh ConstraintTuple = putByte bh 2---     get bh = do---       h <- getByte bh---       case h of---         0 -> do return BoxedTuple---         1 -> do return UnboxedTuple---         _ -> do return ConstraintTuple---- instance Binary Activation where---     put_ bh NeverActive = do---             putByte bh 0---     put_ bh FinalActive = do---             putByte bh 1---     put_ bh AlwaysActive = do---             putByte bh 2---     put_ bh (ActiveBefore src aa) = do---             putByte bh 3---             put_ bh src---             put_ bh aa---     put_ bh (ActiveAfter src ab) = do---             putByte bh 4---             put_ bh src---             put_ bh ab---     get bh = do---             h <- getByte bh---             case h of---               0 -> do return NeverActive---               1 -> do return FinalActive---               2 -> do return AlwaysActive---               3 -> do src <- get bh---                       aa <- get bh---                       return (ActiveBefore src aa)---               _ -> do src <- get bh---                       ab <- get bh---                       return (ActiveAfter src ab)---- instance Binary InlinePragma where---     put_ bh (InlinePragma s a b c d) = do---             put_ bh s---             put_ bh a---             put_ bh b---             put_ bh c---             put_ bh d----     get bh = do---            s <- get bh---            a <- get bh---            b <- get bh---            c <- get bh---            d <- get bh---            return (InlinePragma s a b c d)---- instance Binary RuleMatchInfo where---     put_ bh FunLike = putByte bh 0---     put_ bh ConLike = putByte bh 1---     get bh = do---             h <- getByte bh---             if h == 1 then return ConLike---                       else return FunLike---- instance Binary InlineSpec where---     put_ bh NoUserInlinePrag = putByte bh 0---     put_ bh Inline           = putByte bh 1---     put_ bh Inlinable        = putByte bh 2---     put_ bh NoInline         = putByte bh 3----     get bh = do h <- getByte bh---                 case h of---                   0 -> return NoUserInlinePrag---                   1 -> return Inline---                   2 -> return Inlinable---                   _ -> return NoInline---- instance Binary RecFlag where---     put_ bh Recursive = do---             putByte bh 0---     put_ bh NonRecursive = do---             putByte bh 1---     get bh = do---             h <- getByte bh---             case h of---               0 -> do return Recursive---               _ -> do return NonRecursive---- instance Binary OverlapMode where---     put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s---     put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s---     put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s---     put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s---     put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s---     get bh = do---         h <- getByte bh---         case h of---             0 -> (get bh) >>= \s -> return $ NoOverlap s---             1 -> (get bh) >>= \s -> return $ Overlaps s---             2 -> (get bh) >>= \s -> return $ Incoherent s---             3 -> (get bh) >>= \s -> return $ Overlapping s---             4 -> (get bh) >>= \s -> return $ Overlappable s---             _ -> panic ("get OverlapMode" ++ show h)----- instance Binary OverlapFlag where---     put_ bh flag = do put_ bh (overlapMode flag)---                       put_ bh (isSafeOverlap flag)---     get bh = do---         h <- get bh---         b <- get bh---         return OverlapFlag { overlapMode = h, isSafeOverlap = b }---- instance Binary FixityDirection where---     put_ bh InfixL = do---             putByte bh 0---     put_ bh InfixR = do---             putByte bh 1---     put_ bh InfixN = do---             putByte bh 2---     get bh = do---             h <- getByte bh---             case h of---               0 -> do return InfixL---               1 -> do return InfixR---               _ -> do return InfixN---- instance Binary Fixity where---     put_ bh (Fixity src aa ab) = do---             put_ bh src---             put_ bh aa---             put_ bh ab---     get bh = do---           src <- get bh---           aa <- get bh---           ab <- get bh---           return (Fixity src aa ab)---- instance Binary WarningTxt where---     put_ bh (WarningTxt s w) = do---             putByte bh 0---             put_ bh s---             put_ bh w---     put_ bh (DeprecatedTxt s d) = do---             putByte bh 1---             put_ bh s---             put_ bh d----     get bh = do---             h <- getByte bh---             case h of---               0 -> do s <- get bh---                       w <- get bh---                       return (WarningTxt s w)---               _ -> do s <- get bh---                       d <- get bh---                       return (DeprecatedTxt s d)---- instance Binary StringLiteral where---   put_ bh (StringLiteral st fs _) = do---             put_ bh st---             put_ bh fs---   get bh = do---             st <- get bh---             fs <- get bh---             return (StringLiteral st fs Nothing)--newtype BinLocated a = BinLocated { unBinLocated :: Located a }--instance Binary a => Binary (BinLocated a) where-    put_ bh (BinLocated (L l x)) = do-            put_ bh $ BinSrcSpan l-            put_ bh x--    get bh = do-            l <- unBinSrcSpan <$> get bh-            x <- get bh-            return $ BinLocated (L l x)--newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan }---- See Note [Source Location Wrappers]-instance Binary BinSpan where-  put_ bh (BinSpan ss) = do-            put_ bh (srcSpanFile ss)-            put_ bh (srcSpanStartLine ss)-            put_ bh (srcSpanStartCol ss)-            put_ bh (srcSpanEndLine ss)-            put_ bh (srcSpanEndCol ss)--  get bh = do-            f <- get bh-            sl <- get bh-            sc <- get bh-            el <- get bh-            ec <- get bh-            return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc)-                                            (mkRealSrcLoc f el ec))--instance Binary UnhelpfulSpanReason where-  put_ bh r = case r of-    UnhelpfulNoLocationInfo -> putByte bh 0-    UnhelpfulWiredIn        -> putByte bh 1-    UnhelpfulInteractive    -> putByte bh 2-    UnhelpfulGenerated      -> putByte bh 3-    UnhelpfulOther fs       -> putByte bh 4 >> put_ bh fs--  get bh = do-    h <- getByte bh-    case h of-      0 -> return UnhelpfulNoLocationInfo-      1 -> return UnhelpfulWiredIn-      2 -> return UnhelpfulInteractive-      3 -> return UnhelpfulGenerated-      _ -> UnhelpfulOther <$> get bh--newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan }---- See Note [Source Location Wrappers]-instance Binary BinSrcSpan where-  put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do-          putByte bh 0-          -- BufSpan doesn't ever get serialised because the positions depend-          -- on build location.-          put_ bh $ BinSpan ss--  put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do-          putByte bh 1-          put_ bh s--  get bh = do-          h <- getByte bh-          case h of-            0 -> do BinSpan ss <- get bh-                    return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)-            _ -> do s <- get bh-                    return $ BinSrcSpan (UnhelpfulSpan s)---{--Note [Source Location Wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Source locations are banned from interface files, to-prevent filepaths affecting interface hashes.--Unfortunately, we can't remove all binary instances,-as they're used to serialise .hie files, and we don't-want to break binary compatibility.--To this end, the Bin[Src]Span newtypes wrappers were-introduced to prevent accidentally serialising a-source location as part of a larger structure.--}------------------------------------------------------------------------------------- Instances for the containers package-----------------------------------------------------------------------------------instance (Binary v) => Binary (IntMap v) where-  put_ bh m = put_ bh (IntMap.toList m)-  get bh = IntMap.fromList <$> get bh+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}++{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++--+-- (c) The University of Glasgow 2002-2006+--+-- Binary I/O library, with special tweaks for GHC+--+-- Based on the nhc98 Binary library, which is copyright+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.+-- Under the terms of the license for that software, we must tell you+-- where you can obtain the original version of the Binary library, namely+--     http://www.cs.york.ac.uk/fp/nhc98/++module GHC.Utils.Binary+  ( {-type-}  Bin, RelBin(..), getRelBin,+    {-class-} Binary(..),+    {-type-}  ReadBinHandle, WriteBinHandle,+    SymbolTable, Dictionary,++   BinData(..), dataHandle, handleData,+   unsafeUnpackBinBuffer,++   openBinMem,+--   closeBin,++   seekBinWriter,+   seekBinReader,+   seekBinReaderRel,+   tellBinReader,+   tellBinWriter,+   castBin,+   withBinBuffer,+   freezeWriteHandle,+   shrinkBinBuffer,+   thawReadHandle,++   foldGet, foldGet',++   writeBinMem,+   readBinMem,+   readBinMemN,++   putAt, getAt,+   putAtRel,+   forwardPut, forwardPut_, forwardGet,+   forwardPutRel, forwardPutRel_, forwardGetRel,++   -- * For writing instances+   putByte,+   getByte,+   putByteString,+   getByteString,++   -- * Variable length encodings+   putULEB128,+   getULEB128,+   putSLEB128,+   getSLEB128,++   -- * Fixed length encoding+   FixedLengthEncoding(..),++   -- * Lazy Binary I/O+   lazyGet,+   lazyPut,+   lazyGet',+   lazyPut',+   lazyGetMaybe,+   lazyPutMaybe,++   -- * EnumBinary+   EnumBinary(..),++   -- * User data+   ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData,+   WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData,+   mkWriterUserData, mkReaderUserData,+   newReadState, newWriteState,+   addReaderToUserData, addWriterToUserData,+   findUserDataReader, findUserDataWriter,+   -- * Binary Readers & Writers+   BinaryReader(..), BinaryWriter(..),+   mkWriter, mkReader,+   SomeBinaryReader, SomeBinaryWriter,+   mkSomeBinaryReader, mkSomeBinaryWriter,+   -- * Tables+   ReaderTable(..),+   WriterTable(..),+   -- * String table ("dictionary")+   initFastStringReaderTable, initFastStringWriterTable,+   putDictionary, getDictionary, putFS,+   FSTable(..), getDictFastString, putDictFastString,+   -- * Generic deduplication table+   GenericSymbolTable(..),+   initGenericSymbolTable,+   getGenericSymtab, putGenericSymTab,+   getGenericSymbolTable, putGenericSymbolTable,+   -- * Newtype wrappers+   BinSpan(..), BinSrcSpan(..), BinLocated(..),+   -- * Newtypes for types that have canonically more than one valid encoding+   BindingName(..),+   simpleBindingNameWriter,+   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+import GHC.Data.TrieMap+import GHC.Utils.Panic.Plain+import GHC.Types.Unique.FM+import GHC.Data.FastMutInt+import GHC.Utils.Fingerprint+import GHC.Types.SrcLoc+import GHC.Types.Unique+import qualified GHC.Data.Strict as Strict+import GHC.Utils.Outputable( JoinPointHood(..) )++import Control.DeepSeq+import Control.Monad            ( when, (<$!>), unless, forM_, void )+import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)+import Data.Array+import Data.Array.IO+import Data.Array.Unsafe+import Data.ByteString (ByteString, copy)+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(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Proxy+import Data.Set                 ( Set )+import qualified Data.Set as Set+import Data.Time+import Data.List (unfoldr)+import System.IO as IO+import System.IO.Unsafe         ( unsafeInterleaveIO )+import System.IO.Error          ( mkIOError, eofErrorType )+import Type.Reflection          ( Typeable, SomeTypeRep(..) )+import qualified Type.Reflection as Refl+import GHC.Real                 ( Ratio(..) )+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import GHC.ForeignPtr           ( unsafeWithForeignPtr )++import Unsafe.Coerce (unsafeCoerce)++type BinArray = ForeignPtr Word8+++---------------------------------------------------------------+-- BinData+---------------------------------------------------------------++data BinData = BinData Int BinArray++instance NFData BinData where+  rnf (BinData sz _) = rnf sz++instance Binary BinData where+  put_ bh (BinData sz dat) = do+    put_ bh sz+    putPrim bh sz $ \dest ->+      unsafeWithForeignPtr dat $ \orig ->+        copyBytes dest orig sz+  --+  get bh = do+    sz <- get bh+    dat <- mallocForeignPtrBytes sz+    getPrim bh sz $ \orig ->+      unsafeWithForeignPtr dat $ \dest ->+        copyBytes dest orig sz+    return (BinData sz dat)++dataHandle :: BinData -> IO ReadBinHandle+dataHandle (BinData size bin) = do+  ixr <- newFastMutInt 0+  return (ReadBinMem noReaderUserData ixr size bin)++handleData :: WriteBinHandle -> IO BinData+handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr++---------------------------------------------------------------+-- FullBinData+---------------------------------------------------------------++-- | 'FullBinData' stores a slice to a 'BinArray'.+--+-- It requires less memory than 'ReadBinHandle', and can be constructed from+-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a+-- 'ReadBinHandle' using 'thawBinHandle'.+-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra+-- conversions via 'putFullBinData'.+data FullBinData = FullBinData+  { fbd_readerUserData :: ReaderUserData+  -- ^ 'ReaderUserData' that can be used to resume reading.+  , fbd_off_s :: {-# UNPACK #-} !Int+  -- ^ start offset+  , fbd_off_e :: {-# UNPACK #-} !Int+  -- ^ end offset+  , fbd_size :: {-# UNPACK #-} !Int+  -- ^ total buffer size+  , fbd_buffer :: {-# UNPACK #-} !BinArray+  }++-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things.+instance Eq FullBinData where+  (FullBinData _ b c d e) == (FullBinData _ b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1++instance Ord FullBinData where+  compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) =+    compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1++-- | Write the 'FullBinData' slice into the 'WriteBinHandle'.+putFullBinData :: WriteBinHandle -> FullBinData -> IO ()+putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do+  let sz = o2 - o1+  putPrim bh sz $ \dest ->+    unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig ->+    copyBytes dest orig sz++-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'.+--+-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current+-- offset of the 'ReadBinHandle'.+freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData+freezeBinHandle (ReadBinMem user_data ixr sz binr) (BinPtr start) = do+  ix <- readFastMutInt ixr+  pure (FullBinData user_data start ix sz binr)++-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle'+-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was+-- obtained from 'freezeBinHandle'.+thawBinHandle :: FullBinData -> IO ReadBinHandle+thawBinHandle (FullBinData user_data ix _end sz ba) = do+  ixr <- newFastMutInt ix+  return $ ReadBinMem user_data ixr sz ba++---------------------------------------------------------------+-- BinHandle+---------------------------------------------------------------++-- | A write-only handle that can be used to serialise binary data into a buffer.+--+-- The buffer is an unboxed binary array.+data WriteBinHandle+  = WriteBinMem {+     wbm_userData :: WriterUserData,+     -- ^ User data for writing binary outputs.+     -- Allows users to overwrite certain 'Binary' instances.+     -- This is helpful when a non-canonical 'Binary' instance is required,+     -- such as in the case of 'Name'.+     wbm_off_r    :: !FastMutInt,      -- ^ the current offset+     wbm_sz_r     :: !FastMutInt,      -- ^ size of the array (cached)+     wbm_arr_r    :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))+    }++-- | A read-only handle that can be used to deserialise binary data from a buffer.+--+-- The buffer is an unboxed binary array.+data ReadBinHandle+  = ReadBinMem {+     rbm_userData :: ReaderUserData,+     -- ^ User data for reading binary inputs.+     -- Allows users to overwrite certain 'Binary' instances.+     -- This is helpful when a non-canonical 'Binary' instance is required,+     -- such as in the case of 'Name'.+     rbm_off_r    :: !FastMutInt,     -- ^ the current offset+     rbm_sz_r     :: !Int,            -- ^ size of the array (cached)+     rbm_arr_r    :: !BinArray        -- ^ the array (bounds: (0,size-1))+    }++getReaderUserData :: ReadBinHandle -> ReaderUserData+getReaderUserData bh = rbm_userData bh++getWriterUserData :: WriteBinHandle -> WriterUserData+getWriterUserData bh = wbm_userData bh++setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle+setWriterUserData bh us = bh { wbm_userData = us }++setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle+setReaderUserData bh us = bh { rbm_userData = us }++-- | Add 'SomeBinaryReader' as a known binary decoder.+-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',+-- it is overwritten.+addReaderToUserData :: forall a. Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle+addReaderToUserData reader bh = bh+  { rbm_userData = (rbm_userData bh)+      { ud_reader_data =+          let+            typRep = Refl.typeRep @a+          in+            Map.insert (SomeTypeRep typRep) (SomeBinaryReader typRep reader) (ud_reader_data (rbm_userData bh))+      }+  }++-- | Add 'SomeBinaryWriter' as a known binary encoder.+-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',+-- it is overwritten.+addWriterToUserData :: forall a . Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle+addWriterToUserData writer bh = bh+  { wbm_userData = (wbm_userData bh)+      { ud_writer_data =+          let+            typRep = Refl.typeRep @a+          in+            Map.insert (SomeTypeRep typRep) (SomeBinaryWriter typRep writer) (ud_writer_data (wbm_userData bh))+      }+  }++-- | Get access to the underlying buffer.+withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a+withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do+  ix <- readFastMutInt ix_r+  arr <- readIORef arr_r+  action $ BS.fromForeignPtr arr 0 ix++unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle+unsafeUnpackBinBuffer (BS.BS arr len) = do+  ix_r <- newFastMutInt 0+  return (ReadBinMem noReaderUserData ix_r len arr)++---------------------------------------------------------------+-- Bin+---------------------------------------------------------------++newtype Bin a = BinPtr Int+  deriving (Eq, Ord, Show, Bounded)++-- | Like a 'Bin' but is used to store relative offset pointers.+-- Relative offset pointers store a relative location, but also contain an+-- anchor that allow to obtain the absolute offset.+data RelBin a = RelBin+  { relBin_anchor :: {-# UNPACK #-} !(Bin a)+  -- ^ Absolute position from where we read 'relBin_offset'.+  , relBin_offset :: {-# UNPACK #-} !(RelBinPtr a)+  -- ^ Relative offset to 'relBin_anchor'.+  -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@+  }+  deriving (Eq, Ord, Show, Bounded)++-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer+-- instead of an absolute offset.+newtype RelBinPtr a = RelBinPtr (Bin a)+  deriving (Eq, Ord, Show, Bounded)++castBin :: Bin a -> Bin b+castBin (BinPtr i) = BinPtr i++-- | Read a relative offset location and wrap it in 'RelBin'.+--+-- The resulting 'RelBin' can be translated into an absolute offset location using+-- 'makeAbsoluteBin'+getRelBin :: ReadBinHandle -> IO (RelBin a)+getRelBin bh = do+  start <- tellBinReader bh+  off <- get bh+  pure $ RelBin start off++makeAbsoluteBin ::  RelBin a -> Bin a+makeAbsoluteBin (RelBin (BinPtr !start) (RelBinPtr (BinPtr !offset))) =+  BinPtr $ start + offset++makeRelativeBin :: RelBin a -> RelBinPtr a+makeRelativeBin (RelBin _ offset) = offset++toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a+toRelBin (BinPtr !start) (BinPtr !goal) =+  RelBin (BinPtr start) (RelBinPtr $ BinPtr $ goal - start)++---------------------------------------------------------------+-- class Binary+---------------------------------------------------------------++-- | Do not rely on instance sizes for general types,+-- we use variable length encoding for many of them.+class Binary a where+    put_   :: WriteBinHandle -> a -> IO ()+    put    :: WriteBinHandle -> a -> IO (Bin a)+    get    :: ReadBinHandle -> IO a++    -- define one of put_, put.  Use of put_ is recommended because it+    -- is more likely that tail-calls can kick in, and we rarely need the+    -- position return value.+    put_ bh a = do _ <- put bh a; return ()+    put bh a  = do p <- tellBinWriter bh; put_ bh a; return p++putAt  :: Binary a => WriteBinHandle -> Bin a -> a -> IO ()+putAt bh p x = do seekBinWriter bh p; put_ bh x; return ()++putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO ()+putAtRel bh from to = putAt bh from (makeRelativeBin $ toRelBin from to)++getAt  :: Binary a => ReadBinHandle -> Bin a -> IO a+getAt bh p = do seekBinReader bh p; get bh++openBinMem :: Int -> IO WriteBinHandle+openBinMem size+ | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"+ | otherwise = do+   arr <- mallocForeignPtrBytes size+   arr_r <- newIORef arr+   ix_r <- newFastMutInt 0+   sz_r <- newFastMutInt size+   return WriteBinMem+    { wbm_userData = noWriterUserData+    , wbm_off_r = ix_r+    , wbm_sz_r = sz_r+    , wbm_arr_r = arr_r+    }++-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'.+--+-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'.+freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle+freezeWriteHandle wbm = do+  rbm_off_r <- newFastMutInt =<< readFastMutInt (wbm_off_r wbm)+  rbm_sz_r <- readFastMutInt (wbm_sz_r wbm)+  rbm_arr_r <- readIORef (wbm_arr_r wbm)+  pure $ ReadBinMem+    { rbm_userData = noReaderUserData+    , rbm_off_r = rbm_off_r+    , rbm_sz_r = rbm_sz_r+    , rbm_arr_r = rbm_arr_r+    }++-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size.+-- This performs a copy of the underlying buffer.+-- The buffer may be truncated if the offset is not at the end of the written+-- output.+--+-- UserData is also discarded during the copy+-- You should just use this when translating a Put handle into a Get handle.+shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle+shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do+  unsafeUnpackBinBuffer (copy bs)++thawReadHandle :: ReadBinHandle -> IO WriteBinHandle+thawReadHandle rbm = do+  wbm_off_r <- newFastMutInt =<< readFastMutInt (rbm_off_r rbm)+  wbm_sz_r <- newFastMutInt (rbm_sz_r rbm)+  wbm_arr_r <- newIORef (rbm_arr_r rbm)+  pure $ WriteBinMem+    { wbm_userData = noWriterUserData+    , wbm_off_r = wbm_off_r+    , wbm_sz_r = wbm_sz_r+    , wbm_arr_r = wbm_arr_r+    }++tellBinWriter :: WriteBinHandle -> IO (Bin a)+tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)++tellBinReader :: ReadBinHandle -> IO (Bin a)+tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)++seekBinWriter :: WriteBinHandle -> Bin a -> IO ()+seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do+  sz <- readFastMutInt sz_r+  if (p > sz)+        then do expandBin h p; writeFastMutInt ix_r p+        else writeFastMutInt ix_r p++-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to+-- by 'Bin a'.+-- This operation may 'panic', if the pointer location is out of bounds of the+-- buffer of 'BinHandle'.+seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO ()+seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do+  sz <- readFastMutInt sz_r+  if (p > sz)+        then panic "seekBinNoExpandWriter: seek out of range"+        else writeFastMutInt ix_r p++-- | SeekBin but without calling expandBin+seekBinReader :: ReadBinHandle -> Bin a -> IO ()+seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do+  if (p > sz_r)+        then panic "seekBinReader: seek out of range"+        else writeFastMutInt ix_r p++seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO ()+seekBinReaderRel (ReadBinMem _ ix_r sz_r _) relBin = do+  let (BinPtr !p) = makeAbsoluteBin relBin+  if (p > sz_r)+        then panic "seekBinReaderRel: seek out of range"+        else writeFastMutInt ix_r p++writeBinMem :: WriteBinHandle -> FilePath -> IO ()+writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do+  h <- openBinaryFile fn WriteMode+  arr <- readIORef arr_r+  ix  <- readFastMutInt ix_r+  unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix+  hClose h++readBinMem :: FilePath -> IO ReadBinHandle+readBinMem filename = do+  withBinaryFile filename ReadMode $ \h -> do+    filesize' <- hFileSize h+    let filesize = fromIntegral filesize'+    readBinMem_ filesize h++readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle)+readBinMemN size filename = do+  withBinaryFile filename ReadMode $ \h -> do+    filesize' <- hFileSize h+    let filesize = fromIntegral filesize'+    if filesize < size+      then pure Nothing+      else Just <$> readBinMem_ size h++readBinMem_ :: Int -> Handle -> IO ReadBinHandle+readBinMem_ filesize h = do+  arr <- mallocForeignPtrBytes filesize+  count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize+  when (count /= filesize) $+       error ("Binary.readBinMem: only read " ++ show count ++ " bytes")+  ix_r <- newFastMutInt 0+  return ReadBinMem+    { rbm_userData = noReaderUserData+    , rbm_off_r = ix_r+    , rbm_sz_r = filesize+    , rbm_arr_r = arr+    }++-- expand the size of the array to include a specified offset+expandBin :: WriteBinHandle -> Int -> IO ()+expandBin (WriteBinMem _ _ sz_r arr_r) !off = do+   !sz <- readFastMutInt sz_r+   let !sz' = getSize sz+   arr <- readIORef arr_r+   arr' <- mallocForeignPtrBytes sz'+   withForeignPtr arr $ \old ->+     withForeignPtr arr' $ \new ->+       copyBytes new old sz+   writeFastMutInt sz_r sz'+   writeIORef arr_r arr'+   where+    getSize :: Int -> Int+    getSize !sz+      | sz > off+      = sz+      | otherwise+      = getSize (sz * 2)++foldGet+  :: Binary a+  => Word -- n elements+  -> ReadBinHandle+  -> b -- initial accumulator+  -> (Word -> a -> b -> IO b)+  -> IO b+foldGet n bh init_b f = go 0 init_b+  where+    go i b+      | i == n    = return b+      | otherwise = do+          a <- get bh+          b' <- f i a b+          go (i+1) b'++foldGet'+  :: Binary a+  => Word -- n elements+  -> ReadBinHandle+  -> b -- initial accumulator+  -> (Word -> a -> b -> IO b)+  -> IO b+{-# INLINE foldGet' #-}+foldGet' n bh init_b f = go 0 init_b+  where+    go i !b+      | i == n    = return b+      | otherwise = do+          !a  <- get bh+          b'  <- f i a b+          go (i+1) b'+++-- -----------------------------------------------------------------------------+-- Low-level reading/writing of bytes++-- | Takes a size and action writing up to @size@ bytes.+--   After the action has run advance the index to the buffer+--   by size bytes.+putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()+putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do+  ix <- readFastMutInt ix_r+  sz <- readFastMutInt sz_r+  when (ix + size > sz) $+    expandBin h (ix + size)+  arr <- readIORef arr_r+  unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)+  writeFastMutInt ix_r (ix + size)++-- -- | Similar to putPrim but advances the index by the actual number of+-- -- bytes written.+-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO ()+-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do+--   ix <- readFastMutInt ix_r+--   sz <- readFastMutInt sz_r+--   when (ix + size > sz) $+--     expandBin h (ix + size)+--   arr <- readIORef arr_r+--   written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)+--   writeFastMutInt ix_r (ix + written)++getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a+getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do+  ix <- readFastMutInt ix_r+  when (ix + size > sz_r) $+      ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)+  w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix)+    -- This is safe WRT #17760 as we we guarantee that the above line doesn't+    -- diverge+  writeFastMutInt ix_r (ix + size)+  return w++putWord8 :: WriteBinHandle -> Word8 -> IO ()+putWord8 h !w = putPrim h 1 (\op -> poke op w)++getWord8 :: ReadBinHandle -> IO Word8+getWord8 h = getPrim h 1 peek++putWord16 :: WriteBinHandle -> Word16 -> IO ()+putWord16 h w = putPrim h 2 (\op -> do+  pokeElemOff op 0 (fromIntegral (w `shiftR` 8))+  pokeElemOff op 1 (fromIntegral (w .&. 0xFF))+  )++getWord16 :: ReadBinHandle -> IO Word16+getWord16 h = getPrim h 2 (\op -> do+  w0 <- fromIntegral <$> peekElemOff op 0+  w1 <- fromIntegral <$> peekElemOff op 1+  return $! w0 `shiftL` 8 .|. w1+  )++putWord32 :: WriteBinHandle -> Word32 -> IO ()+putWord32 h w = putPrim h 4 (\op -> do+  pokeElemOff op 0 (fromIntegral (w `shiftR` 24))+  pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))+  pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))+  pokeElemOff op 3 (fromIntegral (w .&. 0xFF))+  )++getWord32 :: ReadBinHandle -> IO Word32+getWord32 h = getPrim h 4 (\op -> do+  w0 <- fromIntegral <$> peekElemOff op 0+  w1 <- fromIntegral <$> peekElemOff op 1+  w2 <- fromIntegral <$> peekElemOff op 2+  w3 <- fromIntegral <$> peekElemOff op 3++  return $! (w0 `shiftL` 24) .|.+            (w1 `shiftL` 16) .|.+            (w2 `shiftL` 8)  .|.+            w3+  )++putWord64 :: WriteBinHandle -> Word64 -> IO ()+putWord64 h w = putPrim h 8 (\op -> do+  pokeElemOff op 0 (fromIntegral (w `shiftR` 56))+  pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))+  pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))+  pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))+  pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))+  pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))+  pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))+  pokeElemOff op 7 (fromIntegral (w .&. 0xFF))+  )++getWord64 :: ReadBinHandle -> IO Word64+getWord64 h = getPrim h 8 (\op -> do+  w0 <- fromIntegral <$> peekElemOff op 0+  w1 <- fromIntegral <$> peekElemOff op 1+  w2 <- fromIntegral <$> peekElemOff op 2+  w3 <- fromIntegral <$> peekElemOff op 3+  w4 <- fromIntegral <$> peekElemOff op 4+  w5 <- fromIntegral <$> peekElemOff op 5+  w6 <- fromIntegral <$> peekElemOff op 6+  w7 <- fromIntegral <$> peekElemOff op 7++  return $! (w0 `shiftL` 56) .|.+            (w1 `shiftL` 48) .|.+            (w2 `shiftL` 40) .|.+            (w3 `shiftL` 32) .|.+            (w4 `shiftL` 24) .|.+            (w5 `shiftL` 16) .|.+            (w6 `shiftL` 8)  .|.+            w7+  )++putByte :: WriteBinHandle -> Word8 -> IO ()+putByte bh !w = putWord8 bh w++getByte :: ReadBinHandle -> IO Word8+getByte h = getWord8 h++-- -----------------------------------------------------------------------------+-- Encode numbers in LEB128 encoding.+-- Requires one byte of space per 7 bits of data.+--+-- There are signed and unsigned variants.+-- Do NOT use the unsigned one for signed values, at worst it will+-- result in wrong results, at best it will lead to bad performance+-- when coercing negative values to an unsigned type.+--+-- We mark them as SPECIALIZE as it's extremely critical that they get specialized+-- to their specific types.+--+-- TODO: Each use of putByte performs a bounds check,+--       we should use putPrimMax here. However it's quite hard to return+--       the number of bytes written into putPrimMax without allocating an+--       Int for it, while the code below does not allocate at all.+--       So we eat the cost of the bounds check instead of increasing allocations+--       for now.++-- Unsigned numbers+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-}+putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO ()+putULEB128 bh w =+#if defined(DEBUG)+    (if w < 0 then panic "putULEB128: Signed number" else id) $+#endif+    go w+  where+    go :: a -> IO ()+    go w+      | w <= (127 :: a)+      = putByte bh (fromIntegral w :: Word8)+      | otherwise = do+        -- bit 7 (8th bit) indicates more to come.+        let !byte = setBit (fromIntegral w) 7 :: Word8+        putByte bh byte+        go (w `unsafeShiftR` 7)++{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-}+getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a+getULEB128 bh =+    go 0 0+  where+    go :: Int -> a -> IO a+    go shift w = do+        b <- getByte bh+        let !hasMore = testBit b 7+        let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a+        if hasMore+            then do+                go (shift+7) val+            else+                return $! val++-- Signed numbers+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}+putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()+putSLEB128 bh initial = go initial+  where+    go :: a -> IO ()+    go val = do+        let !byte = fromIntegral (clearBit val 7) :: Word8+        let !val' = val `unsafeShiftR` 7+        let !signBit = testBit byte 6+        let !done =+                -- Unsigned value, val' == 0 and last value can+                -- be discriminated from a negative number.+                ((val' == 0 && not signBit) ||+                -- Signed value,+                 (val' == -1 && signBit))++        let !byte' = if done then byte else setBit byte 7+        putByte bh byte'++        unless done $ go val'++{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-}+getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a+getSLEB128 bh = do+    (val,shift,signed) <- go 0 0+    if signed && (shift < finiteBitSize val )+        then return $! ((complement 0 `unsafeShiftL` shift) .|. val)+        else return val+    where+        go :: Int -> a -> IO (a,Int,Bool)+        go shift val = do+            byte <- getByte bh+            let !byteVal = fromIntegral (clearBit byte 7) :: a+            let !val' = val .|. (byteVal `unsafeShiftL` shift)+            let !more = testBit byte 7+            let !shift' = shift+7+            if more+                then go (shift') val'+                else do+                    let !signed = testBit byte 6+                    return (val',shift',signed)++-- -----------------------------------------------------------------------------+-- Fixed length encoding instances++-- Sometimes words are used to represent a certain bit pattern instead+-- of a number. Using FixedLengthEncoding we will write the pattern as+-- is to the interface file without the variable length encoding we usually+-- apply.++-- | Encode the argument in its full length. This is different from many default+-- binary instances which make no guarantee about the actual encoding and+-- might do things using variable length encoding.+newtype FixedLengthEncoding a+  = FixedLengthEncoding { unFixedLength :: a }+  deriving (Eq,Ord,Show)++instance Binary (FixedLengthEncoding Word8) where+  put_ h (FixedLengthEncoding x) = putByte h x+  get h = FixedLengthEncoding <$> getByte h++instance Binary (FixedLengthEncoding Word16) where+  put_ h (FixedLengthEncoding x) = putWord16 h x+  get h = FixedLengthEncoding <$> getWord16 h++instance Binary (FixedLengthEncoding Word32) where+  put_ h (FixedLengthEncoding x) = putWord32 h x+  get h = FixedLengthEncoding <$> getWord32 h++instance Binary (FixedLengthEncoding Word64) where+  put_ h (FixedLengthEncoding x) = putWord64 h x+  get h = FixedLengthEncoding <$> getWord64 h++-- -----------------------------------------------------------------------------+-- Primitive Word writes++instance Binary Word8 where+  put_ bh !w = putWord8 bh w+  get  = getWord8++instance Binary Word16 where+  put_ = putULEB128+  get  = getULEB128++instance Binary Word32 where+  put_ = putULEB128+  get  = getULEB128++instance Binary Word64 where+  put_ = putULEB128+  get = getULEB128++-- -----------------------------------------------------------------------------+-- Primitive Int writes++instance Binary Int8 where+  put_ h w = put_ h (fromIntegral w :: Word8)+  get h    = do w <- get h; return $! (fromIntegral (w::Word8))++instance Binary Int16 where+  put_ = putSLEB128+  get = getSLEB128++instance Binary Int32 where+  put_ = putSLEB128+  get = getSLEB128++instance Binary Int64 where+  put_ h w = putSLEB128 h w+  get h    = getSLEB128 h++-- -----------------------------------------------------------------------------+-- Instances for standard types++instance Binary () where+    put_ _ () = return ()+    get  _    = return ()++instance Binary Bool where+    put_ bh b = putByte bh (fromIntegral (fromEnum b))+    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))++instance Binary Char where+    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)+    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))++instance Binary Int where+    put_ bh i = put_ bh (fromIntegral i :: Int64)+    get  bh = do+        x <- get bh+        return $! (fromIntegral (x :: Int64))++instance Binary a => Binary [a] where+    put_ bh l = do+        let len = length l+        put_ bh len+        mapM_ (put_ bh) l+    get bh = do+        len <- get bh :: IO Int -- Int is variable length encoded so only+                                -- one byte for small lists.+        let loop 0 = return []+            loop n = do a <- get bh; as <- loop (n-1); return (a:as)+        loop len++-- | 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.toAscList s)+  get bh = Set.fromAscList <$> get bh++instance Binary a => Binary (NonEmpty a) where+    put_ bh = put_ bh . NonEmpty.toList+    get bh = NonEmpty.fromList <$> get bh++instance (Ix a, Binary a, Binary b) => Binary (Array a b) where+    put_ bh arr = do+        put_ bh $ bounds arr+        put_ bh $ elems arr+    get bh = do+        bounds <- get bh+        xs <- get bh+        return $ listArray bounds xs++instance (Binary a, Binary b) => Binary (a,b) where+    put_ bh (a,b) = do put_ bh a; put_ bh b+    get bh        = do a <- get bh+                       b <- get bh+                       return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         return (a,b,c)++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d+    get bh            = do a <- get bh+                           b <- get bh+                           c <- get bh+                           d <- get bh+                           return (a,b,c,d)++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where+    put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;+    get bh               = do a <- get bh+                              b <- get bh+                              c <- get bh+                              d <- get bh+                              e <- get bh+                              return (a,b,c,d,e)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where+    put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;+    get bh                  = do a <- get bh+                                 b <- get bh+                                 c <- get bh+                                 d <- get bh+                                 e <- get bh+                                 f <- get bh+                                 return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where+    put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g+    get bh                  = do a <- get bh+                                 b <- get bh+                                 c <- get bh+                                 d <- get bh+                                 e <- get bh+                                 f <- get bh+                                 g <- get bh+                                 return (a,b,c,d,e,f,g)++instance Binary a => Binary (Maybe a) where+    put_ bh Nothing  = putByte bh 0+    put_ bh (Just a) = do putByte bh 1; put_ bh a+    get bh           = do h <- getWord8 bh+                          case h of+                            0 -> return Nothing+                            _ -> do x <- get bh; return (Just x)++instance Binary a => Binary (Strict.Maybe a) where+    put_ bh Strict.Nothing = putByte bh 0+    put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a+    get bh =+      do h <- getWord8 bh+         case h of+           0 -> return Strict.Nothing+           _ -> do x <- get bh; return (Strict.Just x)++instance (Binary a, Binary b) => Binary (Either a b) where+    put_ bh (Left  a) = do putByte bh 0; put_ bh a+    put_ bh (Right b) = do putByte bh 1; put_ bh b+    get bh            = do h <- getWord8 bh+                           case h of+                             0 -> do a <- get bh ; return (Left a)+                             _ -> do b <- get bh ; return (Right b)++instance Binary UTCTime where+    put_ bh u = do put_ bh (utctDay u)+                   put_ bh (utctDayTime u)+    get bh = do day <- get bh+                dayTime <- get bh+                return $ UTCTime { utctDay = day, utctDayTime = dayTime }++instance Binary Day where+    put_ bh d = put_ bh (toModifiedJulianDay d)+    get bh = do i <- get bh+                return $ ModifiedJulianDay { toModifiedJulianDay = i }++instance Binary DiffTime where+    put_ bh dt = put_ bh (toRational dt)+    get bh = do r <- get bh+                return $ fromRational r++instance Binary JoinPointHood where+    put_ bh NotJoinPoint = putByte bh 0+    put_ bh (JoinPoint ar) = do+        putByte bh 1+        put_ bh ar+    get bh = do+        h <- getByte bh+        case h of+            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.++We used to encode values in the Int32 range as such,+falling back to a string of all things. In either case+we stored a tag byte to discriminate between the two cases.++This made some sense as it's highly portable but also not very+efficient.++However GHC stores a surprisingly large number of large Integer+values. In the examples looked at between 25% and 50% of Integers+serialized were outside of the Int32 range.++Consider a value like `2724268014499746065`, some sort of hash+actually generated by GHC.+In the old scheme this was encoded as a list of 19 chars. This+gave a size of 77 Bytes, one for the length of the list and 76+since we encode chars as Word32 as well.++We can easily do better. The new plan is:++* Start with a tag byte+  * 0 => Int64 (LEB128 encoded)+  * 1 => Negative large integer+  * 2 => Positive large integer+* Followed by the value:+  * Int64 is encoded as usual+  * Large integers are encoded as a list of bytes (Word8).+    We use Data.Bits which defines a bit order independent of the representation.+    Values are stored LSB first.++This means our example value `2724268014499746065` is now only 10 bytes large.+* One byte tag+* One byte for the length of the [Word8] list.+* 8 bytes for the actual date.++The new scheme also does not depend in any way on+architecture specific details.++We still use this scheme even with LEB128 available,+as it has less overhead for truly large numbers. (> maxBound :: Int64)++The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal+-}++instance Binary Integer where+    put_ bh i+      | i >= lo64 && i <= hi64 = do+          putWord8 bh 0+          put_ bh (fromIntegral i :: Int64)+      | otherwise = do+          if i < 0+            then putWord8 bh 1+            else putWord8 bh 2+          put_ bh (unroll $ abs i)+      where+        lo64 = fromIntegral (minBound :: Int64)+        hi64 = fromIntegral (maxBound :: Int64)+    get bh = do+      int_kind <- getWord8 bh+      case int_kind of+        0 -> fromIntegral <$!> (get bh :: IO Int64)+        -- Large integer+        1 -> negate <$!> getInt+        2 -> getInt+        _ -> panic "Binary Integer - Invalid byte"+        where+          getInt :: IO Integer+          getInt = roll <$!> (get bh :: IO [Word8])++unroll :: Integer -> [Word8]+unroll = unfoldr step+  where+    step 0 = Nothing+    step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll   = foldl' unstep 0 . reverse+  where+    unstep a b = a `shiftL` 8 .|. fromIntegral b+++    {-+    -- This code is currently commented out.+    -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for+    -- discussion.++    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)+    put_ bh (J# s# a#) = do+        putByte bh 1+        put_ bh (I# s#)+        let sz# = sizeofByteArray# a#  -- in *bytes*+        put_ bh (I# sz#)  -- in *bytes*+        putByteArray bh a# sz#++    get bh = do+        b <- getByte bh+        case b of+          0 -> do (I# i#) <- get bh+                  return (S# i#)+          _ -> do (I# s#) <- get bh+                  sz <- get bh+                  (BA a#) <- getByteArray bh sz+                  return (J# s# a#)++putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()+putByteArray bh a s# = loop 0#+  where loop n#+           | n# ==# s# = return ()+           | otherwise = do+                putByte bh (indexByteArray a n#)+                loop (n# +# 1#)++getByteArray :: BinHandle -> Int -> IO ByteArray+getByteArray bh (I# sz) = do+  (MBA arr) <- newByteArray sz+  let loop n+           | n ==# sz = return ()+           | otherwise = do+                w <- getByte bh+                writeByteArray arr n w+                loop (n +# 1#)+  loop 0#+  freezeByteArray arr+    -}++{-+data ByteArray = BA ByteArray#+data MBA = MBA (MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+  case newByteArray# sz s of { (# s, arr #) ->+  (# s, MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->+  (# s, BA arr #) }++writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()+writeByteArray arr i (W8# w) = IO $ \s ->+  case writeWord8Array# arr i w s of { s ->+  (# s, () #) }++indexByteArray :: ByteArray# -> Int# -> Word8+indexByteArray a# n# = W8# (indexWord8Array# a# n#)++-}+instance (Binary a) => Binary (Ratio a) where+    put_ bh (a :% b) = do put_ bh a; put_ bh b+    get bh = do a <- get bh; b <- get bh; return (a :% b)++-- Instance uses fixed-width encoding to allow inserting+-- Bin placeholders in the stream.+instance Binary (Bin a) where+  put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)+  get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))++-- Instance uses fixed-width encoding to allow inserting+-- Bin placeholders in the stream.+instance Binary (RelBinPtr a) where+  put_ bh (RelBinPtr i) = put_ bh i+  get bh = RelBinPtr <$> get bh++-- -----------------------------------------------------------------------------+-- Forward reading/writing++-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B+-- by using a forward reference.+forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)+forwardPut bh put_A put_B = do+  -- write placeholder pointer to A+  pre_a <- tellBinWriter bh+  put_ bh pre_a++  -- write B+  r_b <- put_B++  -- update A's pointer+  a <- tellBinWriter bh+  putAt bh pre_a a+  seekBinNoExpandWriter bh a++  -- write A+  r_a <- put_A r_b+  pure (r_a,r_b)++forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()+forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B++-- | Read a value stored using a forward reference+--+-- The forward reference is expected to be an absolute offset.+forwardGet :: ReadBinHandle -> IO a -> IO a+forwardGet bh get_A = do+    -- read forward reference+    p <- get bh -- a BinPtr+    -- store current position+    p_a <- tellBinReader bh+    -- go read the forward value, then seek back+    seekBinReader bh p+    r <- get_A+    seekBinReader bh p_a+    pure r++-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B+-- by using a forward reference.+--+-- This forward reference is a relative offset that allows us to skip over the+-- result of 'put_A'.+forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)+forwardPutRel bh put_A put_B = do+  -- write placeholder pointer to A+  pre_a <- tellBinWriter bh+  put_ bh pre_a++  -- write B+  r_b <- put_B++  -- update A's pointer+  a <- tellBinWriter bh+  putAtRel bh pre_a a+  seekBinNoExpandWriter bh a++  -- write A+  r_a <- put_A r_b+  pure (r_a,r_b)++-- | Like 'forwardGetRel', but discard the result.+forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()+forwardPutRel_ bh put_A put_B = void $ forwardPutRel bh put_A put_B++-- | Read a value stored using a forward reference.+--+-- The forward reference is expected to be a relative offset.+forwardGetRel :: ReadBinHandle -> IO a -> IO a+forwardGetRel bh get_A = do+    -- read forward reference+    p <- getRelBin bh+    -- store current position+    p_a <- tellBinReader bh+    -- go read the forward value, then seek back+    seekBinReader bh $ makeAbsoluteBin p+    r <- get_A+    seekBinReader bh p_a+    pure r++-- -----------------------------------------------------------------------------+-- Lazy reading/writing++lazyPut :: Binary a => WriteBinHandle -> a -> IO ()+lazyPut = lazyPut' put_++lazyGet :: Binary a => ReadBinHandle -> IO a+lazyGet = lazyGet' get++lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()+lazyPut' f bh a = do+    -- output the obj with a ptr to skip over it:+    pre_a <- tellBinWriter bh+    put_ bh pre_a       -- save a slot for the ptr+    f bh a           -- dump the object+    q <- tellBinWriter bh     -- q = ptr to after object+    putAtRel bh pre_a q    -- fill in slot before a with ptr to q+    seekBinWriter bh q        -- finally carry on writing at q++lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a+lazyGet' f bh = do+    p <- getRelBin bh -- a BinPtr+    p_a <- tellBinReader bh+    a <- unsafeInterleaveIO $ do+        -- NB: Use a fresh rbm_off_r variable in the child thread, for thread+        -- safety.+        off_r <- newFastMutInt 0+        let bh' = bh { rbm_off_r = off_r }+        seekBinReader bh' p_a+        f bh'+    seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now+    return a++-- | Serialize the constructor strictly but lazily serialize a value inside a+-- 'Just'.+--+-- This way we can check for the presence of a value without deserializing the+-- value itself.+lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO ()+lazyPutMaybe bh Nothing  = putWord8 bh 0+lazyPutMaybe bh (Just x) = do+  putWord8 bh 1+  lazyPut bh x++-- | Deserialize a value serialized by 'lazyPutMaybe'.+lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a)+lazyGetMaybe bh = do+  h <- getWord8 bh+  case h of+    0 -> pure Nothing+    _ -> Just <$> lazyGet bh++-- -----------------------------------------------------------------------------+-- UserData+-- -----------------------------------------------------------------------------++-- Note [Binary UserData]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- Information we keep around during interface file+-- serialization/deserialization. Namely we keep the functions for serializing+-- and deserializing 'Name's and 'FastString's. We do this because we actually+-- use serialization in two distinct settings,+--+-- * When serializing interface files themselves+--+-- * When computing the fingerprint of an IfaceDecl (which we computing by+--   hashing its Binary serialization)+--+-- These two settings have different needs while serializing Names:+--+-- * Names in interface files are serialized via a symbol table (see Note+--   [Symbol table representation of names] in "GHC.Iface.Binary").+--+-- * During fingerprinting a binding Name is serialized as the OccName and a+--   non-binding Name is serialized as the fingerprint of the thing they+--   represent. See Note [Fingerprinting IfaceDecls] for further discussion.+--++-- | Newtype to serialise binding names differently to non-binding 'Name'.+-- See Note [Binary UserData]+newtype BindingName = BindingName { getBindingName :: Name }+  deriving ( Eq )++simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName+simpleBindingNameWriter = coerce++simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName+simpleBindingNameReader = coerce++-- | Existential for 'BinaryWriter' with a type witness.+data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a)++-- | Existential for 'BinaryReader' with a type witness.+data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a)++-- | UserData required to serialise symbols for interface files.+--+-- See Note [Binary UserData]+data WriterUserData =+   WriterUserData {+      ud_writer_data :: Map SomeTypeRep SomeBinaryWriter+      -- ^ A mapping from a type witness to the 'Writer' for the associated type.+      -- This is a 'Map' because microbenchmarks indicated this is more efficient+      -- than other representations for less than ten elements.+      --+      -- Considered representations:+      --+      -- * [(TypeRep, SomeBinaryWriter)]+      -- * bytehash (on hackage)+      -- * Map TypeRep SomeBinaryWriter+   }++-- | UserData required to deserialise symbols for interface files.+--+-- See Note [Binary UserData]+data ReaderUserData =+   ReaderUserData {+      ud_reader_data :: Map SomeTypeRep SomeBinaryReader+      -- ^ A mapping from a type witness to the 'Reader' for the associated type.+      -- This is a 'Map' because microbenchmarks indicated this is more efficient+      -- than other representations for less than ten elements.+      --+      -- Considered representations:+      --+      -- * [(TypeRep, SomeBinaryReader)]+      -- * bytehash (on hackage)+      -- * Map TypeRep SomeBinaryReader+   }++mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData+mkWriterUserData caches = noWriterUserData+  { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (SomeTypeRep typRep, cache)) caches+  }++mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData+mkReaderUserData caches = noReaderUserData+  { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (SomeTypeRep typRep, cache)) caches+  }++mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter+mkSomeBinaryWriter cb = SomeBinaryWriter (Refl.typeRep @a) cb++mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader+mkSomeBinaryReader cb = SomeBinaryReader (Refl.typeRep @a) cb++newtype BinaryReader s = BinaryReader+  { getEntry :: ReadBinHandle -> IO s+  } deriving (Functor)++newtype BinaryWriter s = BinaryWriter+  { putEntry :: WriteBinHandle -> s -> IO ()+  }++mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s+mkWriter f = BinaryWriter+  { putEntry = f+  }++mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s+mkReader f = BinaryReader+  { getEntry = f+  }++-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'.+--+-- If no 'BinaryReader' has been configured before, this function will panic.+findUserDataReader :: forall a . Refl.Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a+findUserDataReader query bh =+  case Map.lookup (Refl.someTypeRep query) (ud_reader_data $ getReaderUserData bh) of+    Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (Refl.someTypeRep query)+    Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->+      unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader+      -- This 'unsafeCoerce' could be written safely like this:+      --+      -- @+      --   Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->+      --     case testEquality (typeRep @a) tyRep of+      --       Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader+      --       Nothing -> panic $ "Invariant violated"+      -- @+      --+      -- But it comes at a slight performance cost and this function is used in+      -- binary serialisation hot loops, thus, we prefer the small performance boost over+      -- the additional type safety.++-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'.+--+-- If no 'BinaryWriter' has been configured before, this function will panic.+findUserDataWriter :: forall a . Refl.Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a+findUserDataWriter query bh =+  case Map.lookup (Refl.someTypeRep query) (ud_writer_data $ getWriterUserData bh) of+    Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (Refl.someTypeRep query)+    Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) ->+      unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer+      -- This 'unsafeCoerce' could be written safely like this:+      --+      -- @+      --   Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) ->+      --     case testEquality (typeRep @a) tyRep of+      --       Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer+      --       Nothing -> panic $ "Invariant violated"+      -- @+      --+      -- But it comes at a slight performance cost and this function is used in+      -- binary serialisation hot loops, thus, we prefer the small performance boost over+      -- the additional type safety.+++noReaderUserData :: ReaderUserData+noReaderUserData = ReaderUserData+  { ud_reader_data = Map.empty+  }++noWriterUserData :: WriterUserData+noWriterUserData = WriterUserData+  { ud_writer_data = Map.empty+  }++newReadState :: (ReadBinHandle -> IO Name)   -- ^ how to deserialize 'Name's+             -> (ReadBinHandle -> IO FastString)+             -> ReaderUserData+newReadState get_name get_fs =+  mkReaderUserData+    [ mkSomeBinaryReader $ mkReader get_name+    , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name)+    , mkSomeBinaryReader $ mkReader get_fs+    ]++newWriteState :: (WriteBinHandle -> Name -> IO ())+                 -- ^ how to serialize non-binding 'Name's+              -> (WriteBinHandle -> Name -> IO ())+                 -- ^ how to serialize binding 'Name's+              -> (WriteBinHandle -> FastString -> IO ())+              -> WriterUserData+newWriteState put_non_binding_name put_binding_name put_fs =+  mkWriterUserData+    [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name))+    , mkSomeBinaryWriter $ mkWriter put_non_binding_name+    , mkSomeBinaryWriter $ mkWriter put_fs+    ]++-- ----------------------------------------------------------------------------+-- Types for lookup and deduplication tables.+-- ----------------------------------------------------------------------------++-- | A 'ReaderTable' describes how to deserialise a table from disk,+-- and how to create a 'BinaryReader' that looks up values in the deduplication table.+data ReaderTable a = ReaderTable+  { getTable :: ReadBinHandle -> IO (SymbolTable a)+  -- ^ Deserialise a list of elements into a 'SymbolTable'.+  , mkReaderFromTable :: SymbolTable a -> BinaryReader a+  -- ^ Given the table from 'getTable', create a 'BinaryReader'+  -- that reads values only from the 'SymbolTable'.+  }++-- | A 'WriterTable' is an interface any deduplication table can implement to+-- describe how the table can be written to disk.+newtype WriterTable = WriterTable+  { putTable :: WriteBinHandle -> IO Int+  -- ^ Serialise a table to disk. Returns the number of written elements.+  }++-- ----------------------------------------------------------------------------+-- Common data structures for constructing and maintaining lookup tables for+-- binary serialisation and deserialisation.+-- ----------------------------------------------------------------------------++-- | The 'GenericSymbolTable' stores a mapping from already seen elements to an index.+-- If an element wasn't seen before, it is added to the mapping together with a fresh+-- index.+--+-- 'GenericSymbolTable' is a variant of a 'BinSymbolTable' that is polymorphic in the table implementation.+-- As such it can be used with any container that implements the 'TrieMap' type class.+--+-- While 'GenericSymbolTable' is similar to the 'BinSymbolTable', it supports storing tree-like+-- structures such as 'Type' and 'IfaceType' more efficiently.+--+data GenericSymbolTable m = GenericSymbolTable+  { gen_symtab_next :: !FastMutInt+  -- ^ The next index to use.+  , gen_symtab_map  :: !(IORef (m Int))+  -- ^ Given a symbol, find the symbol and return its index.+  , gen_symtab_to_write :: !(IORef [Key m])+  -- ^ Reversed list of values to write into the buffer.+  -- This is an optimisation, as it allows us to write out quickly all+  -- newly discovered values that are discovered when serialising 'Key m'+  -- to disk.+  }++-- | Initialise a 'GenericSymbolTable', initialising the index to '0'.+initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m)+initGenericSymbolTable = do+  symtab_next <- newFastMutInt 0+  symtab_map <- newIORef emptyTM+  symtab_todo <- newIORef []+  pure $ GenericSymbolTable+        { gen_symtab_next = symtab_next+        , gen_symtab_map  = symtab_map+        , gen_symtab_to_write = symtab_todo+        }++-- | Serialise the 'GenericSymbolTable' to disk.+--+-- Since 'GenericSymbolTable' stores tree-like structures, such as 'IfaceType',+-- serialising an element can add new elements to the mapping.+-- Thus, 'putGenericSymbolTable' first serialises all values, and then checks whether any+-- new elements have been discovered. If so, repeat the loop.+putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int+{-# INLINE putGenericSymbolTable #-}+putGenericSymbolTable gen_sym_tab serialiser bh = do+  putGenericSymbolTable bh+  where+    symtab_next = gen_symtab_next gen_sym_tab+    symtab_to_write = gen_symtab_to_write gen_sym_tab+    putGenericSymbolTable :: WriteBinHandle -> IO Int+    putGenericSymbolTable bh  = do+      let loop = do+            vs <- atomicModifyIORef' symtab_to_write (\a -> ([], a))+            case vs of+              [] -> readFastMutInt symtab_next+              todo -> do+                mapM_ (\n -> serialiser bh n) (reverse todo)+                loop+      snd <$>+        (forwardPutRel bh (const $ readFastMutInt symtab_next >>= put_ bh) $+          loop)++-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'.+getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)+getGenericSymbolTable deserialiser bh = do+  sz <- forwardGetRel bh (get bh) :: IO Int+  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)+  forM_ [0..(sz-1)] $ \i -> do+    f <- deserialiser bh+    writeArray mut_arr i f+  unsafeFreeze mut_arr++-- | Write an element 'Key m' to the given 'WriteBinHandle'.+--+-- If the element was seen before, we simply write the index of that element to the+-- 'WriteBinHandle'. If we haven't seen it before, we add the element to+-- the 'GenericSymbolTable', increment the index, and return this new index.+putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()+{-# INLINE putGenericSymTab #-}+putGenericSymTab GenericSymbolTable{+               gen_symtab_map = symtab_map_ref,+               gen_symtab_next = symtab_next,+               gen_symtab_to_write = symtab_todo }+        bh val = do+  symtab_map <- readIORef symtab_map_ref+  case lookupTM val symtab_map of+    Just off -> put_ bh (fromIntegral off :: Word32)+    Nothing -> do+      off <- readFastMutInt symtab_next+      writeFastMutInt symtab_next (off+1)+      writeIORef symtab_map_ref+          $! insertTM val off symtab_map+      atomicModifyIORef symtab_todo (\todo -> (val : todo, ()))+      put_ bh (fromIntegral off :: Word32)++-- | Read a value from a 'SymbolTable'.+getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a+getGenericSymtab symtab bh = do+  i :: Word32 <- get bh+  return $! symtab ! fromIntegral i++---------------------------------------------------------+-- The Dictionary+---------------------------------------------------------++-- | A 'SymbolTable' of 'FastString's.+type Dictionary = SymbolTable FastString++initFastStringReaderTable :: IO (ReaderTable FastString)+initFastStringReaderTable = do+  return $+    ReaderTable+      { getTable = getDictionary+      , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl)+      }++initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString)+initFastStringWriterTable = do+  dict_next_ref <- newFastMutInt 0+  dict_map_ref <- newIORef emptyUFM+  let bin_dict =+        FSTable+          { fs_tab_next = dict_next_ref+          , fs_tab_map = dict_map_ref+          }+  let put_dict bh = do+        fs_count <- readFastMutInt dict_next_ref+        dict_map <- readIORef dict_map_ref+        putDictionary bh fs_count dict_map+        pure fs_count++  return+    ( WriterTable+        { putTable = put_dict+        }+    , mkWriter $ putDictFastString bin_dict+    )++putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()+putDictionary bh sz dict = do+  put_ bh sz+  mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))+    -- It's OK to use nonDetEltsUFM here because the elements have indices+    -- that array uses to create order++getDictionary :: ReadBinHandle -> IO Dictionary+getDictionary bh = do+  sz <- get bh :: IO Int+  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)+  forM_ [0..(sz-1)] $ \i -> do+    fs <- getFS bh+    writeArray mut_arr i fs+  unsafeFreeze mut_arr++getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString+getDictFastString dict bh = do+    j <- get bh+    return $! (dict ! fromIntegral (j :: Word32))++putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()+putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh++allocateFastString :: FSTable -> FastString -> IO Word32+allocateFastString FSTable { fs_tab_next = j_r+                           , fs_tab_map  = out_r+                           } f = do+    out <- readIORef out_r+    let !uniq = getUnique f+    case lookupUFM_Directly out uniq of+        Just (j, _)  -> return (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM_Directly out uniq (j, f)+           return (fromIntegral j :: Word32)++-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to+-- avoid a collision and copy to avoid a dependency.+data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use+                       , fs_tab_map  :: !(IORef (UniqFM FastString (Int,FastString)))+                                -- indexed by FastString+  }+++---------------------------------------------------------+-- The Symbol Table+---------------------------------------------------------++-- | Symbols that are read from disk.+-- The 'SymbolTable' index starts on '0'.+type SymbolTable a = Array Int a++---------------------------------------------------------+-- Reading and writing FastStrings+---------------------------------------------------------++putFS :: WriteBinHandle -> FastString -> IO ()+putFS bh fs = putSBS bh $ fastStringToShortByteString fs++getFS :: ReadBinHandle -> IO FastString+getFS bh = do+  l  <- get bh :: IO Int+  getPrim bh l (\src -> pure $! mkFastStringBytes src l )++-- | Put a ByteString without its length (can't be read back without knowing the+-- length!)+putByteString :: WriteBinHandle -> ByteString -> IO ()+putByteString bh bs =+  BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do+    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)++-- | Get a ByteString whose length is known+getByteString :: ReadBinHandle -> Int -> IO ByteString+getByteString bh l =+  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+    put_ bh l+    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)++getBS :: ReadBinHandle -> IO ByteString+getBS bh = do+  l <- get bh :: IO Int+  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++instance Binary FastString where+  put_ bh f =+    case findUserDataWriter (Proxy :: Proxy FastString) bh of+      tbl -> putEntry tbl bh f++  get bh =+    case findUserDataReader (Proxy :: Proxy FastString) bh of+      tbl -> getEntry tbl bh++deriving instance Binary NonDetFastString+deriving instance Binary LexicalFastString++instance Binary Fingerprint where+  put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2+  get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)++instance Binary ModuleName where+  put_ bh (ModuleName fs) = put_ bh fs+  get bh = do fs <- get bh; return (ModuleName fs)++-- instance Binary TupleSort where+--     put_ bh BoxedTuple      = putByte bh 0+--     put_ bh UnboxedTuple    = putByte bh 1+--     put_ bh ConstraintTuple = putByte bh 2+--     get bh = do+--       h <- getByte bh+--       case h of+--         0 -> do return BoxedTuple+--         1 -> do return UnboxedTuple+--         _ -> do return ConstraintTuple++-- instance Binary Activation where+--     put_ bh NeverActive = do+--             putByte bh 0+--     put_ bh FinalActive = do+--             putByte bh 1+--     put_ bh AlwaysActive = do+--             putByte bh 2+--     put_ bh (ActiveBefore src aa) = do+--             putByte bh 3+--             put_ bh src+--             put_ bh aa+--     put_ bh (ActiveAfter src ab) = do+--             putByte bh 4+--             put_ bh src+--             put_ bh ab+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do return NeverActive+--               1 -> do return FinalActive+--               2 -> do return AlwaysActive+--               3 -> do src <- get bh+--                       aa <- get bh+--                       return (ActiveBefore src aa)+--               _ -> do src <- get bh+--                       ab <- get bh+--                       return (ActiveAfter src ab)++-- instance Binary InlinePragma where+--     put_ bh (InlinePragma s a b c d) = do+--             put_ bh s+--             put_ bh a+--             put_ bh b+--             put_ bh c+--             put_ bh d++--     get bh = do+--            s <- get bh+--            a <- get bh+--            b <- get bh+--            c <- get bh+--            d <- get bh+--            return (InlinePragma s a b c d)++-- instance Binary RuleMatchInfo where+--     put_ bh FunLike = putByte bh 0+--     put_ bh ConLike = putByte bh 1+--     get bh = do+--             h <- getByte bh+--             if h == 1 then return ConLike+--                       else return FunLike++-- instance Binary InlineSpec where+--     put_ bh NoUserInlinePrag = putByte bh 0+--     put_ bh Inline           = putByte bh 1+--     put_ bh Inlinable        = putByte bh 2+--     put_ bh NoInline         = putByte bh 3++--     get bh = do h <- getByte bh+--                 case h of+--                   0 -> return NoUserInlinePrag+--                   1 -> return Inline+--                   2 -> return Inlinable+--                   _ -> return NoInline++-- instance Binary RecFlag where+--     put_ bh Recursive = do+--             putByte bh 0+--     put_ bh NonRecursive = do+--             putByte bh 1+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do return Recursive+--               _ -> do return NonRecursive++-- instance Binary OverlapMode where+--     put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s+--     put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s+--     put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s+--     put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s+--     put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+--     get bh = do+--         h <- getByte bh+--         case h of+--             0 -> (get bh) >>= \s -> return $ NoOverlap s+--             1 -> (get bh) >>= \s -> return $ Overlaps s+--             2 -> (get bh) >>= \s -> return $ Incoherent s+--             3 -> (get bh) >>= \s -> return $ Overlapping s+--             4 -> (get bh) >>= \s -> return $ Overlappable s+--             _ -> panic ("get OverlapMode" ++ show h)+++-- instance Binary OverlapFlag where+--     put_ bh flag = do put_ bh (overlapMode flag)+--                       put_ bh (isSafeOverlap flag)+--     get bh = do+--         h <- get bh+--         b <- get bh+--         return OverlapFlag { overlapMode = h, isSafeOverlap = b }++-- instance Binary FixityDirection where+--     put_ bh InfixL = do+--             putByte bh 0+--     put_ bh InfixR = do+--             putByte bh 1+--     put_ bh InfixN = do+--             putByte bh 2+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do return InfixL+--               1 -> do return InfixR+--               _ -> do return InfixN++-- instance Binary Fixity where+--     put_ bh (Fixity src aa ab) = do+--             put_ bh src+--             put_ bh aa+--             put_ bh ab+--     get bh = do+--           src <- get bh+--           aa <- get bh+--           ab <- get bh+--           return (Fixity src aa ab)++-- instance Binary WarningTxt where+--     put_ bh (WarningTxt s w) = do+--             putByte bh 0+--             put_ bh s+--             put_ bh w+--     put_ bh (DeprecatedTxt s d) = do+--             putByte bh 1+--             put_ bh s+--             put_ bh d++--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do s <- get bh+--                       w <- get bh+--                       return (WarningTxt s w)+--               _ -> do s <- get bh+--                       d <- get bh+--                       return (DeprecatedTxt s d)++-- instance Binary StringLiteral where+--   put_ bh (StringLiteral st fs _) = do+--             put_ bh st+--             put_ bh fs+--   get bh = do+--             st <- get bh+--             fs <- get bh+--             return (StringLiteral st fs Nothing)++newtype BinLocated a = BinLocated { unBinLocated :: Located a }++instance Binary a => Binary (BinLocated a) where+    put_ bh (BinLocated (L l x)) = do+            put_ bh $ BinSrcSpan l+            put_ bh x++    get bh = do+            l <- unBinSrcSpan <$> get bh+            x <- get bh+            return $ BinLocated (L l x)++newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan }++-- See Note [Source Location Wrappers]+instance Binary BinSpan where+  put_ bh (BinSpan ss) = do+            put_ bh (srcSpanFile ss)+            put_ bh (srcSpanStartLine ss)+            put_ bh (srcSpanStartCol ss)+            put_ bh (srcSpanEndLine ss)+            put_ bh (srcSpanEndCol ss)++  get bh = do+            f <- get bh+            sl <- get bh+            sc <- get bh+            el <- get bh+            ec <- get bh+            return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc)+                                            (mkRealSrcLoc f el ec))++instance Binary UnhelpfulSpanReason where+  put_ bh r = case r of+    UnhelpfulNoLocationInfo -> putByte bh 0+    UnhelpfulWiredIn        -> putByte bh 1+    UnhelpfulInteractive    -> putByte bh 2+    UnhelpfulGenerated      -> putByte bh 3+    UnhelpfulOther fs       -> putByte bh 4 >> put_ bh fs++  get bh = do+    h <- getByte bh+    case h of+      0 -> return UnhelpfulNoLocationInfo+      1 -> return UnhelpfulWiredIn+      2 -> return UnhelpfulInteractive+      3 -> return UnhelpfulGenerated+      _ -> UnhelpfulOther <$> get bh++newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan }++-- See Note [Source Location Wrappers]+instance Binary BinSrcSpan where+  put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do+          putByte bh 0+          -- BufSpan doesn't ever get serialised because the positions depend+          -- on build location.+          put_ bh $ BinSpan ss++  put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do+          putByte bh 1+          put_ bh s++  get bh = do+          h <- getByte bh+          case h of+            0 -> do BinSpan ss <- get bh+                    return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)+            _ -> do s <- get bh+                    return $ BinSrcSpan (UnhelpfulSpan s)+++{-+Note [Source Location Wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Source locations are banned from interface files, to+prevent filepaths affecting interface hashes.++Unfortunately, we can't remove all binary instances,+as they're used to serialise .hie files, and we don't+want to break binary compatibility.++To this end, the Bin[Src]Span newtypes wrappers were+introduced to prevent accidentally serialising a+source location as part of a larger structure.+-}++--------------------------------------------------------------------------------+-- Instances for the containers package+--------------------------------------------------------------------------------++instance (Binary v) => Binary (IntMap v) where+  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/Binary/Typeable.hs view
@@ -4,9 +4,6 @@  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} {-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-}-#if MIN_VERSION_base(4,16,0)-#define HAS_TYPELITCHAR-#endif  -- | Orphan Binary instances for Data.Typeable stuff module GHC.Utils.Binary.Typeable@@ -19,9 +16,7 @@ import GHC.Utils.Binary  import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))-#if __GLASGOW_HASKELL__ >= 901 import GHC.Exts (Levity(Lifted, Unlifted))-#endif import GHC.Serialized  import Foreign@@ -40,7 +35,7 @@     get bh =         mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -getSomeTypeRep :: BinHandle -> IO SomeTypeRep+getSomeTypeRep :: ReadBinHandle -> IO SomeTypeRep getSomeTypeRep bh = do     tag <- get bh :: IO Word8     case tag of@@ -102,13 +97,8 @@     put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b     put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps     put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps-#if __GLASGOW_HASKELL__ >= 901     put_ bh (BoxedRep Lifted)   = putByte bh 3     put_ bh (BoxedRep Unlifted) = putByte bh 4-#else-    put_ bh LiftedRep       = putByte bh 3-    put_ bh UnliftedRep     = putByte bh 4-#endif     put_ bh IntRep          = putByte bh 5     put_ bh WordRep         = putByte bh 6     put_ bh Int64Rep        = putByte bh 7@@ -129,13 +119,8 @@           0  -> VecRep <$> get bh <*> get bh           1  -> TupleRep <$> get bh           2  -> SumRep <$> get bh-#if __GLASGOW_HASKELL__ >= 901           3  -> pure (BoxedRep Lifted)           4  -> pure (BoxedRep Unlifted)-#else-          3  -> pure LiftedRep-          4  -> pure UnliftedRep-#endif           5  -> pure IntRep           6  -> pure WordRep           7  -> pure Int64Rep@@ -173,20 +158,16 @@ instance Binary TypeLitSort where     put_ bh TypeLitSymbol = putByte bh 0     put_ bh TypeLitNat = putByte bh 1-#if defined(HAS_TYPELITCHAR)     put_ bh TypeLitChar = putByte bh 2-#endif     get bh = do         tag <- getByte bh         case tag of           0 -> pure TypeLitSymbol           1 -> pure TypeLitNat-#if defined(HAS_TYPELITCHAR)           2 -> pure TypeLitChar-#endif           _ -> fail "Binary.putTypeLitSort: invalid tag" -putTypeRep :: BinHandle -> TypeRep a -> IO ()+putTypeRep :: WriteBinHandle -> TypeRep a -> IO () putTypeRep bh rep -- Handle Type specially since it's so common   | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)   = put_ bh (0 :: Word8)@@ -198,12 +179,6 @@     put_ bh (2 :: Word8)     putTypeRep bh f     putTypeRep bh x-#if __GLASGOW_HASKELL__ < 903-putTypeRep bh (Fun arg res) = do-    put_ bh (3 :: Word8)-    putTypeRep bh arg-    putTypeRep bh res-#endif  instance Binary Serialized where     put_ bh (Serialized the_type bytes) = do
compiler/GHC/Utils/BufHandle.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}  -----------------------------------------------------------------------------
compiler/GHC/Utils/Containers/Internal/BitUtil.hs view
@@ -1,10 +1,5 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif  ----------------------------------------------------------------------------- -- |
compiler/GHC/Utils/Containers/Internal/StrictPair.hs view
@@ -1,14 +1,13 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif  -- | A strict pair  module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where -import Prelude () -- for build ordering; see #23942 and-                  -- Note [Depend on GHC.Num.Integer] in base:GHC.Base+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Base ()++default ()  -- | The same as a regular Haskell pair, but --
compiler/GHC/Utils/Error.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE BangPatterns    #-}-{-# LANGUAGE DeriveFunctor   #-}-{-# LANGUAGE RankNTypes      #-} {-# LANGUAGE ViewPatterns    #-}-{-# LANGUAGE TypeApplications #-}  {- (c) The AQUA Project, Glasgow University, 1994-1998@@ -32,7 +28,7 @@         formatBulleted,          -- ** Construction-        DiagOpts (..), diag_wopt, diag_fatal_wopt,+        DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt,         emptyMessages, mkDecorated, mkLocMessage,         mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,         mkErrorMsgEnvelope,@@ -75,10 +71,10 @@ import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc+import GHC.Unit.Module.Warnings  import System.Exit      ( ExitCode(..), exitWith ) import Data.List        ( sortBy )@@ -89,49 +85,93 @@ import Control.Monad.Catch as MC (handle) import GHC.Conc         ( getAllocationCounter ) import System.CPUTime+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE  data DiagOpts = DiagOpts   { diag_warning_flags       :: !(EnumSet WarningFlag) -- ^ Enabled warnings   , diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings+  , diag_custom_warning_categories       :: !WarningCategorySet -- ^ Enabled custom warning categories+  , diag_fatal_custom_warning_categories :: !WarningCategorySet -- ^ Fatal custom warning categories   , diag_warn_is_error       :: !Bool                  -- ^ Treat warnings as errors   , diag_reverse_errors      :: !Bool                  -- ^ Reverse error reporting order   , diag_max_errors          :: !(Maybe Int)           -- ^ Max reported error count   , diag_ppr_ctx             :: !SDocContext           -- ^ Error printing context   } +emptyDiagOpts :: DiagOpts+emptyDiagOpts =+    DiagOpts+        { diag_warning_flags = EnumSet.empty+        , diag_fatal_warning_flags = EnumSet.empty+        , diag_custom_warning_categories = emptyWarningCategorySet+        , diag_fatal_custom_warning_categories = emptyWarningCategorySet+        , diag_warn_is_error = False+        , diag_reverse_errors = False+        , diag_max_errors = Nothing+        , diag_ppr_ctx = defaultSDocContext+        }+ diag_wopt :: WarningFlag -> DiagOpts -> Bool diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts  diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts +diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool+diag_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_custom_warning_categories opts++diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool+diag_fatal_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_fatal_custom_warning_categories opts+ -- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of -- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed, -- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a -- particular diagnostic message is built, otherwise the computed 'Severity' might -- not be correct, due to the mutable nature of the 'DynFlags' in GHC.+--+-- diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity-diagReasonSeverity opts reason = case reason of-  WarningWithFlag wflag-    | not (diag_wopt wflag opts) -> SevIgnore-    | diag_fatal_wopt wflag opts -> SevError-    | otherwise                  -> SevWarning+diagReasonSeverity opts reason = fst (diag_reason_severity opts reason)++-- Like the diagReasonSeverity but the second half of the pair is a small+-- ReasolvedDiagnosticReason which would cause the diagnostic to be triggered with the+-- same severity.+--+-- See Note [Warnings controlled by multiple flags]+--+diag_reason_severity :: DiagOpts -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason)+diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason of+  WarningWithFlags wflags -> case wflags' of+    []     -> (SevIgnore, reason)+    w : ws -> case wflagsE of+      []     -> (SevWarning, WarningWithFlags (w :| ws))+      e : es -> (SevError, WarningWithFlags (e :| es))+    where+      wflags' = NE.filter (\wflag -> diag_wopt wflag opts) wflags+      wflagsE = filter (\wflag -> diag_fatal_wopt wflag opts) wflags'++  WarningWithCategory wcat+    | not (diag_wopt_custom wcat opts) -> (SevIgnore, reason)+    | diag_fatal_wopt_custom wcat opts -> (SevError, reason)+    | otherwise                        -> (SevWarning, reason)   WarningWithoutFlag-    | diag_warn_is_error opts -> SevError-    | otherwise             -> SevWarning+    | diag_warn_is_error opts -> (SevError, reason)+    | otherwise             -> (SevWarning, reason)   ErrorWithoutFlag-    -> SevError-+    -> (SevError, reason)  -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the--- 'DiagOpts.+-- 'DiagOpts'. mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass-mkMCDiagnostic opts reason code = MCDiagnostic (diagReasonSeverity opts reason) reason code+mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code+  where+    (sev, reason') = diag_reason_severity opts reason  -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the -- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. errorDiagnostic :: MessageClass-errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag Nothing+errorDiagnostic = MCDiagnostic SevError (ResolvedDiagnosticReason ErrorWithoutFlag) Nothing  -- -- Creating MsgEnvelope(s)@@ -142,13 +182,15 @@   => Severity   -> SrcSpan   -> NamePprCtx+  -> ResolvedDiagnosticReason   -> e   -> MsgEnvelope e-mk_msg_envelope severity locn name_ppr_ctx err+mk_msg_envelope severity locn name_ppr_ctx reason err  = MsgEnvelope { errMsgSpan = locn                , errMsgContext = name_ppr_ctx                , errMsgDiagnostic = err                , errMsgSeverity = severity+               , errMsgReason = reason                }  -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.@@ -162,7 +204,9 @@   -> e   -> MsgEnvelope e mkMsgEnvelope opts locn name_ppr_ctx err- = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn name_ppr_ctx err+ = mk_msg_envelope sev locn name_ppr_ctx reason err+  where+    (sev, reason) = diag_reason_severity opts (diagnosticReason err)  -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. -- Precondition: the diagnostic is, in fact, an error. That is,@@ -173,7 +217,7 @@                    -> e                    -> MsgEnvelope e mkErrorMsgEnvelope locn name_ppr_ctx msg =- assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx msg+ assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx (ResolvedDiagnosticReason ErrorWithoutFlag) msg  -- | Variant that doesn't care about qualified/unqualified names. mkPlainMsgEnvelope :: Diagnostic e@@ -191,7 +235,7 @@                         -> e                         -> MsgEnvelope e mkPlainErrorMsgEnvelope locn msg =-  mk_msg_envelope SevError locn alwaysQualify msg+  mk_msg_envelope SevError locn alwaysQualify (ResolvedDiagnosticReason ErrorWithoutFlag) msg  ------------------------- data Validity' a@@ -219,14 +263,14 @@  ---------------- -- | Formats the input list of structured document, where each element of the list gets a bullet.-formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc-formatBulleted ctx (unDecorated -> docs)-  = case msgs of+formatBulleted :: DecoratedSDoc -> SDoc+formatBulleted (unDecorated -> docs)+  = sdocWithContext $ \ctx -> case msgs ctx of         []    -> Outputable.empty         [msg] -> msg-        _     -> vcat $ map starred msgs+        xs    -> vcat $ map starred xs     where-    msgs    = filter (not . Outputable.isEmpty ctx) docs+    msgs ctx = filter (not . Outputable.isEmpty ctx) docs     starred = (bullet<+>)  pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc@@ -247,13 +291,13 @@ pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan      = s                                , errMsgDiagnostic = e                                , errMsgSeverity  = sev-                               , errMsgContext   = name_ppr_ctx })-  = sdocWithContext $ \ctx ->-    withErrStyle name_ppr_ctx $+                               , errMsgContext   = name_ppr_ctx+                               , errMsgReason    = reason })+  = withErrStyle name_ppr_ctx $       mkLocMessage-        (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e))+        (MCDiagnostic sev reason (diagnosticCode e))         s-        (formatBulleted ctx $ diagnosticMessage opts e)+        (formatBulleted $ diagnosticMessage opts e)  sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList@@ -365,7 +409,7 @@             -> m a withTiming' logger what force_result prtimings action   = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings-    then do whenPrintTimings $+    then do when printTimingsNotDumpToFile $ liftIO $               logInfo logger $ withPprStyle defaultUserStyle $                 text "***" <+> what <> colon             let ctx = log_default_user_context (logFlags logger)@@ -383,7 +427,7 @@             let alloc = alloc0 - alloc1                 time = realToFrac (end - start) * 1e-9 -            when (logVerbAtLeast logger 2 && prtimings == PrintTimings)+            when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile)                 $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle                     (text "!!!" <+> what <> colon <+> text "finished in"                      <+> doublePrec 2 time@@ -403,7 +447,16 @@             pure r      else action -    where whenPrintTimings = liftIO . when (prtimings == PrintTimings)+    where whenPrintTimings =+            liftIO . when printTimings++          printTimings =+            prtimings == PrintTimings++          -- Avoid both printing to console and dumping to a file (#20316).+          printTimingsNotDumpToFile =+            printTimings+            && not (log_dump_to_file (logFlags logger))            recordAllocs alloc =             liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc
compiler/GHC/Utils/FV.hs view
@@ -3,8 +3,6 @@  -} -{-# LANGUAGE BangPatterns #-}- -- | Utilities for efficiently and deterministically computing free variables. module GHC.Utils.FV (         -- * Deterministic free vars computations@@ -23,6 +21,7 @@         delFVs,         filterFV,         mapUnionFV,+        fvDVarSetSome,     ) where  import GHC.Prelude@@ -197,3 +196,7 @@ mkFVs vars fv_cand in_scope acc =   mapUnionFV unitFV vars fv_cand in_scope acc {-# INLINE mkFVs #-}++fvDVarSetSome :: InterestingVarFun -> FV -> DVarSet+fvDVarSetSome interesting_var fv =+  mkDVarSet $ fst $ fv interesting_var emptyVarSet ([], emptyVarSet)
compiler/GHC/Utils/Fingerprint.hs view
@@ -19,6 +19,7 @@         fingerprintFingerprints,         fingerprintData,         fingerprintString,+        fingerprintStrings,         getFileHash    ) where @@ -43,3 +44,7 @@ fingerprintByteString :: BS.ByteString -> Fingerprint fingerprintByteString bs = unsafeDupablePerformIO $   BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len++-- See Note [Repeated -optP hashing]+fingerprintStrings :: [String] -> Fingerprint+fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
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/Lexeme.hs view
@@ -219,13 +219,14 @@   OtherNumber     -> True -- See #4373   _               -> c == '\'' || c == '_' --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.+-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report,+-- plus the GHC-specific @forall@ keyword (see GHC Proposal #281). reservedIds :: Set.Set String reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"-                           , "do", "else", "foreign", "if", "import", "in"-                           , "infix", "infixl", "infixr", "instance", "let"-                           , "module", "newtype", "of", "then", "type", "where"-                           , "_" ]+                           , "do", "else", "forall", "foreign", "if", "import"+                           , "in", "infix", "infixl", "infixr", "instance"+                           , "let", "module", "newtype", "of", "then", "type"+                           , "where", "_" ]  -- | All reserved operators. Taken from section 2.4 of the 2010 Report, -- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229).
compiler/GHC/Utils/Logger.hs view
@@ -24,6 +24,7 @@     -- * Logger setup     , initLogger     , LogAction+    , LogJsonAction     , DumpAction     , TraceAction     , DumpFormat (..)@@ -31,6 +32,8 @@     -- ** Hooks     , popLogHook     , pushLogHook+    , popJsonLogHook+    , pushJsonLogHook     , popDumpHook     , pushDumpHook     , popTraceHook@@ -49,12 +52,14 @@     , logVerbAtLeast      -- * Logging-    , jsonLogAction     , putLogMsg     , defaultLogAction+    , defaultLogActionWithHandles+    , defaultLogJsonAction     , defaultLogActionHPrintDoc     , defaultLogActionHPutStrDoc     , logMsg+    , logJsonMsg     , logDumpMsg      -- * Dumping@@ -87,6 +92,7 @@  import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.FastString  import System.Directory import System.FilePath  ( takeDirectory, (</>) )@@ -111,6 +117,7 @@   , log_default_dump_context :: SDocContext   , log_dump_flags           :: !(EnumSet DumpFlag) -- ^ Dump flags   , log_show_caret           :: !Bool               -- ^ Show caret in diagnostics+  , log_diagnostics_as_json  :: !Bool               -- ^ Format diagnostics as JSON   , log_show_warn_groups     :: !Bool               -- ^ Show warning flag groups   , log_enable_timestamps    :: !Bool               -- ^ Enable timestamps   , log_dump_to_file         :: !Bool               -- ^ Enable dump to file@@ -130,6 +137,7 @@   , log_default_dump_context = defaultSDocContext   , log_dump_flags           = EnumSet.empty   , log_show_caret           = True+  , log_diagnostics_as_json  = False   , log_show_warn_groups     = True   , log_enable_timestamps    = True   , log_dump_to_file         = False@@ -177,6 +185,11 @@               -> SDoc               -> IO () +type LogJsonAction = LogFlags+                   -> MessageClass+                   -> JsonDoc+                   -> IO ()+ type DumpAction = LogFlags                -> PprStyle                -> DumpFlag@@ -214,6 +227,9 @@     { log_hook   :: [LogAction -> LogAction]         -- ^ Log hooks stack +    , json_log_hook :: [LogJsonAction -> LogJsonAction]+        -- ^ Json log hooks stack+     , dump_hook  :: [DumpAction -> DumpAction]         -- ^ Dump hooks stack @@ -249,6 +265,7 @@     dumps <- newMVar Map.empty     return $ Logger         { log_hook        = []+        , json_log_hook   = []         , dump_hook       = []         , trace_hook      = []         , generated_dumps = dumps@@ -260,6 +277,10 @@ putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) +-- | Log a JsonDoc+putJsonLogMsg :: Logger -> LogJsonAction+putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger)+ -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger =@@ -284,6 +305,15 @@     []   -> panic "popLogHook: empty hook stack"     _:hs -> logger { log_hook = hs } +-- | Push a json log hook+pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger+pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger }++popJsonLogHook :: Logger -> Logger+popJsonLogHook logger = case json_log_hook logger of+    []   -> panic "popJsonLogHook: empty hook stack"+    _:hs -> logger { json_log_hook = hs}+ -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }@@ -328,24 +358,60 @@            $ logger  -- See Note [JSON Error Messages]----jsonLogAction :: LogAction-jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message-jsonLogAction logflags msg_class srcSpan msg+defaultLogJsonAction :: LogJsonAction+defaultLogJsonAction logflags msg_class jsdoc =+  case msg_class of+      MCOutput                     -> printOut msg+      MCDump                       -> printOut (msg $$ blankLine)+      MCInteractive                -> putStrSDoc msg+      MCInfo                       -> printErrs msg+      MCFatal                      -> printErrs msg+      MCDiagnostic SevIgnore _ _   -> pure () -- suppress the message+      MCDiagnostic _sev _rea _code -> printErrs msg+  where+    printOut   = defaultLogActionHPrintDoc  logflags False stdout+    printErrs  = defaultLogActionHPrintDoc  logflags False stderr+    putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout+    msg = renderJSON jsdoc++-- See Note [JSON Error Messages]+-- this is to be removed+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       doc = renderJSON $-              JSObject [ ( "span", json srcSpan )+              JSObject [ ( "span", spanToDumpJSON srcSpan )                        , ( "doc" , JSString str )                        , ( "messageClass", json msg_class )                        ]+      spanToDumpJSON :: SrcSpan -> JsonDoc+      spanToDumpJSON s = case s of+                 (RealSrcSpan rss _) -> JSObject [ ("file", json file)+                                                , ("startLine", json $ srcSpanStartLine rss)+                                                , ("startCol", json $ srcSpanStartCol rss)+                                                , ("endLine", json $ srcSpanEndLine rss)+                                                , ("endCol", json $ srcSpanEndCol rss)+                                                ]+                   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)@@ -355,21 +421,20 @@       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        printDiagnostics = do-        hPutChar stderr '\n'         caretDiagnostic <-             if log_show_caret logflags             then getCaretDiagnostic msg_class srcSpan             else pure empty         printErrs $ getPprStyle $ \style ->           withPprStyle (setStyleColoured True style)-            (message $+$ caretDiagnostic)+            (message $+$ caretDiagnostic $+$ blankLine)         -- careful (#2302): printErrs prints in UTF-8,         -- whereas converting to string first and using         -- hPutStr would just emit the low 8 bits of@@ -403,6 +468,12 @@ -- information to provide to the user but refactoring log_action is quite -- invasive as it is called in many places. So, for now I left it alone -- and we can refine its behaviour as users request different output.+--+-- The recent work here replaces the purpose of flag -ddump-json with+-- -fdiagnostics-as-json. For temporary backwards compatibility while+-- -ddump-json is being deprecated, `jsonLogAction` has been added in, but+-- it should be removed along with -ddump-json. Similarly, the guard in+-- `defaultLogAction` should be removed. This cleanup is tracked in #24113.  -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction@@ -505,7 +576,7 @@      getPrefix          -- dump file location is being forced-         --      by the --ddump-file-prefix flag.+         --      by the -ddump-file-prefix flag.        | Just prefix <- log_dump_prefix_override logflags           = prefix          -- dump file locations, module specified to [modulename] set by@@ -531,6 +602,9 @@ -- | Log something logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg++logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()+logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc  (json d)  -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
compiler/GHC/Utils/Misc.hs view
@@ -1,11 +1,9 @@ -- (c) The University of Glasgow 2006  {-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Highly random utility functions --@@ -22,12 +20,13 @@         unzipWith,          mapFst, mapSnd, chkAppend,-        mapAndUnzip, mapAndUnzip3,-        filterOut, partitionWith,+        mapAndUnzip, mapAndUnzip3, mapAndUnzip4,+        filterOut, partitionWith, partitionWithM,          dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, -        List.foldl1', foldl2, count, countWhile, all2,+        foldl2, count, countWhile, all2, any2, all2Prefix, all3Prefix,+        foldr1WithDefault, foldl1WithDefault',          lengthExceeds, lengthIs, lengthIsNot,         lengthAtLeast, lengthAtMost, lengthLessThan,@@ -35,14 +34,11 @@         equalLength, compareLength, leLength, ltLength,          isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,-        notNull, snocView,--        chunkList,+        notNull, expectNonEmpty, snocView,          holes,          changeLast,-        mapLastM,          whenNonEmpty, @@ -55,6 +51,7 @@          -- * Tuples         fstOf3, sndOf3, thdOf3,+        fstOf4, sndOf4,         fst3, snd3, third3,         uncurry3, @@ -121,6 +118,7 @@     ) where  import GHC.Prelude.Basic hiding ( head, init, last, tail )+import qualified GHC.Prelude.Basic as Partial ( head )  import GHC.Utils.Exception import GHC.Utils.Panic.Plain@@ -129,12 +127,11 @@  import Data.Data import qualified Data.List as List-import qualified Data.List as Partial ( head ) import Data.List.NonEmpty  ( NonEmpty(..), last, nonEmpty )-import qualified Data.List.NonEmpty as NE -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 )@@ -145,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 )@@ -183,6 +181,11 @@ sndOf3      (_,b,_) =  b thdOf3      (_,_,c) =  c +fstOf4   :: (a,b,c,d) -> a+sndOf4   :: (a,b,c,d) -> b+fstOf4      (a,_,_,_) =  a+sndOf4      (_,b,_,_) =  b+ fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) fst3 f (a, b, c) = (f a, b, c) @@ -215,6 +218,17 @@                          Right c -> (bs, c:cs)     where (bs,cs) = partitionWith f xs +partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])+-- ^ Monadic version of `partitionWith`+partitionWithM _ [] = return ([], [])+partitionWithM f (x:xs) = do+  y <- f x+  (bs, cs) <- partitionWithM f xs+  case y of+    Left  b -> return (b:bs, cs)+    Right c -> return (bs, c:cs)+{-# INLINEABLE partitionWithM #-}+ chkAppend :: [a] -> [a] -> [a] -- Checks for the second argument being empty -- Used in situations where that situation is common@@ -228,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@@ -314,24 +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)- zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip f (a:as) (b:bs)   = let (r1,  r2)  = f a b@@ -472,20 +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 :: HasCallStack => 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)----- | Split a list into chunks of /n/ elements-chunkList :: Int -> [a] -> [[a]]-chunkList _ [] = []-chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs+expectOnly _     = panic "expectOnly"  -- | Compute all the ways of removing a single element from a list. --@@ -500,11 +491,17 @@ changeLast [_]    x  = [x] changeLast (x:xs) x' = x : changeLast xs x' --- | Apply an effectful function to the last list element.-mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a)-mapLastM f (x:|[]) = NE.singleton <$> f x-mapLastM f (x0:|x1:xs) = (x0 NE.<|) <$> mapLastM f (x1:|xs)+-- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'.+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 []     = expectNonEmptyPanic +expectNonEmptyPanic :: HasCallStack => a+expectNonEmptyPanic = panic "expectNonEmpty"+{-# NOINLINE expectNonEmptyPanic #-}+ whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty []     _ = pure () whenNonEmpty (x:xs) f = f (x :| xs)@@ -637,6 +634,42 @@ all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _      _      = False +any2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool+-- True if any of the corresponding elements satisfy the predicate+-- Unlike `all2`, this ignores excess elements of the other list+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@@ -1028,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)@@ -1048,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')@@ -1417,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/Monad.hs view
@@ -11,13 +11,14 @@         , MonadIO(..)          , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM+        , zipWith3MNE         , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M         , mapAccumLM         , mapSndM         , concatMapM         , mapMaybeM         , anyM, allM, orM-        , foldlM, foldlM_, foldrM+        , foldlM, foldlM_, foldrM, foldMapM         , whenM, unlessM         , filterOutM         , partitionM@@ -36,6 +37,7 @@ import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid (Ap (Ap, getAp)) import Data.Tuple (swap)  -------------------------------------------------------------------------------@@ -97,6 +99,15 @@        ; return (c:cs, d:ds) } zipWithAndUnzipM _ _ _ = return ([], []) +-- | 'zipWith3M' for 'NonEmpty' lists.+zipWith3MNE :: Monad m+            => (a -> b -> c -> m d)+            -> NonEmpty a -> NonEmpty b -> NonEmpty c -> m (NonEmpty d)+zipWith3MNE f ~(x :| xs) ~(y :| ys) ~(z :| zs)+  = do { w  <- f x y z+       ; ws <- zipWith3M f xs ys zs+       ; return $ w :| ws }+ {-  Note [Inline @mapAndUnzipNM@ functions]@@ -217,6 +228,10 @@ -- | Monadic version of foldl that discards its result foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = foldM_++-- | Monadic version of 'foldMap'+foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b+foldMapM f = getAp <$> foldMap (Ap . f)  -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m ()
compiler/GHC/Utils/Monad/State/Strict.hs view
@@ -4,7 +4,7 @@ -- | A state monad which is strict in its state. module GHC.Utils.Monad.State.Strict   ( -- * The State monad-    State(State)+    State(State, State' {- for deriving via purposes only -})   , state   , evalState   , execState@@ -78,8 +78,10 @@ forceState :: (# a, s #) -> (# a, s #) forceState (# a, !s #) = (# a, s #) +-- See Note [The one-shot state monad trick] for why we don't derive this. instance Functor (State s) where   fmap f m = State $ \s -> case runState' m s  of (# x, s' #) -> (# f x, s' #)+  {-# INLINE fmap #-}  instance Applicative (State s) where   pure x  = State $ \s -> (# x, s #)@@ -87,10 +89,20 @@     case runState' m s  of { (# f, s' #) ->     case runState' n s' of { (# x, s'' #) ->                              (# f x, s'' #) }}+  m *> n = State $ \s ->+    case runState' m s of { (# _, s' #) ->+    case runState' n s' of { (# x, s'' #) ->+                             (# x, s'' #) }}+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+  {-# INLINE (*>) #-}  instance Monad (State s) where   m >>= n = State $ \s -> case runState' m s of     (# r, !s' #) -> runState' (n r) s'+  (>>) = (*>)+  {-# INLINE (>>=) #-}+  {-# INLINE (>>) #-}  state :: (s -> (a, s)) -> State s a state f = State $ \s -> case f s of (r, s') -> (# r, s' #)
compiler/GHC/Utils/Outputable.hs view
@@ -23,6 +23,7 @@ module GHC.Utils.Outputable (         -- * Type classes         Outputable(..), OutputableBndr(..), OutputableP(..),+        BindingSite(..),  JoinPointHood(..), isJoinPoint,          IsOutput(..), IsLine(..), IsDoc(..),         HLine, HDoc,@@ -31,13 +32,15 @@         SDoc, runSDoc, PDoc(..),         docToSDoc,         interppSP, interpp'SP, interpp'SP',-        pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,+        pprQuotedList, pprWithCommas, pprWithSemis,+        unquotedListWith, pprUnquotedSet,+        quotedListWithOr, quotedListWithNor, quotedListWithAnd,         pprWithBars,         spaceIfSingleQuote,         isEmpty, nest,         ptext,         int, intWithCommas, integer, word64, word, float, double, rational, doublePrec,-        parens, cparen, brackets, braces, quotes, quote,+        parens, cparen, brackets, braces, quotes, quote, quoteIfPunsEnabled,         doubleQuotes, angleBrackets,         semi, comma, colon, dcolon, space, equals, dot, vbar,         arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,@@ -46,10 +49,11 @@         blankLine, forAllLit, bullet,         ($+$),         cat, fcat,-        hang, hangNotEmpty, punctuate, ppWhen, ppUnless,-        ppWhenOption, ppUnlessOption,-        speakNth, speakN, speakNOf, plural, singular,+        hang, hangNotEmpty, punctuate, punctuateFinal,+        ppWhen, ppUnless, ppWhenOption, ppUnlessOption,+        speakNth, speakN, speakNOf, plural, singular, pluralSet,         isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,+        itOrThey,         unicodeSyntax,          coloured, keyword,@@ -85,8 +89,6 @@         pprModuleName,          -- * Controlling the style in which output is printed-        BindingSite(..),-         PprStyle(..), NamePprCtx(..),         QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick,         PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton,@@ -126,10 +128,11 @@ import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr       ( Doc, Mode(..) )+import GHC.Utils.Panic.Plain (assert) import GHC.Serialized import GHC.LanguageExtensions (Extension) import GHC.Utils.GlobalVars( unsafeHasPprDebug )-import GHC.Utils.Misc (lastMaybe)+import GHC.Utils.Misc (lastMaybe, snocView)  import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -139,6 +142,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set+import qualified Data.IntSet as IntSet import qualified GHC.Data.Word64Set as Word64Set import Data.String import Data.Word@@ -149,10 +153,12 @@ import Data.Graph (SCC(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup (Arg(..)) import qualified Data.List.NonEmpty as NEL-import Data.Time+import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 import Data.Void+import Control.DeepSeq (NFData(rnf))  import GHC.Fingerprint import GHC.Show         ( showMultiLineString )@@ -207,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.@@ -262,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@@ -393,6 +399,7 @@   , sdocCanUseUnicode               :: !Bool       -- ^ True if Unicode encoding is supported       -- and not disabled by GHC_NO_UNICODE environment variable+  , sdocPrintErrIndexLinks          :: !Bool   , sdocHexWordLiterals             :: !Bool   , sdocPprDebug                    :: !Bool   , sdocPrintUnicodeSyntax          :: !Bool@@ -454,6 +461,7 @@   , sdocDefaultDepth                = 5   , sdocLineLength                  = 100   , sdocCanUseUnicode               = False+  , sdocPrintErrIndexLinks          = False   , sdocHexWordLiterals             = False   , sdocPprDebug                    = False   , sdocPrintUnicodeSyntax          = False@@ -559,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@@ -728,6 +736,12 @@ {-# INLINE CONLIKE cparen #-} cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d +quoteIfPunsEnabled :: SDoc -> SDoc+quoteIfPunsEnabled doc =+  sdocOption sdocListTuplePuns $ \case+    True -> quote doc+    False -> doc+ -- 'quotes' encloses something in single quotes... -- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''.  Instead we just have foo'.@@ -842,6 +856,21 @@                      go d [] = [d]                      go d (e:es) = (d <> p) : go e es +-- | Punctuate a list, e.g. with commas and dots.+--+-- > sep $ punctuateFinal comma dot [text "ab", text "cd", text "ef"]+-- > ab, cd, ef.+punctuateFinal :: IsLine doc+               => doc   -- ^ The interstitial punctuation+               -> doc   -- ^ The final punctuation+               -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements+               -> [doc] -- ^ Punctuated list+punctuateFinal _ _ []     = []+punctuateFinal p q (d:ds) = go d ds+  where+    go d [] = [d <> q]+    go d (e:es) = (d <> p) : go e es+ ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc {-# INLINE CONLIKE ppWhen #-} ppWhen True  doc = doc@@ -858,9 +887,10 @@    False -> empty  {-# INLINE CONLIKE ppUnlessOption #-}-ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc-ppUnlessOption f doc = docWithContext $-                          \ctx -> if f ctx then empty else doc+ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc+ppUnlessOption f doc = sdocOption f $ \case+   True  -> empty+   False -> doc  -- | Apply the given colour\/style for the argument. --@@ -890,6 +920,9 @@ -- There's no Outputable for Char; it's too easy to use Outputable -- on String and have ppr "hello" rendered as "h,e,l,l,o". +instance Outputable Void where+    ppr _ = text "<<Void>>"+ instance Outputable Bool where     ppr True  = text "True"     ppr False = text "False"@@ -950,12 +983,18 @@ instance (Outputable a) => Outputable (NonEmpty a) where     ppr = ppr . NEL.toList +instance (Outputable a, Outputable b) => Outputable (Arg a b) where+    ppr (Arg a b) = text "Arg" <+> ppr a <+> ppr b+ instance (Outputable a) => Outputable (Set a) where     ppr s = braces (pprWithCommas ppr (Set.toList s))  instance Outputable Word64Set.Word64Set where     ppr s = braces (pprWithCommas ppr (Word64Set.toList s)) +instance Outputable IntSet.IntSet where+    ppr s = braces (pprWithCommas ppr (IntSet.toList s))+ instance (Outputable a, Outputable b) => Outputable (a, b) where     ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) @@ -1041,12 +1080,10 @@ instance Outputable ModuleName where   ppr = pprModuleName + pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) =-    docWithContext $ \ctx ->-    if codeStyle (sdocStyle ctx)-        then ztext (zEncodeFS nm)-        else ftext nm+    docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm) {-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} {-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] @@ -1168,6 +1205,9 @@ instance OutputableP env a => OutputableP env (Maybe a) where    pdoc env xs = ppr (fmap (pdoc env) xs) +instance OutputableP env () where+   pdoc _ _ = ppr ()+ instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where     pdoc env (a,b) = ppr (pdoc env a, pdoc env b) @@ -1198,16 +1238,6 @@ ************************************************************************ -} --- | 'BindingSite' is used to tell the thing that prints binder what--- language construct is binding the identifier.  This can be used--- to decide how much info to print.--- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"-data BindingSite-    = LambdaBind  -- ^ The x in   (\x. e)-    | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }-    | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }-    | LetBind     -- ^ The x in   (let x = rhs in e)-    deriving Eq -- | When we print a binder, we often want to print its type too. -- The @OutputableBndr@ class encapsulates this idea. class Outputable a => OutputableBndr a where@@ -1219,13 +1249,40 @@       -- prefix position of an application, thus   (f a b) or  ((+) x)       -- or infix position,                 thus   (a `f` b) or  (x + y) -   bndrIsJoin_maybe :: a -> Maybe Int-   bndrIsJoin_maybe _ = Nothing+   bndrIsJoin_maybe :: a -> JoinPointHood+   bndrIsJoin_maybe _ = NotJoinPoint       -- When pretty-printing we sometimes want to find       -- whether the binder is a join point.  You might think       -- we could have a function of type (a->Var), but Var       -- isn't available yet, alas +-- | 'BindingSite' is used to tell the thing that prints binder what+-- language construct is binding the identifier.  This can be used+-- to decide how much info to print.+-- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"+data BindingSite+    = LambdaBind  -- ^ The x in   (\x. e)+    | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }+    | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }+    | LetBind     -- ^ The x in   (let x = rhs in e)+    deriving Eq++data JoinPointHood+  = JoinPoint {-# UNPACK #-} !Int   -- The JoinArity (but an Int here because+  | NotJoinPoint                    -- synonym JoinArity is defined in Types.Basic)+  deriving( Eq )++isJoinPoint :: JoinPointHood -> Bool+isJoinPoint (JoinPoint {}) = True+isJoinPoint NotJoinPoint   = False++instance Outputable JoinPointHood where+  ppr NotJoinPoint      = text "NotJoinPoint"+  ppr (JoinPoint arity) = text "JoinPoint" <> parens (ppr arity)++instance NFData JoinPointHood where+  rnf x = x `seq` ()+ {- ************************************************************************ *                                                                      *@@ -1341,6 +1398,12 @@                              -- comma-separated and finally packed into a paragraph. pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) +pprWithSemis :: (a -> SDoc) -- ^ The pretty printing function to use+              -> [a]         -- ^ The things to be pretty printed+              -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,+                             -- semicolon-separated and finally packed into a paragraph.+pprWithSemis pp xs = fsep (punctuate semi (map pp xs))+ pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use             -> [a]         -- ^ The things to be pretty printed             -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,@@ -1374,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)) @@ -1387,6 +1459,20 @@ quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) quotedListWithNor xs = quotedList xs +quotedListWithAnd :: [SDoc] -> SDoc+-- [x,y,z]  ==>  `x', `y' and `z'+quotedListWithAnd xs@(_:_:_) = quotedList (init xs) <+> text "and" <+> quotes (last xs)+quotedListWithAnd xs = quotedList xs+++unquotedListWith :: SDoc -> [SDoc] -> SDoc+-- "whatever" [x,y,z] ==> x, y whatever z+unquotedListWith d xs+  | Just (fs@(_:_), l) <- snocView xs = unquotedList fs <+> d <+> l+  | otherwise                         = unquotedList xs+  where+    unquotedList = fsep . punctuate comma+ {- ************************************************************************ *                                                                      *@@ -1464,6 +1550,10 @@ 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: -- -- > singular [] = empty@@ -1500,7 +1590,16 @@ itsOrTheir [_] = text "its" itsOrTheir _   = text "their" +-- | 'it' or 'they', depeneding on the length of the list.+--+-- > itOrThey [x]   = text "it"+-- > itOrThey [x,y] = text "they"+-- > itOrThey []    = text "they"  -- probably avoid this+itOrThey :: [a] -> SDoc+itOrThey [_] = text "it"+itOrThey _   = text "they" + -- | Determines the form of subject appropriate for the length of a list: -- -- > thisOrThese [x]   = text "This"@@ -1636,6 +1735,7 @@     class IsOutput doc where       empty :: doc       docWithContext :: (SDocContext -> doc) -> doc+      docWithStyle :: doc -> (PprStyle -> SDoc) -> doc      class IsOutput doc => IsLine doc     class (IsOutput doc, IsLine (Line doc)) => IsDoc doc@@ -1672,14 +1772,23 @@ difficult to make completely equivalent under both printer implementations.  These operations should generally be avoided, as they can result in surprising-changes in behavior when the printer implementation is changed. However, in-certain cases, the alternative is even worse. For example, we use dualLine in-the implementation of pprUnitId, as the hack we use for printing unit ids-(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine-and is not necessary for code paths that use it, anyway.+changes in behavior when the printer implementation is changed.+Right now, they are used only when outputting debugging comments in+codegen, as it is difficult to adapt that code to use HLine and not necessary. -Use these operations wisely. -}+Use these operations wisely. +Note [docWithStyle]+~~~~~~~~~~~~~~~~~~~+Sometimes when printing, we consult the printing style. This can be done+with 'docWithStyle c f'. This is similar to 'docWithContext (f . sdocStyle)',+but:+* For code style, 'docWithStyle c f' will return 'c'.+* For other styles, 'docWithStyle c f', will call 'f style', but expect+  an SDoc rather than doc. This removes the need to write code polymorphic+  in SDoc and HDoc, since the latter is used only for code style.+-}+ -- | Represents a single line of output that can be efficiently printed directly -- to a 'System.IO.Handle' (actually a 'BufHandle'). -- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details.@@ -1703,7 +1812,7 @@ {-# COMPLETE HDoc #-}  bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO ()-bPutHDoc h ctx (HDoc f) = f ctx h+bPutHDoc h ctx (HDoc f) = assert (codeStyle (sdocStyle ctx)) (f ctx h)  -- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', -- as well as access to the shared 'SDocContext'.@@ -1712,6 +1821,7 @@ class IsOutput doc where   empty :: doc   docWithContext :: (SDocContext -> doc) -> doc+  docWithStyle :: doc -> (PprStyle -> SDoc) -> doc  -- see Note [docWithStyle]  -- | A class of types that represent a single logical line of text, with support -- for horizontal composition.@@ -1782,6 +1892,11 @@   {-# INLINE CONLIKE empty #-}   docWithContext = sdocWithContext   {-# INLINE docWithContext #-}+  docWithStyle c f = sdocWithContext (\ctx -> let sty = sdocStyle ctx+                                              in if codeStyle sty then c+                                                                  else f sty)+                     -- see Note [docWithStyle]+  {-# INLINE CONLIKE docWithStyle #-}  instance IsLine SDoc where   char c = docToSDoc $ Pretty.char c@@ -1826,12 +1941,16 @@   {-# INLINE empty #-}   docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h   {-# INLINE CONLIKE docWithContext #-}+  docWithStyle c _ = c  -- see Note [docWithStyle]+  {-# INLINE CONLIKE docWithStyle #-}  instance IsOutput HDoc where   empty = HDoc (\_ _ -> pure ())   {-# INLINE empty #-}   docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h   {-# INLINE CONLIKE docWithContext #-}+  docWithStyle c _ = c  -- see Note [docWithStyle]+  {-# INLINE CONLIKE docWithStyle #-}  instance IsLine HLine where   char c = HLine (\_ h -> bPutChar h c)
compiler/GHC/Utils/Panic.hs view
@@ -7,6 +7,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables, LambdaCase #-} +#include <ghcautoconf.h>+ -- | Defines basic functions for printing error messages. -- -- It's hard to put these functions anywhere else without causing@@ -21,17 +23,12 @@    , handleGhcException       -- * Command error throwing patterns-   , pgmError-   , panic    , pprPanic-   , sorry    , panicDoc    , sorryDoc    , pgmErrorDoc-   , cmdLineError-   , cmdLineErrorIO+      -- ** Assertions-   , assertPanic    , assertPprPanic    , assertPpr    , assertPprMaybe@@ -50,6 +47,7 @@    , tryMost    , throwTo    , withSignalHandlers+   , module GHC.Utils.Panic.Plain    ) where @@ -130,6 +128,10 @@           PlainProgramError str -> ProgramError str     | otherwise = Nothing +  -- Explicitly omit ExceptionContext since we generally don't+  -- want backtraces and other context in GHC's user errors.+  displayException exc = showGhcExceptionUnsafe exc ""+ instance Show GhcException where   showsPrec _ e = showGhcExceptionUnsafe e @@ -175,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@@ -186,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@@ -236,6 +238,11 @@ -- | Temporarily install standard signal handlers for catching ^C, which just -- throw an exception in the current thread. withSignalHandlers :: ExceptionMonad m => m a -> m a+#if !defined(HAVE_SIGNAL_H)+-- No signal functionality exist on the host platform (e.g. on+-- wasm32-wasi), so don't attempt to set up signal handlers+withSignalHandlers = id+#else withSignalHandlers act = do   main_thread <- liftIO myThreadId   wtid <- liftIO (mkWeakThreadId main_thread)@@ -295,6 +302,7 @@    mayInstallHandlers   act `MC.finally` mayUninstallHandlers+#endif  callStackDoc :: HasCallStack => SDoc callStackDoc = prettyCallStackDoc callStack
compiler/GHC/Utils/Panic/Plain.hs view
@@ -5,15 +5,10 @@ -- type.  It omits the exception constructors that involve -- pretty-printing via 'GHC.Utils.Outputable.SDoc'. ----- There are two reasons for this:------ 1. To avoid import cycles / use of boot files. "GHC.Utils.Outputable" has--- many transitive dependencies. To throw exceptions from these--- modules, the functions here can be used without introducing import--- cycles.------ 2. To reduce the number of modules that need to be compiled to--- object code when loading GHC into GHCi. See #13101+-- The reason for this is to avoid import cycles / use of boot files.+-- "GHC.Utils.Outputable" has many transitive dependencies.+-- To throw exceptions from these modules, the functions here can be used+-- without introducing import cycles. module GHC.Utils.Panic.Plain   ( PlainGhcException(..)   , showPlainGhcException@@ -29,6 +24,8 @@ import GHC.Utils.Exception as Exception import GHC.Stack import GHC.Prelude.Basic++import Control.Monad (when) import System.IO.Unsafe  -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits@@ -102,12 +99,7 @@  -- | Panics and asserts. panic, sorry, pgmError :: HasCallStack => String -> a-panic    x = unsafeDupablePerformIO $ do-   stack <- ccsToStrings =<< getCurrentCCS x-   let doc = unlines $ fmap ("  "++) $ lines (prettyCallStack callStack)-   if null stack-      then throwPlainGhcException (PlainPanic (x ++ '\n' : doc))-      else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))+panic    x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x)  sorry    x = throwPlainGhcException (PlainSorry x) pgmError x = throwPlainGhcException (PlainProgramError x)@@ -116,11 +108,7 @@ cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO  cmdLineErrorIO :: String -> IO a-cmdLineErrorIO x = do-  stack <- ccsToStrings =<< getCurrentCCS x-  if null stack-    then throwPlainGhcException (PlainCmdLineError x)-    else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))+cmdLineErrorIO x = throwPlainGhcException (PlainCmdLineError x)  -- | Throw a failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a@@ -128,14 +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' =-  let doc = unlines $ fmap ("  "++) $ lines (prettyCallStack callStack)-  in-  Exception.throw (Exception.AssertionFailed-           ("ASSERT failed!\n"-            ++ withFrozenCallStack doc))+    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 #-}@@ -150,4 +141,8 @@  assertM :: (HasCallStack, Monad m) => m Bool -> m () {-# INLINE assertM #-}-assertM mcond = withFrozenCallStack (mcond >>= massert)+assertM mcond+  | debugIsOn = withFrozenCallStack $ do+      res <- mcond+      when (not res) assertPanic'+  | otherwise = return ()
compiler/GHC/Utils/Ppr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}  -----------------------------------------------------------------------------
compiler/GHC/Utils/TmpFs.hs view
@@ -64,6 +64,8 @@       --       -- Shared with forked TmpFs. +  , tmp_dir_prefix :: String+   , tmp_files_to_clean :: IORef PathsToClean       -- ^ Files to clean (per session or per module)       --@@ -121,6 +123,7 @@         , tmp_subdirs_to_clean = subdirs         , tmp_dirs_to_clean    = dirs         , tmp_next_suffix      = next+        , tmp_dir_prefix       = "tmp"         }  -- | Initialise an empty TmpFs sharing unique numbers and per-process temporary@@ -132,11 +135,16 @@ forkTmpFsFrom old = do     files <- newIORef emptyPathsToClean     subdirs <- newIORef emptyPathsToClean+    counter <- newIORef 0+    prefix  <- newTempSuffix old++     return $ TmpFs         { tmp_files_to_clean   = files         , tmp_subdirs_to_clean = subdirs         , tmp_dirs_to_clean    = tmp_dirs_to_clean old-        , tmp_next_suffix      = tmp_next_suffix old+        , tmp_next_suffix      = counter+        , tmp_dir_prefix       = prefix         }  -- | Merge the first TmpFs into the second.@@ -259,10 +267,12 @@   addFilesToClean tmpfs lifetime existing_files  -- Return a unique numeric temp file suffix-newTempSuffix :: TmpFs -> IO Int-newTempSuffix tmpfs =-  atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n)+newTempSuffix :: TmpFs -> IO String+newTempSuffix tmpfs = do+  n <- atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n)+  return $ tmp_dir_prefix tmpfs ++ "_" ++ show n + -- Find a temporary name that doesn't already exist. newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath newTempName logger tmpfs tmp_dir lifetime extn@@ -271,8 +281,8 @@   where     findTempName :: FilePath -> IO FilePath     findTempName prefix-      = do n <- newTempSuffix tmpfs-           let filename = prefix ++ show n <.> extn+      = do suffix <- newTempSuffix tmpfs+           let filename = prefix ++ suffix <.> extn            b <- doesFileExist filename            if b then findTempName prefix                 else do -- clean it up later@@ -295,8 +305,8 @@   where     findTempDir :: FilePath -> IO FilePath     findTempDir prefix-      = do n <- newTempSuffix tmpfs-           let name = prefix ++ show n+      = do suffix <- newTempSuffix tmpfs+           let name = prefix ++ suffix            b <- doesDirectoryExist name            if b then findTempDir prefix                 else (do@@ -314,8 +324,8 @@   where     findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)     findTempName dir prefix-      = do n <- newTempSuffix tmpfs -- See Note [Deterministic base name]-           let libname = prefix ++ show n+      = do suffix <- newTempSuffix tmpfs -- See Note [Deterministic base name]+           let libname = prefix ++ suffix                filename = dir </> "lib" ++ libname <.> extn            b <- doesFileExist filename            if b then findTempName dir prefix@@ -340,8 +350,8 @@      mkTempDir :: FilePath -> IO FilePath     mkTempDir prefix = do-        n <- newTempSuffix tmpfs-        let our_dir = prefix ++ show n+        suffix <- newTempSuffix tmpfs+        let our_dir = prefix ++ suffix          -- 1. Speculatively create our new directory.         createDirectory our_dir@@ -376,19 +386,33 @@ the process id).  This is ok, as the temporary directory used contains the pid (see getTempDir).++In addition to this, multiple threads can race against each other creating temporary+files. Therefore we supply a prefix when creating temporary files, when a thread is+forked, each thread must be given an TmpFs with a unique prefix. This is achieved+by forkTmpFsFrom creating a fresh prefix from the parent TmpFs. -}++manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()+manyWithTrace _ _ _ [] = pure () -- do silent nothing on zero filepaths+manyWithTrace logger phase act paths+  = traceCmd logger phase ("Deleting: " ++ unwords paths) (act paths)+ removeTmpDirs :: Logger -> [FilePath] -> IO ()-removeTmpDirs logger ds-  = traceCmd logger "Deleting temp dirs"-             ("Deleting: " ++ unwords ds)-             (mapM_ (removeWith logger removeDirectory) ds)+removeTmpDirs logger+  = manyWithTrace logger "Deleting temp dirs"+                  (mapM_ (removeWith logger removeDirectory)) +removeTmpSubdirs :: Logger -> [FilePath] -> IO ()+removeTmpSubdirs logger+  = manyWithTrace logger "Deleting temp subdirs"+                  (mapM_ (removeWith logger removeDirectory))+ removeTmpFiles :: Logger -> [FilePath] -> IO () removeTmpFiles logger fs   = warnNon $-    traceCmd logger "Deleting temp files"-             ("Deleting: " ++ unwords deletees)-             (mapM_ (removeWith logger removeFile) deletees)+    manyWithTrace logger "Deleting temp files"+                  (mapM_ (removeWith logger removeFile)) deletees   where      -- Flat out refuse to delete files that are likely to be source input      -- files (is there a worse bug than having a compiler delete your source@@ -404,12 +428,6 @@         act      (non_deletees, deletees) = partition isHaskellUserSrcFilename fs--removeTmpSubdirs :: Logger -> [FilePath] -> IO ()-removeTmpSubdirs logger fs-  = traceCmd logger "Deleting temp subdirs"-             ("Deleting: " ++ unwords fs)-             (mapM_ (removeWith logger removeDirectory) fs)  removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () removeWith logger remover f = remover f `Exception.catchIO`
compiler/GHC/Utils/Trace.hs view
@@ -8,6 +8,7 @@   , pprSTrace   , pprTraceException   , warnPprTrace+  , warnPprTraceM   , pprTraceUserWarning   , trace   )@@ -83,6 +84,9 @@   = pprDebugAndThen traceSDocContext trace (text "WARNING:")                     (text s $$ msg $$ withFrozenCallStack traceCallStackDoc )                     x++warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f ()+warnPprTraceM b s doc = withFrozenCallStack warnPprTrace b s doc (pure ())  -- | For when we want to show the user a non-fatal WARNING so that they can -- report a GHC bug, but don't want to panic.
− compiler/GHC/Utils/Unique.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE CPP #-}--{- Work around #23537--On 32 bit systems, GHC's codegen around 64 bit numbers is not quite-complete. This led to panics mentioning missing cases in iselExpr64.-Now that GHC uses Word64 for its uniques, these panics have started-popping up whenever a unique is compared to many other uniques in one-function. As a workaround we use these two functions which are not-inlined on 32 bit systems, thus preventing the panics.--}--module GHC.Utils.Unique (sameUnique, anyOfUnique) where--#include "MachDeps.h"--import GHC.Prelude.Basic (Bool, Eq((==)), Foldable(elem))-import GHC.Types.Unique (Unique, Uniquable (getUnique))---#if WORD_SIZE_IN_BITS == 32-{-# NOINLINE sameUnique #-}-#else-{-# INLINE sameUnique #-}-#endif-sameUnique :: Uniquable a => a -> a -> Bool-sameUnique x y = getUnique x == getUnique y--#if WORD_SIZE_IN_BITS == 32-{-# NOINLINE anyOfUnique #-}-#else-{-# INLINE anyOfUnique #-}-#endif-anyOfUnique :: Uniquable a => a -> [Unique] -> Bool-anyOfUnique tc xs = getUnique tc `elem` xs
compiler/GHC/Utils/Word64.hs view
@@ -6,14 +6,14 @@  import GHC.Prelude import GHC.Utils.Panic.Plain (assert)+import GHC.Utils.Misc (HasDebugCallStack)  import Data.Word-import GHC.Stack -intToWord64 :: HasCallStack => Int -> Word64+intToWord64 :: HasDebugCallStack => Int -> Word64 intToWord64 x = assert (0 <= x) (fromIntegral x) -word64ToInt :: HasCallStack => Word64 -> Int+word64ToInt :: HasDebugCallStack => Word64 -> Int word64ToInt x = assert (x <= fromIntegral (maxBound :: Int)) (fromIntegral x)  truncateWord64ToWord32 :: Word64 -> Word32
compiler/Language/Haskell/Syntax.hs view
@@ -25,7 +25,6 @@         module Language.Haskell.Syntax.Module.Name,         module Language.Haskell.Syntax.Pat,         module Language.Haskell.Syntax.Type,-        module Language.Haskell.Syntax.Concrete,         module Language.Haskell.Syntax.Extension,         ModuleName(..), HsModule(..) ) where@@ -36,7 +35,6 @@ import Language.Haskell.Syntax.ImpExp import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type@@ -68,16 +66,7 @@ -- -- All we actually declare here is the top-level structure for a module. data HsModule p-  =  -- | 'GHC.Parser.Annotation.AnnKeywordId's-     ---     --  - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere'-     ---     --  - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi',-     --    'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around-     --    hsmodImports,hsmodDecls if this style is used.--     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-    HsModule {+    = HsModule {       hsmodExt :: XCModule p,         -- ^ HsModule extension point       hsmodName :: Maybe (XRec p ModuleName),@@ -91,15 +80,8 @@         --  - @Just []@: export /nothing/         --         --  - @Just [...]@: as you would expect...-        ---        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'-        --                                   ,'GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation       hsmodImports :: [LImportDecl p],       hsmodDecls :: [LHsDecl p]         -- ^ Type, class, value, and interface signature decls    }   | XModule !(XXModule p)-
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@@ -96,3 +96,33 @@                      | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified                      | NoSrcUnpack -- ^ no unpack pragma      deriving (Eq, Data)++{-+************************************************************************+*                                                                      *+Fixity+*                                                                      *+************************************************************************+-}++-- | Captures the fixity of declarations as they are parsed. This is not+-- necessarily the same as the fixity declaration, as the normal fixity may be+-- overridden using parens or backticks.+data LexicalFixity = Prefix | Infix deriving (Eq, Data)++data FixityDirection+   = InfixL+   | InfixR+   | 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
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -25,20 +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.Data.Bag (Bag) import GHC.Types.Basic (InlinePragma)--import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.SourceText (StringLiteral) -import Data.Void import Data.Bool import Data.Maybe @@ -127,7 +123,7 @@ type HsBind   id = HsBindLR   id id  -- | Located Haskell Bindings with separate Left and Right identifier types-type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)+type LHsBindsLR idL idR = [LHsBindLR idL idR]  -- | Located Haskell Binding with separate Left and Right identifier types type LHsBindLR  idL idR = XRec idL (HsBindLR idL idR)@@ -162,6 +158,25 @@     Just x = e     (x) = e     x :: Ty = e++Note [Multiplicity annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Multiplicity annotations are stored in the pat_mult field on PatBinds,+represented by the HsMultAnn data type++  HsNoMultAnn <=> no annotation in the source file+  HsPct1Ann   <=> the %1 annotation+  HsMultAnn   <=> the %t annotation, where `t` is some type++In case of HsNoMultAnn the typechecker infers a multiplicity.++We don't need to store a multiplicity on FunBinds:+- let %1 x = … is parsed as a PatBind. So we don't need an annotation before+  typechecking.+- the multiplicity that the typechecker infers is stored in the binder's Var for+  the desugarer to use. It's only relevant for strict FunBinds, see Wrinkle 1 in+  Note [Desugar Strict binds] in GHC.HsToCore.Binds as, in Core, let expressions+  don't have multiplicity annotations. -}  -- | Haskell Binding with separate Left and Right id's@@ -184,15 +199,6 @@     -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their     -- 'MatchContext'. See Note [FunBind vs PatBind] for     -- details about the relationship between FunBind and PatBind.-    ---    --  'GHC.Parser.Annotation.AnnKeywordId's-    ---    --  - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches-    ---    --  - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',-    --    'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     FunBind {          fun_ext :: XFunBind idL idR,@@ -209,16 +215,11 @@   -- That case is done by FunBind.   -- See Note [FunBind vs PatBind] for details about the   -- relationship between FunBind and PatBind.--  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang',-  --       'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',-  --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | PatBind {         pat_ext    :: XPatBind idL idR,         pat_lhs    :: LPat idL,+        pat_mult   :: HsMultAnn idL,+        -- ^ See Note [Multiplicity annotations].         pat_rhs    :: GRHSs idR (LHsExpr idR)     } @@ -236,23 +237,10 @@   | PatSynBind         (XPatSynBind idL idR)         (PatSynBind idL idR)-        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',-        --          'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual',-        --          'GHC.Parser.Annotation.AnnWhere'-        --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@ -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | XHsBindsLR !(XXHsBindsLR idL idR)  --- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',---             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow',---             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@,---             'GHC.Parser.Annotation.AnnClose' @'}'@,---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | Pattern Synonym binding data PatSynBind idL idR   = PSB { psb_ext  :: XPSB idL idR,@@ -263,7 +251,6 @@      }    | XPatSynBind !(XXPatSynBind idL idR) - {- ************************************************************************ *                                                                      *@@ -284,16 +271,8 @@  -- | Located Implicit Parameter Binding type LIPBind id = XRec id (IPBind id)--- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a---   list --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | Implicit parameter bindings.------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data IPBind id   = IPBind         (XCIPBind id)@@ -330,11 +309,6 @@       -- fresh meta vars in the type. Their names are stored in the type       -- signature that brought them into scope, in this third field to be       -- more specific.-      ---      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon',-      --          'GHC.Parser.Annotation.AnnComma'--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     TypeSig        (XTypeSig pass)        [LIdP pass]           -- LHS of the signature; e.g.  f,g,h :: blah@@ -343,12 +317,6 @@       -- | A pattern synonym type signature       --       -- > pattern Single :: () => (Show a) => a -> [a]-      ---      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',-      --           'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall'-      --           'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass)       -- P :: forall a b. Req => Prov => ty @@ -359,49 +327,25 @@       --          op :: a -> a                   -- Ordinary       --          default op :: Eq a => a -> a   -- Generic default       -- No wildcards allowed here-      ---      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',-      --           'GHC.Parser.Annotation.AnnDcolon'   | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass)          -- | An ordinary fixity declaration         --         -- >     infixl 8 ***-        ---        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix',-        --           'GHC.Parser.Annotation.AnnVal'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | FixSig (XFixSig pass) (FixitySig pass)          -- | An inline pragma         --         -- > {#- INLINE f #-}-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' :-        --       'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@,-        --       'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen',-        --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde',-        --       'GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | InlineSig   (XInlineSig pass)                 (LIdP pass)        -- Function name                 InlinePragma       -- Never defaultInlinePragma -        -- | A specialisation pragma+        -- | An old-form specialisation pragma         --         -- > {-# SPECIALISE f :: Int -> Int #-}         ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --      'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,-        --      'GHC.Parser.Annotation.AnnTilde',-        --      'GHC.Parser.Annotation.AnnVal',-        --      'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@,-        --      'GHC.Parser.Annotation.AnnDcolon'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+        -- 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@@ -409,29 +353,29 @@                                    -- 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] #-}         --         -- (Class tys); should be a specialisation of the         -- current instance declaration-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --      'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SpecInstSig (XSpecInstSig pass) (LHsSigType pass)          -- | A minimal complete definition pragma         --         -- > {-# MINIMAL a | (b, c | (d | e)) #-}-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --      'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma',-        --      'GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass))+  | MinimalSig (XMinimalSig pass) (LBooleanFormula pass)          -- | A "set cost centre" pragma for declarations         --@@ -452,7 +396,7 @@        -- complete matchings which, for example, arise from pattern        -- synonym definitions.   | CompleteMatchSig (XCompleteMatchSig pass)-                     (XRec pass [LIdP pass])+                     [LIdP pass]                      (Maybe (LIdP pass))   | XSig !(XXSig pass) @@ -474,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@@ -484,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@@ -506,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]+ {- ************************************************************************ *                                                                      *@@ -515,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/Concrete.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Bits of concrete syntax (tokens, layout).--module Language.Haskell.Syntax.Concrete-  ( LHsToken, LHsUniToken,-    HsToken(HsTok),-    HsUniToken(HsNormalTok, HsUnicodeTok),-    LayoutInfo(ExplicitBraces, VirtualBraces, NoLayoutInfo)-  ) where--import GHC.Prelude-import GHC.TypeLits (Symbol, KnownSymbol)-import Data.Data-import Language.Haskell.Syntax.Extension--type LHsToken tok p = XRec p (HsToken tok)-type LHsUniToken tok utok p = XRec p (HsUniToken tok utok)---- | A token stored in the syntax tree. For example, when parsing a--- let-expression, we store @HsToken "let"@ and @HsToken "in"@.--- The locations of those tokens can be used to faithfully reproduce--- (exactprint) the original program text.-data HsToken (tok :: Symbol) = HsTok---- | With @UnicodeSyntax@, there might be multiple ways to write the same--- token. For example an arrow could be either @->@ or @→@. This choice must be--- recorded in order to exactprint such tokens, so instead of @HsToken "->"@ we--- introduce @HsUniToken "->" "→"@.------ See also @IsUnicodeSyntax@ in @GHC.Parser.Annotation@; we do not use here to--- avoid a dependency.-data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok--deriving instance KnownSymbol tok => Data (HsToken tok)-deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)---- | Layout information for declarations.-data LayoutInfo pass =--    -- | Explicit braces written by the user.-    ---    -- @-    -- class C a where { foo :: a; bar :: a }-    -- @-    ExplicitBraces !(LHsToken "{" pass) !(LHsToken "}" pass)-  |-    -- | Virtual braces inserted by the layout algorithm.-    ---    -- @-    -- class C a where-    --   foo :: a-    --   bar :: a-    -- @-    VirtualBraces-      !Int -- ^ Layout column (indentation level, begins at 1)-  |-    -- | Empty or compiler-generated blocks do not have layout information-    -- associated with them.-    NoLayoutInfo
compiler/Language/Haskell/Syntax/Decls.hs view
@@ -30,26 +30,23 @@   HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..),   HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,   NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData,-  isTypeDataDefnCons,+  isTypeDataDefnCons, firstDataDefnCon,   StandaloneKindSig(..), LStandaloneKindSig,    -- ** Class or type declarations   TyClDecl(..), LTyClDecl,   TyClGroup(..),-  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,-  tyClGroupKindSigs,   isClassDecl, isDataDecl, isSynDecl,   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,-  tyClDeclTyVars,   FamilyDecl(..), LFamilyDecl,    -- ** Instance declarations-  InstDecl(..), LInstDecl, FamilyInfo(..),+  InstDecl(..), LInstDecl, FamilyInfo(..), familyInfoTyConFlavour,   TyFamInstDecl(..), LTyFamInstDecl,   TyFamDefltDecl, LTyFamDefltDecl,   DataFamInstDecl(..), LDataFamInstDecl,-  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,   LClsInstDecl, ClsInstDecl(..),    -- ** Standalone deriving declarations@@ -70,7 +67,8 @@   CImportSpec(..),   -- ** Data-constructor declarations   ConDecl(..), LConDecl,-  HsConDeclH98Details, HsConDeclGADTDetails(..),+  HsConDeclH98Details,+  HsConDeclGADTDetails(..), XPrefixConGADT, XRecConGADT, XXConDeclGADTDetails,   -- ** Document comments   DocDecl(..), LDocDecl, docDeclDoc,   -- ** Deprecations@@ -85,7 +83,7 @@   FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,    -- * Grouping-  HsGroup(..), hsGroupInstDecls,+  HsGroup(..)     ) where  -- friends:@@ -94,31 +92,28 @@         -- Because Expr imports Decls via HsBracket  import Language.Haskell.Syntax.Binds-import Language.Haskell.Syntax.Concrete 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)+import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation+                       ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec)-import GHC.Types.Fixity (LexicalFixity) -import GHC.Core.Type (Specificity) import GHC.Unit.Module.Warnings (WarningTxt)  import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST  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 (..))@@ -133,12 +128,7 @@  type LHsDecl p = XRec p (HsDecl p)         -- ^ When in a list this may have-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'-        -- --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | A Haskell Declaration data HsDecl p   = TyClD      (XTyClD p)      (TyClDecl p)      -- ^ Type or Class Declaration@@ -238,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) @@ -405,24 +392,9 @@ -- | A type or class declaration. data TyClDecl pass   = -- | @type/data family T :: *->*@-    ---    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-    --             'GHC.Parser.Annotation.AnnData',-    --             'GHC.Parser.Annotation.AnnFamily','GHC.Parser.Annotation.AnnDcolon',-    --             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpenP',-    --             'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnCloseP',-    --             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnRarrow',-    --             'GHC.Parser.Annotation.AnnVbar'--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }    | -- | @type@ declaration-    ---    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-    --             'GHC.Parser.Annotation.AnnEqual',--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renamer, FVs             , tcdLName  :: LIdP pass              -- ^ Type constructor             , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an@@ -432,14 +404,6 @@             , tcdRhs    :: LHsType pass }         -- ^ RHS of type declaration    | -- | @data@ declaration-    ---    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',-    --              'GHC.Parser.Annotation.AnnFamily',-    --              'GHC.Parser.Annotation.AnnNewType',-    --              'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnDcolon'-    --              'GHC.Parser.Annotation.AnnWhere',--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     DataDecl { tcdDExt     :: XDataDecl pass       -- ^ Post renamer, CUSK flag, FVs              , tcdLName    :: LIdP pass             -- ^ Type constructor              , tcdTyVars   :: LHsQTyVars pass      -- ^ Type variables@@ -447,16 +411,7 @@              , tcdFixity   :: LexicalFixity        -- ^ Fixity used in the declaration              , tcdDataDefn :: HsDataDefn pass } -    -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass',-    --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',-    --           'GHC.Parser.Annotation.AnnClose'-    --   - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar',-    --                          'GHC.Parser.Annotation.AnnComma'-    --                          'GHC.Parser.Annotation.AnnRarrow'-    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs-                tcdLayout  :: !(LayoutInfo pass),      -- ^ Explicit or virtual braces-                              -- See Note [Class LayoutInfo]                 tcdCtxt    :: Maybe (LHsContext pass), -- ^ Context...                 tcdLName   :: LIdP pass,               -- ^ Name of the class                 tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables@@ -499,9 +454,9 @@      Note [Family instance declaration binders] -} -{- Note [Class LayoutInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The LayoutInfo is used to associate Haddock comments with parts of the declaration.+{- Note [Class EpLayout]+~~~~~~~~~~~~~~~~~~~~~~~~+The EpLayout is used to associate Haddock comments with parts of the declaration. Compare the following examples:      class C a where@@ -567,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@@ -580,7 +530,8 @@ See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy and #9200 for lots of discussion of how we got here. -The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default.+The detection of CUSKs is enabled by the -XCUSKs extension, switched off by default+in GHC2021 and on in Haskell98/2010. Under -XNoCUSKs, all declarations are treated as if they have no CUSK. See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst @@ -670,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@@ -701,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@@ -789,24 +728,10 @@ -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig]     NoSig (XNoSig pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | KindSig  (XCKindSig pass) (LHsKind pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-  --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',-  --             'GHC.Parser.Annotation.AnnCloseP'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-  --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',-  --             'GHC.Parser.Annotation.AnnCloseP', 'GHC.Parser.Annotation.AnnEqual'   | XFamilyResultSig !(XXFamilyResultSig pass) -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- | Located type Family Declaration@@ -825,16 +750,7 @@   , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann   }   | XFamilyDecl !(XXFamilyDecl pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-  --             'GHC.Parser.Annotation.AnnData', 'GHC.Parser.Annotation.AnnFamily',-  --             'GHC.Parser.Annotation.AnnWhere', 'GHC.Parser.Annotation.AnnOpenP',-  --             'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnCloseP',-  --             'GHC.Parser.Annotation.AnnEqual', 'GHC.Parser.Annotation.AnnRarrow',-  --             'GHC.Parser.Annotation.AnnVbar' -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-- -- | Located Injectivity Annotation type LInjectivityAnn pass = XRec pass (InjectivityAnn pass) @@ -849,10 +765,6 @@ data InjectivityAnn pass   = InjectivityAnn (XCInjectivityAnn pass)                    (LIdP pass) [LIdP pass]-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-  --             'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XInjectivityAnn !(XXInjectivityAnn pass)  data FamilyInfo pass@@ -862,7 +774,29 @@      -- said "type family Foo x where .."   | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) +familyInfoTyConFlavour+  :: Maybe tc    -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyInfo pass+  -> TyConFlavour tc+familyInfoTyConFlavour mb_parent_tycon info =+  case info of+    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]+                          ClosedTypeFamilyFlavour +{- Note [Closed type family mb_parent_tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's no way to write a closed type family inside a class declaration:++  class C a where+    type family F a where  -- error: parse error on input ‘where’++In fact, it is not clear what the meaning of such a declaration would be.+Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.+-}+ {- ********************************************************************* *                                                                      *                Data types and data constructors@@ -916,11 +850,6 @@ type LHsDerivingClause pass = XRec pass (HsDerivingClause pass)  -- | A single @deriving@ clause of a data declaration.------  - 'GHC.Parser.Annotation.AnnKeywordId' :---       'GHC.Parser.Annotation.AnnDeriving', 'GHC.Parser.Annotation.AnnStock',---       'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype',---       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' data HsDerivingClause pass   -- See Note [Deriving strategies] in GHC.Tc.Deriv   = HsDerivingClause@@ -986,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@@@ -1006,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.@@ -1015,13 +938,14 @@ isTypeDataDefnCons (NewTypeCon _) = False isTypeDataDefnCons (DataTypeCons is_type_data _) = is_type_data +-- | Retrieve the first data constructor in a 'DataDefnCons' (if one exists).+firstDataDefnCon :: DataDefnCons a -> Maybe a+firstDataDefnCon (NewTypeCon con) = Just con+firstDataDefnCon (DataTypeCons _ cons) = listToMaybe cons+ -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass)-      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when-      --   in a GADT constructor list -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | -- -- @@@ -1037,27 +961,21 @@ -- data T a where --      Int `MkT` Int :: T Int -- @------ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',---            'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnCLose',---            'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnVbar',---            'GHC.Parser.Annotation.AnnDarrow','GHC.Parser.Annotation.AnnDarrow',---            'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot' --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | data Constructor Declaration data ConDecl pass   = ConDeclGADT       { con_g_ext   :: XConDeclGADT pass       , con_names   :: NonEmpty (LIdP pass)-      , con_dcolon  :: !(LHsUniToken "::" "∷" 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@@ -1201,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. @@ -1212,9 +1130,14 @@ -- derived Show instances—see Note [Infix GADT constructors] in -- GHC.Tc.TyCl—but that is an orthogonal concern.) data HsConDeclGADTDetails pass-   = PrefixConGADT [HsScaled pass (LBangType pass)]-   | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass)+   = PrefixConGADT !(XPrefixConGADT pass) [HsConDeclField pass]+   | RecConGADT !(XRecConGADT pass) (XRec pass [LHsConDeclRecField pass])+   | XConDeclGADTDetails !(XXConDeclGADTDetails pass) +type family XPrefixConGADT       p+type family XRecConGADT          p+type family XXConDeclGADTDetails p+ {- ************************************************************************ *                                                                      *@@ -1248,13 +1171,13 @@  -- | Located Type Family Instance Equation type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass)-  -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'-  --   when in a list --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation---- | Haskell Type Patterns-type HsTyPats pass = [LHsTypeArg pass]+-- | HsFamEqnPats represents patterns on the left-hand side of a type instance,+-- e.g. `type instance F @k (a :: k) = a` has patterns `@k` and `(a :: k)`.+--+-- HsFamEqnPats used to be called HsTyPats but it was renamed to avoid confusion+-- with a different notion of type patterns, see #23657.+type HsFamEqnPats pass = [LHsTypeArg pass]  {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1307,11 +1230,6 @@ data TyFamInstDecl pass   = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl pass                   , tfid_eqn :: TyFamInstEqn pass }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-    --           'GHC.Parser.Annotation.AnnInstance',--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XTyFamInstDecl !(XXTyFamInstDecl pass)  ----------------- Data family instances -------------@@ -1322,15 +1240,7 @@ -- | Data Family Instance Declaration newtype DataFamInstDecl pass   = DataFamInstDecl { dfid_eqn :: FamEqn pass (HsDataDefn pass) }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',-    --           'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnInstance',-    --           'GHC.Parser.Annotation.AnnDcolon'-    --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',-    --           'GHC.Parser.Annotation.AnnClose' -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- ----------------- Family instances (common types) -------------  -- | Family Equation@@ -1344,26 +1254,18 @@        { feqn_ext    :: XCFamEqn pass rhs        , feqn_tycon  :: LIdP pass        , feqn_bndrs  :: HsOuterFamEqnTyVarBndrs pass -- ^ Optional quantified type vars-       , feqn_pats   :: HsTyPats pass+       , feqn_pats   :: HsFamEqnPats pass        , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration        , feqn_rhs    :: rhs        }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'   | XFamEqn !(XXFamEqn pass rhs) -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- ----------------- Class instances -------------  -- | Located Class Instance Declaration type LClsInstDecl pass = XRec pass (ClsInstDecl pass)  -- | Class Instance Declaration---  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance',---           'GHC.Parser.Annotation.AnnWhere',---           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data ClsInstDecl pass   = ClsInstDecl       { cid_ext     :: XCClsInstDecl pass@@ -1375,10 +1277,6 @@       , cid_tyfam_insts   :: [LTyFamInstDecl pass]   -- Type family instances       , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances       , cid_overlap_mode  :: Maybe (XRec pass OverlapMode)-         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-         --                                    'GHC.Parser.Annotation.AnnClose',--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation       }   | XClsInstDecl !(XXClsInstDecl pass) @@ -1428,12 +1326,6 @@          , deriv_strategy     :: Maybe (LDerivStrategy pass)         , deriv_overlap_mode :: Maybe (XRec pass OverlapMode)-         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDeriving',-         --        'GHC.Parser.Annotation.AnnInstance', 'GHC.Parser.Annotation.AnnStock',-         --        'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype',-         --        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         }   | XDerivDecl !(XXDerivDecl pass) @@ -1469,22 +1361,18 @@ \subsection[DefaultDecl]{A @default@ declaration} *                                                                      * ************************************************************************--There can only be one default declaration per module, but it is hard-for the parser to check that; we pass them all through in the abstract-syntax, and that restriction must be checked in the front end. -}  -- | Located Default Declaration type LDefaultDecl pass = XRec pass (DefaultDecl pass) +-- See Note [Named default declarations] in GHC.Tc.Gen.Default -- | Default Declaration data DefaultDecl pass-  = DefaultDecl (XCDefaultDecl pass) [LHsType pass]-        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnDefault',-        --          'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  = DefaultDecl+      { defd_ext      :: XCDefaultDecl pass+      , defd_class    :: Maybe (LIdP pass)  -- Nothing in absence of NamedDefaults+      , defd_defaults :: [LHsType pass] }   | XDefaultDecl !(XXDefaultDecl pass)  {-@@ -1517,12 +1405,6 @@       , fd_name   :: LIdP pass             -- uses this name       , fd_sig_ty :: LHsSigType pass       -- sig_ty       , fd_fe     :: ForeignExport pass }-        -- ^-        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign',-        --           'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport',-        --           'GHC.Parser.Annotation.AnnDcolon'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XForeignDecl !(XXForeignDecl pass)  {-@@ -1552,7 +1434,7 @@                           --  * `Safety' is irrelevant for `CLabel' and `CWrapper'                           --                           CImport  (XCImport pass)-                                   (XRec pass CCallConv) -- ccall or stdcall+                                   (XRec pass CCallConv) -- ccall                                    (XRec pass Safety)  -- interruptible, safe or unsafe                                    (Maybe Header)       -- name of C header                                    CImportSpec          -- details of the C entity@@ -1598,42 +1480,14 @@        { rd_ext  :: XHsRule pass            -- ^ After renamer, free-vars from the LHS and RHS        , rd_name :: XRec pass RuleName-           -- ^ Note [Pragma source text] in "GHC.Types.Basic"-       , 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)+           -- ^ Note [Pragma source text] in "GHC.Types.SourceText"+       , rd_act   :: Activation+       , rd_bndrs :: RuleBndrs pass+       , rd_lhs   :: XRec pass (HsExpr pass)+       , rd_rhs   :: XRec pass (HsExpr pass)        }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' :-    --           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnTilde',-    --           'GHC.Parser.Annotation.AnnVal',-    --           'GHC.Parser.Annotation.AnnClose',-    --           'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot',-    --           'GHC.Parser.Annotation.AnnEqual',   | 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)-        -- ^-        --  - '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]- {- ************************************************************************ *                                                                      *@@ -1702,12 +1556,6 @@ data AnnDecl pass = HsAnnotation                       (XHsAnnotation pass)                       (AnnProvenance pass) (XRec pass (HsExpr pass))-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-      --           'GHC.Parser.Annotation.AnnType'-      --           'GHC.Parser.Annotation.AnnModule'-      --           'GHC.Parser.Annotation.AnnClose'--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XAnnDecl !(XXAnnDecl pass)  -- | Annotation Provenance@@ -1742,8 +1590,4 @@   = RoleAnnotDecl (XCRoleAnnotDecl pass)                   (LIdP pass)              -- type constructor                   [XRec pass (Maybe Role)] -- optional annotations-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-      --           'GHC.Parser.Annotation.AnnRole'--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XRoleAnnotDecl !(XXRoleAnnotDecl pass)
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]@@ -24,26 +25,22 @@ import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name (ModuleName) import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds  -- others:-import GHC.Types.Fixity (LexicalFixity(Infix), Fixity)-import GHC.Types.SourceText (StringLiteral, SourceText)+import GHC.Types.SourceText (StringLiteral) -import GHC.Unit.Module (ModuleName) import GHC.Data.FastString (FastString)  -- libraries: import Data.Data hiding (Fixity(..)) import Data.Bool-import Data.Either import Data.Eq import Data.Maybe import Data.List.NonEmpty ( NonEmpty )-import GHC.Types.Name.Reader  {- Note [RecordDotSyntax field updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -132,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].@@ -147,6 +144,19 @@ type RecUpdProj p = RecProj p (LHsExpr p) type LHsRecUpdProj p = XRec p (RecUpdProj p) +-- | Haskell Record Update Fields.+data LHsRecUpdFields p where+  -- | A regular (non-overloaded) record update.+  RegularRecUpdFields+    :: { xRecUpdFields :: XLHsRecUpdLabels p+       , recUpdFields  :: [LHsRecUpdField p p] }+    -> LHsRecUpdFields p+  -- | An overloaded record update.+  OverloadedRecUpdFields+    :: { xOLRecUpdFields :: XLHsOLRecUpdLabels p+       , olRecUpdFields  :: [LHsRecUpdProj p] }+    -> LHsRecUpdFields p+ {- ************************************************************************ *                                                                      *@@ -159,11 +169,7 @@  -- | Located Haskell Expression type LHsExpr p = XRec p (HsExpr p)-  -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when-  --   in a list -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- ------------------------- {- Note [NoSyntaxExpr] ~~~~~~~~~~~~~~~~~~~~~~@@ -227,7 +233,7 @@  NB 2: The notation getField @"size" e is short for HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e.-We track the original parsed syntax via HsExpanded.+We track the original parsed syntax via ExpandedThingRn.  -} @@ -248,32 +254,88 @@ transforms the record-selector Name to an Id. -} --- | A Haskell expression.-data HsExpr p-  = HsVar     (XVar p)-              (LIdP p) -- ^ Variable-                       -- See Note [Located RdrNames]+{- Note [Types in terms]+~~~~~~~~~~~~~~~~~~~~~~~~+Types-in-terms is a notion introduced by GHC Proposal #281. It refers+to the extension of term syntax (HsExpr in the AST, infixexp2 in Parser.y)+with constructs that previously could only occur at the type level: -  | 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.+  * Function arrows: a -> b+  * Multiplicity-polymorphic function arrows: a %m -> b (LinearTypes)+  * Constraint arrows: a => b+  * Universal quantification: forall a. b+  * Visible universal quantification: forall a -> b +This syntax can't be used to construct a type at the term level because `Type`+is not inhabited by any terms. Its use is limited to required type arguments: -  | HsRecSel  (XRecSel p)-              (FieldOcc p) -- ^ Variable pointing to record selector-                           -- See Note [Non-overloaded record field selectors] and-                           -- Note [Record selectors in the AST]+  -- Error:+  t :: Type+  t = (Int -> String)+    -- Not supported by GHC, `tcExpr` emits `TcRnIllegalTypeExpr` -  | HsOverLabel (XOverLabel p) SourceText FastString+  -- OK:+  s :: String+  s = vfun (Int -> String)+        -- Valid use in a required type argument,+        -- see `expr_to_type` (GHC.Tc.Gen.App)+    where+      vfun :: forall t -> Typeable t => String+      vfun t = show (typeRep @t)++In GHC, types-in-terms are implemented by the following additions to the AST of+expressions and their grammar:++  -- Language/Haskell/Syntax/Expr.hs+  data HsExpr p =+    ...+    | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p)+    | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p)+    | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)++  -- GHC/Parser.y+  infixexp2 :: { ECP }+    : infixexp %shift                  { ... }+    | infixexp         '->'  infixexp2 { ... }+    | infixexp expmult '->'  infixexp2 { ... }+    | infixexp         '->.' infixexp2 { ... }+    | expcontext       '=>'  infixexp2 { ... }+    | forall_telescope infixexp2       { ... }++These constructors and non-terminals mirror those found in HsType++     HsType      |  HsExpr+    -------------+-----------+     HsForAllTy  |  HsForAll+     HsFunTy     |  HsFunArr+     HsQualTy    |  HsQual++The resulting code duplication can be removed if we unify HsExpr and HsType+into one type (#25121).++Per the proposal, the constituents of types-in-terms are parsed and renamed+as terms, and forall-bound variables inhabit the term namespace. Example:++  h = \a -> g (forall a. Maybe a) a++To ensure that the `a` in `Maybe a` refers to the innermost binding (i.e. to the+forall-bound `a` and not to the lambda-bound `a`), we must consistently use the+term namespace `varName` throughout the expression. We set the correct namespace+using `setTelescopeBndrsNameSpace` in GHC.Parser.PostProcess and GHC.ThToHs.++`exprCtOrigin` returns `Shouldn'tHappenOrigin` for types-in-terms because+they either undergo the T2T translation `expr_to_type` in `tcVDQ` or result+in `TcRnIllegalTypeExpr`.+-}++-- | A Haskell expression.+data HsExpr p+  = HsVar     (XVar p)+              (LIdOccP p) -- ^ Variable+                          -- See Note [Located RdrNames]++  | HsOverLabel (XOverLabel p) FastString      -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)-     -- Note [Pragma source text] in GHC.Types.SourceText    | HsIPVar   (XIPVar p)               HsIPName   -- ^ Implicit parameter (not in use after typechecking)@@ -283,44 +345,28 @@   | HsLit     (XLitE p)               (HsLit p)      -- ^ Simple (non-overloaded) literals +  -- | Lambda, Lambda-case, and Lambda-cases   | HsLam     (XLam p)+              HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases               (MatchGroup p (LHsExpr p))-                       -- ^ Lambda abstraction. Currently always a single match-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --       'GHC.Parser.Annotation.AnnRarrow',--       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation--  -- | Lambda-case-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-  --           'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',-  --           'GHC.Parser.Annotation.AnnClose'-  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-  --           'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen',-  --           'GHC.Parser.Annotation.AnnClose'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | HsLamCase (XLamCase p) LamCaseVariant (MatchGroup p (LHsExpr p))+                       -- ^ LamSingle: one match of arity >= 1+                       --   LamCase: many arity-1 matches+                       --   LamCases: many matches of uniform arity >= 1    | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application    | HsAppType (XAppTypeE p) -- After typechecking: the type argument               (LHsExpr p)-             !(LHsToken "@" p)               (LHsWcType (NoGhcTc p))  -- ^ Visible type application        --        -- Explicit type argument; e.g  f @Int x y        -- NB: Has wildcards, but no implicit quantification-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt',    -- | Operator applications:   -- 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@@ -329,22 +375,12 @@    -- | Negation operator. Contains the negated expression and the name   -- of 'negate'-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | NegApp      (XNegApp p)                 (LHsExpr p)                 (SyntaxExpr p) -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-  --             'GHC.Parser.Annotation.AnnClose' @')'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsPar       (XPar p)-               !(LHsToken "(" p)                 (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]-               !(LHsToken ")" p)    | SectionL    (XSectionL p)                 (LHsExpr p)    -- operand; see Note [Sections in HsSyn]@@ -354,11 +390,7 @@                 (LHsExpr p)    -- operand    -- | Used for explicit tuples and sections thereof-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --         'GHC.Parser.Annotation.AnnClose' -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- Note [ExplicitTuple]   | ExplicitTuple         (XExplicitTuple p)@@ -366,33 +398,16 @@         Boxity    -- | Used for unboxed sum types-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,-  --          'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@,-  ---  --  There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before-  --  the expression, (arity - alternative) after it   | ExplicitSum           (XExplicitSum p)           ConTag   --  Alternative (one-based)           SumWidth --  Sum arity           (LHsExpr p) -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',-  --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,-  --       'GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsCase      (XCase p)                 (LHsExpr p)                 (MatchGroup p (LHsExpr p)) -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',-  --       'GHC.Parser.Annotation.AnnSemi',-  --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',-  --       'GHC.Parser.Annotation.AnnElse',--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsIf        (XIf p)        -- GhcPs: this is a Bool; False <=> do not use                                --  rebindable syntax                 (LHsExpr p)    --  predicate@@ -400,80 +415,41 @@                 (LHsExpr p)    --  else part    -- | Multi-way if-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf'-  --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]+  | HsMultiIf   (XMultiIf p) (NonEmpty (LGRHS p (LHsExpr p)))    -- | let(rec)-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',-  --       'GHC.Parser.Annotation.AnnOpen' @'{'@,-  --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsLet       (XLet p)-               !(LHsToken "let" p)                 (HsLocalBinds p)-               !(LHsToken "in" p)                 (LHsExpr  p) -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',-  --             'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',-  --             'GHC.Parser.Annotation.AnnVbar',-  --             'GHC.Parser.Annotation.AnnClose'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsDo        (XDo p)                  -- Type of the whole expression                 HsDoFlavour                 (XRec p [ExprLStmt p])   -- "do":one or more stmts    -- | Syntactic list: [a,b,c,...]-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-  --              'GHC.Parser.Annotation.AnnClose' @']'@ -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- See Note [Empty lists]   | ExplicitList                 (XExplicitList p)  -- Gives type of components of list                 [LHsExpr p]    -- | Record construction-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,-  --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | RecordCon       { rcon_ext  :: XRecordCon p       , rcon_con  :: XRec p (ConLikeP p)  -- The constructor       , rcon_flds :: HsRecordBinds p }    -- The fields    -- | Record update-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,-  --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@-  --         'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot',-  --         'GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | RecordUpd       { rupd_ext  :: XRecordUpd p       , rupd_expr :: LHsExpr p-      , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p]+      , rupd_flds :: LHsRecUpdFields p       }   -- For a type family, the arg types are of the *instance* tycon,   -- not the family tycon    -- | Record field selection e.g @z.x@.-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot' -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   -- This case only arises when the OverloadedRecordDot langauge   -- extension is enabled. See Note [Record selectors in the AST].   | HsGetField {@@ -487,20 +463,12 @@   -- This case only arises when the OverloadedRecordDot langauge   -- extensions is enabled. See Note [Record selectors in the AST]. -  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'-  --         'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsProjection {         proj_ext :: XProjection p-      , proj_flds :: NonEmpty (XRec p (DotFieldOcc p))+      , proj_flds :: NonEmpty (DotFieldOcc p)       }    -- | Expression with an explicit type signature. @e :: type@-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ExprWithTySig                 (XExprWithTySig p) @@ -508,12 +476,6 @@                 (LHsSigWcType (NoGhcTc p))    -- | Arithmetic sequence-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-  --              'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot',-  --              'GHC.Parser.Annotation.AnnClose' @']'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ArithSeq                 (XArithSeq p)                 (Maybe (SyntaxExpr p))@@ -525,30 +487,15 @@   -----------------------------------------------------------   -- MetaHaskell Extensions -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --         'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ',-  --         'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsTypedBracket   (XTypedBracket p)   (LHsExpr p)   | HsUntypedBracket (XUntypedBracket p) (HsQuote p)--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --         'GHC.Parser.Annotation.AnnClose'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | HsTypedSplice    (XTypedSplice p)   (LHsExpr p) -- `$$z` or `$$(f 4)`+  | HsTypedSplice    (XTypedSplice p)   (HsTypedSplice p) -- `$$z` or `$$(f 4)`   | HsUntypedSplice  (XUntypedSplice p) (HsUntypedSplice p)    -----------------------------------------------------------   -- Arrow notation extension    -- | @proc@ notation for Arrows-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc',-  --          'GHC.Parser.Annotation.AnnRarrow'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsProc      (XProc p)                 (LPat p)               -- arrow abstraction, proc                 (LHsCmdTop p)          -- body of the abstraction@@ -556,9 +503,6 @@    ---------------------------------------   -- static pointers extension-  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic',--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsStatic (XStatic p) -- Free variables of the body, and type after typechecking              (LHsExpr p)        -- Body @@ -566,9 +510,33 @@   -- Expressions annotated with pragmas, written as {-# ... #-}   | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) +  -- Embed the syntax of types into expressions.+  -- Used with @RequiredTypeArguments@, e.g. @fn (type (Int -> Bool))@.+  | 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]+  | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p)++  -- Constrained types @ctx => t@.+  -- Used with @RequiredTypeArguments@, e.g. @fn (Bounded a => a)@.+  -- See Note [Types in terms]+  | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p)++  -- | Function types @a -> b@.+  -- Used with @RequiredTypeArguments@, e.g. @fn (Int -> Bool)@.+  -- See Note [Types in terms]+  | 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-  -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr+  -- general idea, and Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr   -- for an example of how we use it.  -- ---------------------------------------------------------------------@@ -587,15 +555,6 @@   = HsPragSCC   (XSCC p)                 StringLiteral         -- "set cost centre" SCC pragma -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --       'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@,-  --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal',-  --       'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal',-  --       'GHC.Parser.Annotation.AnnMinus',-  --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon',-  --       'GHC.Parser.Annotation.AnnVal',-  --       'GHC.Parser.Annotation.AnnClose' @'\#-}'@-   | XHsPragE !(XXPragE p)  -- | Located Haskell Tuple Argument@@ -605,10 +564,7 @@ -- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ -- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ type LHsTupArg id = XRec id (HsTupArg id)--- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | Haskell Tuple Argument data HsTupArg id   = Present (XPresent id) (LHsExpr id)     -- ^ The argument@@ -617,9 +573,10 @@                              -- in Language.Haskell.Syntax.Extension  -- | Which kind of lambda case are we dealing with?-data LamCaseVariant-  = LamCase -- ^ `\case`-  | LamCases -- ^ `\cases`+data HsLamVariant+  = LamSingle  -- ^ `\p -> e`+  | LamCase    -- ^ `\case pi -> ei `+  | LamCases   -- ^ `\cases psi -> ei`   deriving (Data, Eq)  {-@@ -793,11 +750,6 @@  -- | Haskell Command (e.g. a "statement" in an Arrow proc block) data HsCmd id-  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail',-  --          'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail',-  --          'GHC.Parser.Annotation.AnnRarrowtail'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)         (XCmdArrApp id)  -- type of the arrow expressions f,                          -- of the form a t t', where arg :: t@@ -807,10 +759,6 @@         Bool             -- True => right-to-left (f -< arg)                          -- False => left-to-right (arg >- f) -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@,-  --         'GHC.Parser.Annotation.AnnCloseB' @'|)'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)         (XCmdArrForm id)         (LHsExpr id)     -- The operator.@@ -818,84 +766,37 @@                          -- applied to the type of the local environment tuple         LexicalFixity    -- Whether the operator appeared prefix or infix when                          -- parsed.-        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that-                         -- were converted from OpApp's by the renamer         [LHsCmdTop id]   -- argument commands    | HsCmdApp    (XCmdApp id)                 (LHsCmd id)                 (LHsExpr id) -  | HsCmdLam    (XCmdLam id)-                (MatchGroup id (LHsCmd id))     -- kappa-       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --       'GHC.Parser.Annotation.AnnRarrow',--       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  -- | Lambda-case+  --+  | HsCmdLam (XCmdLamCase id) HsLamVariant+             (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's    | HsCmdPar    (XCmdPar id)-               !(LHsToken "(" id)                 (LHsCmd id)                     -- parenthesised command-               !(LHsToken ")" id)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-    --             'GHC.Parser.Annotation.AnnClose' @')'@ -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsCmdCase   (XCmdCase id)                 (LHsExpr id)                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',-    --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,-    --       'GHC.Parser.Annotation.AnnClose' @'}'@ -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation--  -- | Lambda-case-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-  --     'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,-  --     'GHC.Parser.Annotation.AnnClose' @'}'@-  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-  --     'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen' @'{'@,-  --     'GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | HsCmdLamCase (XCmdLamCase id) LamCaseVariant-                 (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's-   | HsCmdIf     (XCmdIf id)                 (SyntaxExpr id)         -- cond function                 (LHsExpr id)            -- predicate                 (LHsCmd id)             -- then part                 (LHsCmd id)             -- else part-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',-    --       'GHC.Parser.Annotation.AnnSemi',-    --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',-    --       'GHC.Parser.Annotation.AnnElse', -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsCmdLet    (XCmdLet id)-               !(LHsToken "let" id)                 (HsLocalBinds id)      -- let(rec)-               !(LHsToken "in" id)                 (LHsCmd  id)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',-    --       'GHC.Parser.Annotation.AnnOpen' @'{'@,-    --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression                 (XRec id [CmdLStmt id])-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',-    --             'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',-    --             'GHC.Parser.Annotation.AnnVbar',-    --             'GHC.Parser.Annotation.AnnClose' -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | XCmd        !(XXCmd id)     -- Extension point; see Note [Trees That Grow]                                 -- in Language.Haskell.Syntax.Extension @@ -960,24 +861,23 @@  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 type LMatch id body = XRec id (Match id body)--- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a---   list --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Match p body   = Match {-        m_ext :: XCMatch p body,-        m_ctxt :: HsMatchContext p,-          -- See Note [m_ctxt in Match]-        m_pats :: [LPat p], -- The patterns+        m_ext   :: XCMatch p body,+        m_ctxt  :: HsMatchContext (LIdP (NoGhcTc p)), -- See Note [m_ctxt in Match]+        m_pats  :: XRec p [LPat p],                   -- The patterns         m_grhss :: (GRHSs p body)   }   | XMatch !(XXMatch p body)@@ -985,7 +885,6 @@ {- Note [m_ctxt in Match] ~~~~~~~~~~~~~~~~~~~~~~- A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and so on. @@ -1016,29 +915,29 @@     (  &&&  ) [] ys =  ys  +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. -isInfixMatch :: Match id body -> Bool-isInfixMatch match = case m_ctxt match of-  FunRhs {mc_fixity = Infix} -> True-  _                          -> False+-} + -- | Guarded Right-Hand Sides -- -- GRHSs are used both for pattern bindings and for Matches------  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',---        'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',---        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'---        'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi'---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation 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)@@ -1097,13 +996,6 @@  -- The SyntaxExprs in here are used *only* for do-notation and monad -- comprehensions, which have rebindable syntax. Otherwise they are unused.--- | Exact print annotations when in qualifier lists or guards---  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',---         'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen',---         'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy',---         'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing'---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data StmtLR idL idR body -- body should always be (LHs**** idR)   = LastStmt  -- Always the last Stmt in ListComp, MonadComp,               -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr@@ -1119,9 +1011,7 @@             -- For ListComp we use the baked-in 'return'             -- For DoExpr, MDoExpr, we don't apply a 'return' at all             -- See Note [Monad Comprehensions]-            -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow' -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | BindStmt (XBindStmt idL idR body)              -- ^ Post renaming has optional fail and bind / (>>=) operator.              -- Post typechecking, also has multiplicity of the argument@@ -1131,20 +1021,6 @@              (LPat idL)              body -  -- | 'ApplicativeStmt' represents an applicative expression built with-  -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the-  -- appropriate applicative expression by the desugarer, but it is intended-  -- to be invisible in error messages.-  ---  -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"-  ---  | ApplicativeStmt-             (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body-             [ ( SyntaxExpr idR-               , ApplicativeArg idL) ]-                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]-             (Maybe (SyntaxExpr idR))  -- 'join', if necessary-   | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type                                       -- of the RHS (used for arrows)              body              -- See Note [BodyStmt]@@ -1152,16 +1028,12 @@              (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp                                -- See notes [Monad Comprehensions] -  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet'-  --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@,--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | LetStmt  (XLetStmt idL idR body) (HsLocalBindsLR idL idR)    -- 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]@@ -1191,9 +1063,6 @@     }                                 -- See Note [Monad Comprehensions]    -- Recursive statement (see Note [How RecStmt works] below)-  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec'--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | RecStmt      { recS_ext :: XRecStmt idL idR body      , recS_stmts :: XRec idR [LStmtLR idL idR body]@@ -1249,37 +1118,6 @@ -- '@BindStmt@'s should use the monadic fail and which shouldn't. type FailOperator id = Maybe (SyntaxExpr id) --- | Applicative Argument-data ApplicativeArg idL-  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)-    { xarg_app_arg_one  :: XApplicativeArgOne idL-      -- ^ The fail operator, after renaming-      ---      -- The fail operator is needed if this is a BindStmt-      -- where the pattern can fail. E.g.:-      -- (Just a) <- stmt-      -- The fail operator will be invoked if the pattern-      -- match fails.-      -- It is also used for guards in MonadComprehensions.-      -- The fail operator is Nothing-      -- if the pattern match can't fail-    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)-    , arg_expr          :: LHsExpr idL-    , is_body_stmt      :: Bool-      -- ^ True <=> was a BodyStmt,-      -- False <=> was a BindStmt.-      -- See Note [Applicative BodyStmt]-    }-  | ApplicativeArgMany     -- do { stmts; return vars }-    { xarg_app_arg_many :: XApplicativeArgMany idL-    , app_stmts         :: [ExprLStmt idL] -- stmts-    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)-    , bv_pattern        :: LPat idL      -- (v1,...,vn)-    , stmt_context      :: HsDoFlavour-      -- ^ context of the do expression, used in pprArg-    }-  | XApplicativeArg !(XXApplicativeArg idL)- {- Note [The type of bind in Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1481,12 +1319,16 @@     | 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   = ExpBr  (XExpBr p)   (LHsExpr p)   -- [|  expr  |]@@ -1530,21 +1372,20 @@ -- -- Context of a pattern match. This is more subtle than it would seem. See -- Note [FunBind vs PatBind].-data HsMatchContext p+data HsMatchContext fn   = FunRhs     -- ^ A pattern matching on an argument of a     -- function binding-      { mc_fun        :: LIdP (NoGhcTc p)    -- ^ function binder of @f@-                                             -- See Note [mc_fun field of FunRhs]-                                             -- See #20415 for a long discussion about-                                             -- this field and why it uses NoGhcTc.+      { mc_fun        :: fn    -- ^ function binder of @f@+                               -- See Note [mc_fun field of FunRhs]+                               -- See #20415 for a long discussion about this field       , mc_fixity     :: LexicalFixity -- ^ fixing of @f@       , mc_strictness :: SrcStrictness -- ^ was @f@ banged?                                        -- See Note [FunBind vs PatBind]+      , mc_an         :: XFunRhs       }-  | LambdaExpr                  -- ^Patterns of a lambda   | CaseAlt                     -- ^Patterns and guards in a case alternative-  | LamCaseAlt LamCaseVariant   -- ^Patterns and guards in @\case@ and @\cases@+  | LamAlt HsLamVariant         -- ^Patterns and guards in @\@, @\case@ and @\cases@   | IfAlt                       -- ^Guards of a multi-way if alternative   | ArrowMatchCtxt              -- ^A pattern match inside arrow notation       HsArrowMatchContext@@ -1557,48 +1398,57 @@                                 --    tell matchWrapper what sort of                                 --    runtime error message to generate] -  | StmtCtxt (HsStmtContext p)  -- ^Pattern of a do-stmt, list comprehension,-                                -- pattern guard, etc+  | StmtCtxt (HsStmtContext fn)  -- ^Pattern of a do-stmt, list comprehension,+                                 --  pattern guard, etc    | ThPatSplice            -- ^A Template Haskell pattern splice   | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]   | PatSyn                 -- ^A pattern synonym declaration+  | LazyPatCtx             -- ^An irrefutable pattern -{--Note [mc_fun field of FunRhs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be-a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a-`Name` in `GhcTc` -- not an `Id`.  See Note [NoGhcTc] in GHC.Hs.Extension.+{- Note [mc_fun field of FunRhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsMatchContext is parameterised over `fn`, the function binder stored in `FunRhs`.+This makes pretty printing easy. -Why a `Name` in the typechecker phase?  Because:-* A `Name` is all we need, as it turns out.-* Using an `Id` involves knot-tying in the monad, which led to #22695.+In the use of `HsMatchContext` in `Match`, it is parameterised thus:+    data Match p body = Match { m_ctxt  :: HsMatchContext (LIdP (NoGhcTc p)), ... }+So in a Match, the mc_fun field `FunRhs` will be a `RdrName` in pass `GhcPs`, a `Name`+in `GhcRn`, and (importantly) still a `Name` in `GhcTc` -- not an `Id`.+See Note [NoGhcTc] in GHC.Hs.Extension. -See #20415 for a long discussion.+* Why a `Name` in the typechecker phase?  Because:+  * A `Name` is all we need, as it turns out.+  * Using an `Id` involves knot-tying in the monad, which led to #22695. --}+* Why a /located/ name?  Because we want to record the location of the Id+  on the LHS of /this/ match.  See Note [m_ctxt in Match].  Example:+    (&&&) [] [] = []+    xs  &&&  [] = xs+  The two occurrences of `&&&` have different locations. -isPatSynCtxt :: HsMatchContext p -> Bool-isPatSynCtxt ctxt =-  case ctxt of-    PatSyn -> True-    _      -> False+* Why parameterise `HsMatchContext` over `fn` rather than over the pass `p`?+  Because during typechecking (specifically GHC.Tc.Gen.Match.tcMatch) we need to convert+     HsMatchContext (LIdP (NoGhcTc GhcRn)) --> HsMatchContext (LIdP (NoGhcTc GhcTc))+  With this parameterisation it's easy; if it was parametersed over `p` we'd  need+  a recursive traversal of the HsMatchContext. +See #20415 for a long discussion.+-}+ -- | Haskell Statement Context.-data HsStmtContext p-  = HsDoStmt HsDoFlavour             -- ^Context for HsDo (do-notation and comprehensions)-  | PatGuard (HsMatchContext p)      -- ^Pattern guard for specified thing-  | ParStmtCtxt (HsStmtContext p)    -- ^A branch of a parallel stmt-  | TransStmtCtxt (HsStmtContext p)  -- ^A branch of a transform stmt-  | ArrowExpr                        -- ^do-notation in an arrow-command context+data HsStmtContext fn+  = HsDoStmt HsDoFlavour              -- ^ Context for HsDo (do-notation and comprehensions)+  | PatGuard (HsMatchContext fn)      -- ^ Pattern guard for specified thing+  | ParStmtCtxt (HsStmtContext fn)    -- ^ A branch of a parallel stmt+  | TransStmtCtxt (HsStmtContext fn)  -- ^ A branch of a transform stmt+  | ArrowExpr                         -- ^ do-notation in an arrow-command context  -- | Haskell arrow match context. data HsArrowMatchContext   = ProcExpr                       -- ^ A proc expression   | ArrowCaseAlt                   -- ^ A case alternative inside arrow notation-  | ArrowLamCaseAlt LamCaseVariant -- ^ A \case or \cases alternative inside arrow notation-  | KappaExpr                      -- ^ An arrow kappa abstraction+  | ArrowLamAlt HsLamVariant       -- ^ A \, \case or \cases alternative inside arrow notation  data HsDoFlavour   = DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }@@ -1606,14 +1456,21 @@   | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs   | ListComp   | MonadComp+  deriving (Eq, Data) -qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName+qualifiedDoModuleName_maybe :: HsStmtContext fn -> Maybe ModuleName qualifiedDoModuleName_maybe ctxt = case ctxt of   HsDoStmt (DoExpr m) -> m   HsDoStmt (MDoExpr m) -> m   _ -> Nothing -isComprehensionContext :: HsStmtContext id -> Bool+isPatSynCtxt :: HsMatchContext fn -> Bool+isPatSynCtxt ctxt =+  case ctxt of+    PatSyn -> True+    _      -> False++isComprehensionContext :: HsStmtContext fn -> Bool -- Uses comprehension syntax [ e | quals ] isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c@@ -1629,7 +1486,7 @@ isDoComprehensionContext MonadComp = True  -- | Is this a monadic context?-isMonadStmtContext :: HsStmtContext id -> Bool+isMonadStmtContext :: HsStmtContext fn -> Bool isMonadStmtContext (ParStmtCtxt ctxt)   = isMonadStmtContext ctxt isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour@@ -1643,7 +1500,7 @@ isMonadDoStmtContext MDoExpr{}    = True isMonadDoStmtContext GhciStmtCtxt = True -isMonadCompContext :: HsStmtContext id -> Bool+isMonadCompContext :: HsStmtContext fn -> Bool isMonadCompContext (HsDoStmt flavour)   = isMonadDoCompContext flavour isMonadCompContext (ParStmtCtxt _)   = False isMonadCompContext (TransStmtCtxt _) = False
compiler/Language/Haskell/Syntax/Expr.hs-boot view
@@ -9,6 +9,9 @@ import Language.Haskell.Syntax.Extension ( XRec ) import Data.Kind  ( Type ) +import Prelude (Eq)+import Data.Data (Data)+ type role HsExpr nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal@@ -20,3 +23,7 @@ type family SyntaxExpr (i :: Type)  type LHsExpr a = XRec a (HsExpr a)++data HsDoFlavour+instance Eq HsDoFlavour+instance Data HsDoFlavour
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)@@ -66,7 +63,7 @@ -}  -- | A placeholder type for TTG extension points that are not currently--- unused to represent any particular value.+-- used to represent any particular value. -- -- This should not be confused with 'DataConCantHappen', which are found in unused -- extension /constructors/ and therefore should never be inhabited. In@@ -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@@ -432,6 +471,8 @@ type family XExplicitList   x type family XRecordCon      x type family XRecordUpd      x+type family XLHsRecUpdLabels x+type family XLHsOLRecUpdLabels x type family XGetField       x type family XProjection     x type family XExprWithTySig  x@@ -445,9 +486,18 @@ type family XTick           x 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 type family XXExpr          x  -- -------------------------------------+-- HsMatchContext type families+type family XFunRhs++-- ------------------------------------- -- DotFieldOcc type families type family XCDotFieldOcc  x type family XXDotFieldOcc  x@@ -457,14 +507,7 @@ type family XSCC            x type family XXPragE         x - -- ---------------------------------------- AmbiguousFieldOcc type families-type family XUnambiguous        x-type family XAmbiguous          x-type family XXAmbiguousFieldOcc x---- ------------------------------------- -- HsTupArg type families type family XPresent  x type family XMissing  x@@ -473,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@@ -515,7 +562,6 @@ -- StmtLR type families type family XLastStmt        x x' b type family XBindStmt        x x' b-type family XApplicativeStmt x x' b type family XBodyStmt        x x' b type family XLetStmt         x x' b type family XParStmt         x x' b@@ -543,18 +589,7 @@ type family XParStmtBlock  x x' type family XXParStmtBlock x x' --- ---------------------------------------- ApplicativeArg type families-type family XApplicativeArgOne   x-type family XApplicativeArgMany  x-type family XXApplicativeArg     x- -- =====================================================================--- Type families for the HsImpExp extension points---- TODO---- ===================================================================== -- Type families for the HsLit extension points  -- We define a type family for each extension point. This is based on prepending@@ -562,14 +597,19 @@ type family XHsChar x type family XHsCharPrim x type family XHsString x+type family XHsMultilineString x type family XHsStringPrim x type family XHsInt x type family XHsIntPrim x type family XHsWordPrim x+type family XHsInt8Prim x+type family XHsInt16Prim x+type family XHsInt32Prim x type family XHsInt64Prim x+type family XHsWord8Prim x+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@@ -591,6 +631,7 @@ type family XListPat     x type family XTuplePat    x type family XSumPat      x+type family XOrPat       x type family XConPat      x type family XViewPat     x type family XSplicePat   x@@ -598,6 +639,8 @@ type family XNPat        x type family XNPlusKPat   x type family XSigPat      x+type family XEmbTyPat    x+type family XInvisPat    x type family XCoPat       x type family XXPat        x type family XHsFieldBind x@@ -633,6 +676,11 @@ type family XXHsPatSigType x  -- -------------------------------------+-- HsTyPat type families+type family XHsTP x+type family XXHsTyPat x++-- ------------------------------------- -- HsType type families type family XForAllTy        x type family XQualTy          x@@ -650,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@@ -673,11 +719,15 @@  -- --------------------------------------------------------------------- -- HsTyVarBndr type families-type family XUserTyVar   x-type family XKindedTyVar x+type family XTyVarBndr   x 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@@ -688,7 +738,7 @@ type family XXFieldOcc x  -- =====================================================================--- Type families for the HsImpExp type families+-- Type families for the HsImpExp extension points  -- ------------------------------------- -- ImportDecl type families@@ -711,8 +761,10 @@ -- ------------------------------------- -- IEWrappedName type families type family XIEName p+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,20 +1,20 @@ {-# 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) import Data.String (String) import Data.Int (Int) -import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST+import Control.DeepSeq+import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST  {- ************************************************************************@@ -28,12 +28,7 @@  -- | Located Import Declaration type LImportDecl pass = XRec pass (ImportDecl pass)-        -- ^ When in a list this may have-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | If/how an import is 'qualified'. data ImportDeclQualifiedStyle   = QualifiedPre  -- ^ 'qualified' appears in prepositive position.@@ -41,22 +36,24 @@   | 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) +data ImportDeclLevel = ImportDeclQuote | ImportDeclSplice deriving (Eq, Data)+ -- | Import Declaration -- -- A single Haskell @import@ declaration. data ImportDecl pass   = ImportDecl {-      ideclExt        :: XCImportDecl pass,+      ideclExt        :: XCImportDecl pass, -- ^ Locations of keywords like @import@, @qualified@, etc. are captured here.       ideclName       :: XRec pass ModuleName, -- ^ Module name.       ideclPkgQual    :: ImportDeclPkgQual pass,  -- ^ Package qualifier.-      ideclSource     :: IsBootInterface,      -- ^ IsBoot <=> {-\# SOURCE \#-} import+      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@@ -64,87 +61,101 @@                                        -- ^ Explicit import list (EverythingBut => hiding, names)     }   | XImportDecl !(XXImportDecl pass)-     -- ^-     --  'GHC.Parser.Annotation.AnnKeywordId's-     ---     --  - 'GHC.Parser.Annotation.AnnImport'-     ---     --  - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource-     ---     --  - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified',-     --    'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs',-     --    'GHC.Parser.Annotation.AnnVal'-     ---     --  - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen',-     --    'GHC.Parser.Annotation.AnnClose' attached-     --     to location in ideclImportList -     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation---- | Whether the import list is exactly what to import, or whether `hiding` was+-- | Whether the import list is exactly what to import, or whether @hiding@ was -- used, and therefore everything but what was listed should be imported data ImportListInterpretation = Exactly | EverythingBut     deriving (Eq, Data) +instance NFData ImportListInterpretation where+  rnf = rwhnf+ -- | Located Import or Export type LIE pass = XRec pass (IE pass)         -- ^ When in a list this may have-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+-- | A docstring attached to an export list item.+type ExportDoc pass = LHsDoc pass  -- | Imported or exported entity. data IE pass-  = IEVar       (XIEVar pass) (LIEWrappedName pass)-        -- ^ Imported or Exported Variable+  = IEVar (XIEVar pass) (LIEWrappedName pass) (Maybe (ExportDoc pass))+        -- ^ Imported or exported variable+        --+        -- @+        -- module Mod ( test )+        -- import Mod ( test )+        -- @ -  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName pass)-        -- ^ Imported or exported Thing with Absent list+  | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass) (Maybe (ExportDoc pass))+        -- ^ Imported or exported Thing with absent subordinate list         ---        -- The thing is a Class/Type (can't tell)-        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',-        --             'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal'+        -- The thing is a Class\/Type (can't tell)+        --+        -- @+        -- module Mod ( Test )+        -- import Mod ( Test )+        -- @ -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr-  | IEThingAll  (XIEThingAll pass) (LIEWrappedName pass)-        -- ^ Imported or exported Thing with All imported or exported+  | IEThingAll  (XIEThingAll pass) (LIEWrappedName pass) (Maybe (ExportDoc pass))+        -- ^ Imported or exported thing with wildcard subordinate list (e.g. @(..)@)         ---        -- The thing is a Class/Type and the All refers to methods/constructors+        -- The thing is a Class\/Type and the All refers to methods\/constructors         ---        -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',-        --       'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',-        --                                 'GHC.Parser.Annotation.AnnType'+        -- @+        -- module Mod ( Test(..) )+        -- import Mod ( Test(..) )+        -- @ -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr-   | IEThingWith (XIEThingWith pass)                 (LIEWrappedName pass)                 IEWildcard                 [LIEWrappedName pass]-        -- ^ Imported or exported Thing With given imported or exported+                (Maybe (ExportDoc pass))+        -- ^ Imported or exported thing with explicit subordinate list.         ---        -- The thing is a Class/Type and the imported or exported things are-        -- methods/constructors and record fields; see Note [IEThingWith]-        -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',-        --                                   'GHC.Parser.Annotation.AnnClose',-        --                                   'GHC.Parser.Annotation.AnnComma',-        --                                   'GHC.Parser.Annotation.AnnType'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+        -- The thing is a Class\/Type (can't tell) and the imported or exported things are+        -- its children.+        --+        -- @+        -- module Mod ( Test(f, g) )+        -- import Mod ( Test(f, g) )+        -- @   | IEModuleContents  (XIEModuleContents pass) (XRec pass ModuleName)-        -- ^ Imported or exported module contents+        -- ^ Export of entire module. Can only occur in export list.         ---        -- (Export Only)+        -- @+        -- module Mod ( module Mod2 )+        -- @+  | IEGroup (XIEGroup pass) Int (LHsDoc pass)+        -- ^ A Haddock section in an export list.         ---        -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | IEGroup             (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading-  | IEDoc               (XIEDoc pass) (LHsDoc pass)       -- ^ Some documentation-  | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc+        -- @+        -- module Mod+        --   ( -- * Section heading+        --     ...+        --   )+        -- @+  | IEDoc (XIEDoc pass) (LHsDoc pass)+        -- ^ A bit of unnamed documentation.+        --+        -- @+        -- module Mod+        --   ( -- | Documentation+        --     ...+        --   )+        -- @+  | IEDocNamed (XIEDocNamed pass) String+        -- ^ A reference to a named documentation chunk.+        --+        -- @+        -- module Mod+        --   ( -- $chunkName+        --     ...+        --   )+        -- @   | XIE !(XXIE pass)  -- | Wildcard in an import or export sublist, like the @..@ in@@ -158,17 +169,14 @@  -- | A name in an import or export specification which may have -- adornments. Used primarily for accurate pretty printing of--- ParsedSource, and API Annotation placement. The--- 'GHC.Parser.Annotation' is the location of the adornment in--- the original source.+-- ParsedSource, and API Annotation placement. data IEWrappedName p-  = IEName    (XIEName p)    (LIdP p)  -- ^ no extra-  | IEPattern (XIEPattern p) (LIdP p)  -- ^ pattern X-  | IEType    (XIEType p)    (LIdP p)  -- ^ type (:+:)+  = 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@+  | IEType    (XIEType p)    (LIdP p)  -- ^ @type (:+:)@+  | IEData    (XIEData p)    (LIdP p)  -- ^ @data (:+:)@   | XIEWrappedName !(XXIEWrappedName p)  -- | Located name with possible adornment--- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType',---         'GHC.Parser.Annotation.AnnPattern' type LIEWrappedName p = XRec p (IEWrappedName p)--- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
− 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
@@ -20,9 +20,7 @@  import Language.Haskell.Syntax.Extension -import GHC.Utils.Panic (panic)-import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText, negateIntegralLit, negateFractionalLit)-import GHC.Core.Type (Type)+import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText)  import GHC.Data.FastString (FastString, lexicalCompareFS) @@ -42,9 +40,9 @@ ************************************************************************ -} --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in+-- Note [Literal source text] in "GHC.Types.SourceText" for SourceText fields in -- the following--- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the Xxxxx+-- Note [Trees That Grow] in "Language.Haskell.Syntax.Extension" for the Xxxxx -- fields in the following -- | Haskell Literal data HsLit x@@ -54,6 +52,8 @@       -- ^ Unboxed character   | HsString (XHsString x) {- SourceText -} FastString       -- ^ String+  | HsMultilineString (XHsMultilineString x) {- SourceText -} FastString+      -- ^ String   | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString       -- ^ Packed bytes   | HsInt (XHsInt x)  IntegralLit@@ -63,26 +63,29 @@       -- ^ literal @Int#@   | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer       -- ^ literal @Word#@+  | HsInt8Prim (XHsInt8Prim x) {- SourceText -} Integer+      -- ^ literal @Int8#@+  | HsInt16Prim (XHsInt16Prim x) {- SourceText -} Integer+      -- ^ literal @Int16#@+  | HsInt32Prim (XHsInt32Prim x) {- SourceText -} Integer+      -- ^ literal @Int32#@   | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer       -- ^ literal @Int64#@+  | HsWord8Prim (XHsWord8Prim x) {- SourceText -} Integer+      -- ^ literal @Word8#@+  | HsWord16Prim (XHsWord16Prim x) {- SourceText -} Integer+      -- ^ literal @Word16#@+  | HsWord32Prim (XHsWord32Prim x) {- SourceText -} Integer+      -- ^ 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@@ -92,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@@ -107,7 +109,7 @@   | XOverLit       !(XXOverLit p) --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in+-- Note [Literal source text] in "GHC.Types.SourceText" for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal@@ -116,29 +118,12 @@   | HsIsString   !SourceText !FastString -- ^ String-looking literals   deriving Data -negateOverLitVal :: OverLitVal -> OverLitVal-negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)-negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)-negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"---- Comparison operations are needed when grouping literals--- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)-instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where-  (OverLit _ val1) == (OverLit _ val2) = val1 == val2-  (XOverLit  val1) == (XOverLit  val2) = val1 == val2-  _ == _ = panic "Eq HsOverLit"- instance Eq OverLitVal where   (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2   (HsFractional f1)   == (HsFractional f2)   = f1 == f2   (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2   _                   == _                   = False -instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where-  compare (OverLit _ val1)  (OverLit _ val2) = val1 `compare` val2-  compare (XOverLit  val1)  (XOverLit  val2) = val1 `compare` val2-  compare _ _ = panic "Ord HsOverLit"- instance Ord OverLitVal where   compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2   compare (HsIntegral _)      (HsFractional _)    = LT@@ -149,4 +134,3 @@   compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `lexicalCompareFS` s2   compare (HsIsString _ _)    (HsIntegral   _)    = GT   compare (HsIsString _ _)    (HsFractional _)    = GT-
compiler/Language/Haskell/Syntax/Module/Name.hs view
@@ -2,27 +2,28 @@  import Prelude -import Data.Data import Data.Char (isAlphaNum)+import Data.Data import Control.DeepSeq import qualified Text.ParserCombinators.ReadP as Parse import System.FilePath -import GHC.Utils.Misc (abstractConstr) import GHC.Data.FastString  -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString deriving (Show, Eq) -instance Ord ModuleName where-  nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2- instance Data ModuleName where   -- don't traverse?-  toConstr _   = abstractConstr "ModuleName"+  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+ instance NFData ModuleName where   rnf x = x `seq` () @@ -56,5 +57,5 @@  parseModuleName :: Parse.ReadP ModuleName parseModuleName = fmap mkModuleName-                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")+                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.'")
compiler/Language/Haskell/Syntax/Pat.hs view
@@ -21,14 +21,15 @@ module Language.Haskell.Syntax.Pat (         Pat(..), LPat,         ConLikeP,+        isInvisArgPat, isInvisArgLPat,+        isVisArgPat, isVisArgLPat,          HsConPatDetails, hsConPatArgs,-        HsConPatTyArg(..),-        HsRecFields(..), HsFieldBind(..), LHsFieldBind,+        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)@@ -36,7 +37,6 @@ -- friends: import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type @@ -52,69 +52,48 @@ import Data.Int import Data.Function import qualified Data.List+import Data.List.NonEmpty (NonEmpty)  type LPat p = XRec p (Pat p)  -- | Pattern------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Pat p   =     ------------ Simple patterns ----------------    WildPat     (XWildPat p)        -- ^ Wildcard Pattern-        -- The sole reason for a type on a WildPat is to-        -- support hsPatType :: Pat Id -> Type+    WildPat     (XWildPat p)+    -- ^ Wildcard Pattern, i.e. @_@ -       -- AZ:TODO above comment needs to be updated   | VarPat      (XVarPat p)-                (LIdP p)     -- ^ Variable Pattern+                (LIdP p)+    -- ^ Variable Pattern, e.g. @x@ -                             -- See Note [Located RdrNames] in GHC.Hs.Expr+    -- See Note [Located RdrNames] in GHC.Hs.Expr   | LazyPat     (XLazyPat p)-                (LPat p)                -- ^ Lazy Pattern-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde'--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-+                (LPat p)+    -- ^ Lazy Pattern, e.g. @~x@   | AsPat       (XAsPat p)                 (LIdP p)-               !(LHsToken "@" p)-                (LPat p)    -- ^ As pattern-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-+                (LPat p)+    -- ^ As pattern, e.g. @x\@pat@   | ParPat      (XParPat p)-               !(LHsToken "(" p)-                (LPat p)                -- ^ Parenthesised pattern-               !(LHsToken ")" p)-                                        -- See Note [Parens in HsSyn] in GHC.Hs.Expr-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-    --                                    'GHC.Parser.Annotation.AnnClose' @')'@+                (LPat p)+    -- ^ Parenthesised pattern, e.g. @(x)@ -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+    -- See Note [Parens in HsSyn] in GHC.Hs.Expr   | BangPat     (XBangPat p)-                (LPat p)                -- ^ Bang pattern-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'--    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+                (LPat p)+    -- ^ Bang pattern, e.g. @!x@          ------------ Lists, tuples, arrays ---------------   | ListPat     (XListPat p)                 [LPat p]--    -- ^ Syntactic List-    ---    -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-    --                                    'GHC.Parser.Annotation.AnnClose' @']'@+    -- ^ Syntactic List, e.g. @[x]@ or @[x,y]@.+    -- Note that @[]@ and @(x:xs)@ patterns are both represented using 'ConPat'. -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | -- | Tuple pattern, e.g. @(x, y)@ (boxed tuples) or @(# x, y #)@ (requires @-XUnboxedTuples@)+    TuplePat    (XTuplePat p)    -- ^ After typechecking, holds the types of the tuple components+                [LPat p]         -- ^ Tuple sub-patterns+                Boxity -  | TuplePat    (XTuplePat p)-                  -- after typechecking, holds the types of the tuple components-                [LPat p]         -- Tuple sub-patterns-                Boxity           -- UnitPat is TuplePat []         -- You might think that the post typechecking Type was redundant,         -- because we can get the pattern type by getting the types of the         -- sub-patterns.@@ -131,23 +110,19 @@         -- of the tuple is of type 'a' not Int.  See selectMatchVar         -- (June 14: I'm not sure this comment is right; the sub-patterns         --           will be wrapped in CoPats, no?)-    -- ^ Tuple sub-patterns++  | OrPat       (XOrPat p)+                (NonEmpty (LPat p))+    -- ^ Or Pattern, e.g. @(pat_1; ...; pat_n)@. Used by @-XOrPatterns@     ---    -- - 'GHC.Parser.Annotation.AnnKeywordId' :-    --            'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@,-    --            'GHC.Parser.Annotation.AnnClose' @')'@ or  @'#)'@+    -- @since 9.12.1    | SumPat      (XSumPat p)        -- after typechecker, types of the alternative                 (LPat p)           -- Sum sub-pattern                 ConTag             -- Alternative (one-based)                 SumWidth           -- Arity (INVARIANT: ≥ 2)-    -- ^ Anonymous sum pattern-    ---    -- - 'GHC.Parser.Annotation.AnnKeywordId' :-    --            'GHC.Parser.Annotation.AnnOpen' @'(#'@,-    --            'GHC.Parser.Annotation.AnnClose' @'#)'@ -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+    -- ^ Anonymous sum pattern, e.g. @(# x | #)@. Used by @-XUnboxedSums@          ------------ Constructor patterns ---------------   | ConPat {@@ -155,35 +130,30 @@         pat_con     :: XRec p (ConLikeP p),         pat_args    :: HsConPatDetails p     }-    -- ^ Constructor Pattern+    -- ^ Constructor Pattern, e.g. @()@, @[]@ or @Nothing@          ------------ View patterns ----------------  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow' -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ViewPat       (XViewPat p)                   (LHsExpr p)                   (LPat p)-    -- ^ View Pattern+    -- ^ View Pattern, e.g. @someFun -> pat@. Used by @-XViewPatterns@          ------------ Pattern splices ----------------  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@-  --        'GHC.Parser.Annotation.AnnClose' @')'@ -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SplicePat       (XSplicePat p)-                    (HsUntypedSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)+                    (HsUntypedSplice p)+  -- ^  Splice Pattern, e.g. @$(pat)@          ------------ Literal and n+k patterns ---------------   | LitPat          (XLitPat p)-                    (HsLit p)           -- ^ Literal Pattern-                                        -- Used for *non-overloaded* literal patterns:-                                        -- Int#, Char#, Int, Char, String, etc.+                    (HsLit p)+    -- ^ Literal Pattern+    --+    -- Used for __non-overloaded__ literal patterns:+    -- Int#, Char#, Int, Char, String, etc. -  | NPat                -- Natural Pattern-                        -- Used for all overloaded literals,-                        -- including overloaded strings with -XOverloadedStrings-                    (XNPat p)            -- Overall type of pattern. Might be+  | NPat            (XNPat p)            -- Overall type of pattern. Might be                                          -- different than the literal's type                                          -- if (==) or negate changes the type                     (XRec p (HsOverLit p))     -- ALWAYS positive@@ -192,12 +162,11 @@                                            -- otherwise                     (SyntaxExpr p)       -- Equality checker, of type t->t->Bool -  -- ^ Natural Pattern-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@+  -- ^ Natural Pattern, used for all overloaded literals, including overloaded Strings+  -- with @-XOverloadedStrings@ -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern+  | -- | n+k pattern, e.g. @n+1@, used by @-XNPlusKPatterns@+   NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern                     (LIdP p)                 -- n+k pattern                     (XRec p (HsOverLit p))   -- It'll always be an HsIntegral                     (HsOverLit p)            -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat@@ -206,43 +175,65 @@                      (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool                     (SyntaxExpr p)   -- Name of '-' (see GHC.Rename.Env.lookupSyntax)-  -- ^ n+k pattern          ------------ Pattern type signatures ----------------  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SigPat          (XSigPat p)             -- After typechecker: Type                     (LPat p)                -- Pattern with a type signature                     (HsPatSigType (NoGhcTc p)) --  Signature can bind both                                                --  kind and type vars -    -- ^ Pattern with a type signature+   -- ^ Pattern with a type signature, e.g. @x :: Int@ -  -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension-  | XPat-      !(XXPat p)+  | -- | Embed the syntax of types into patterns, e.g. @fn (type t) = rhs@.+    -- Enabled by @-XExplicitNamespaces@ in conjunction with @-XRequiredTypeArguments@.+    EmbTyPat        (XEmbTyPat p)+                    (HsTyPat (NoGhcTc p)) +  | InvisPat (XInvisPat p) (HsTyPat (NoGhcTc p))+  -- ^ Type abstraction which brings into scope type variables associated with invisible forall.+  -- E.g. @fn \@t ... = rhs@. Used by @-XTypeAbstractions@.++  -- See Note [Invisible binders in functions] in GHC.Hs.Pat++  | -- | TTG Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension+    XPat !(XXPat p)+ type family ConLikeP x   -- --------------------------------------------------------------------- --- | Type argument in a data constructor pattern,---   e.g. the @\@a@ in @f (Just \@a x) = ...@.-data HsConPatTyArg p =-  HsConPatTyArg-    !(LHsToken "@" p)-     (HsPatSigType 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] +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@@ -250,11 +241,14 @@ data HsRecFields p arg         -- A bunch of record fields                                 --      { x = 3, y = True }         -- Used for both expressions and patterns-  = HsRecFields { rec_flds   :: [LHsRecField p arg],+  = HsRecFields { rec_ext    :: !(XHsRecFields p),+                  rec_flds   :: [LHsRecField p arg],                   rec_dotdot :: Maybe (XRec p RecFieldsDotDot) }  -- Note [DotDot fields]   -- AZ:The XRec for LHsRecField makes the derivings fail.   -- deriving (Functor, Foldable, Traversable) +type family XHsRecFields p+ -- | Newtype to be able to have a specific XRec instance for the Int in `rec_dotdot` newtype RecFieldsDotDot = RecFieldsDotDot { unRecFieldsDotDot :: Int }     deriving (Data, Eq, Ord)@@ -279,20 +273,16 @@ -- | Located Haskell Record Field type LHsRecField  p arg = XRec p (HsRecField  p arg) --- | Located Haskell Record Update Field-type LHsRecUpdField p   = XRec p (HsRecUpdField p)- -- | Haskell Record Field type HsRecField p arg   = HsFieldBind (LFieldOcc p) arg +-- | Located Haskell Record Update Field+type LHsRecUpdField p q = XRec p (HsRecUpdField p q)+ -- | Haskell Record Update Field-type HsRecUpdField p    = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr p)+type HsRecUpdField p q  = HsFieldBind (LFieldOcc p) (LHsExpr q)  -- | Haskell Field Binding------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual',------ For details on above see Note [exact print annotations] in GHC.Parser.Annotation data HsFieldBind lhs rhs = HsFieldBind {         hfbAnn :: XHsFieldBind lhs,         hfbLHS :: lhs,@@ -353,14 +343,4 @@ -- --     hfbLHS = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id ----- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head.--hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc 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 -> XCFieldOcc p-hsRecFieldSel = foExt . unXRec @p . hfbLHS-+-- See also Note [Disambiguating record updates] in GHC.Rename.Pat.
+ compiler/Language/Haskell/Syntax/Specificity.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE MultiWayIf, PatternSynonyms #-}++-- TODO Everthing in this module should be moved to+-- Language.Haskell.Syntax.Decls++module Language.Haskell.Syntax.Specificity (+        -- * ForAllTyFlags+        ForAllTyFlag(Invisible,Required,Specified,Inferred),+        Specificity(..),+        isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag,+        isSpecifiedForAllTyFlag,+        coreTyLamForAllTyFlag,+        ) where++import Prelude++import Data.Data++-- | ForAllTyFlag+--+-- Is something required to appear in source Haskell ('Required'),+-- permitted by request ('Specified') (visible type application), or+-- prohibited entirely from appearing in source Haskell ('Inferred')?+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep"+data ForAllTyFlag = Invisible !Specificity+                  | Required+  deriving (Eq, Ord, Data)+  -- (<) on ForAllTyFlag means "is less visible than"++-- | Whether an 'Invisible' argument may appear in source Haskell.+data Specificity = InferredSpec+                   -- ^ the argument may not appear in source Haskell, it is+                   -- only inferred.+                 | SpecifiedSpec+                   -- ^ the argument may appear in source Haskell, but isn't+                   -- required.+  deriving (Eq, Ord, Data)++pattern Inferred, Specified :: ForAllTyFlag+pattern Inferred  = Invisible InferredSpec+pattern Specified = Invisible SpecifiedSpec++{-# COMPLETE Required, Specified, Inferred #-}++-- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell?+isVisibleForAllTyFlag :: ForAllTyFlag -> Bool+isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af)++-- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell?+isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool+isInvisibleForAllTyFlag (Invisible {}) = True+isInvisibleForAllTyFlag Required       = False++isInferredForAllTyFlag :: ForAllTyFlag -> Bool+-- More restrictive than isInvisibleForAllTyFlag+isInferredForAllTyFlag (Invisible InferredSpec) = True+isInferredForAllTyFlag _                        = False++isSpecifiedForAllTyFlag :: ForAllTyFlag -> Bool+-- More restrictive than isInvisibleForAllTyFlag+isSpecifiedForAllTyFlag (Invisible SpecifiedSpec) = True+isSpecifiedForAllTyFlag _                         = False++coreTyLamForAllTyFlag :: ForAllTyFlag+-- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable.+-- If you want other ForAllTyFlag, use a cast.+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep+coreTyLamForAllTyFlag = Specified
compiler/Language/Haskell/Syntax/Type.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+{-# LANGUAGE LambdaCase #-}                                       -- in module Language.Haskell.Syntax.Extension {- (c) The University of Glasgow 2006@@ -19,62 +20,64 @@  -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type (-        HsScaled(..),-        hsMult, hsScaledThing,-        HsArrow(..),-        HsLinearArrowTokens(..),+        HsMultAnn, HsMultAnnOf(..),+        XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOf,          HsType(..), LHsType, HsKind, LHsKind,-        HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,+        HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,+        HsBndrVar(..), XBndrVar, XBndrWildCard, XXBndrVar,+        HsBndrKind(..), XBndrKind, XBndrNoKind, XXBndrKind,+        isHsBndrInvisible,+        isHsBndrWildCard,+        HsForAllTelescope(..),+        HsTyVarBndr(..), LHsTyVarBndr,         LHsQTyVars(..),         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,         HsWildCardBndrs(..),         HsPatSigType(..),         HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,+        HsTyPat(..), LHsTyPat,         HsTupleSort(..),         HsContext, LHsContext,         HsTyLit(..),         HsIPName(..), hsIPNameFS,-        HsArg(..),+        HsArg(..), XValArg, XTypeArg, XArgPar, XXArg,+         LHsTypeArg, -        LBangType, BangType,-        HsSrcBang(..),         PromotionFlag(..), isPromoted, -        ConDeclField(..), LConDeclField,+        HsConDeclRecField(..), LHsConDeclRecField, -        HsConDetails(..), noTypeArgs,+        HsConDetails(..),+        HsConDeclField(..),          FieldOcc(..), LFieldOcc,-        AmbiguousFieldOcc(..), LAmbiguousFieldOcc,          mapHsOuterImplicit,         hsQTvExplicit,-        isHsKindedTyVar,-        hsPatSigType,+        isHsKindedTyVar     ) where  import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) -import Language.Haskell.Syntax.Concrete+import Language.Haskell.Syntax.Basic ( SrcStrictness, SrcUnpackedness ) import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Specificity -import GHC.Types.Name.Reader ( RdrName )-import GHC.Core.DataCon( HsSrcBang(..) )-import GHC.Core.Type (Specificity)-import GHC.Types.SrcLoc (SrcSpan)  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  {- ************************************************************************@@ -88,30 +91,15 @@ data PromotionFlag   = NotPromoted   | IsPromoted-  deriving ( Eq, Data )+  deriving ( Eq, Data, Ord )  isPromoted :: PromotionFlag -> Bool 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  = ()  {- ************************************************************************@@ -291,28 +279,19 @@  -- | Located Haskell Context type LHsContext pass = XRec pass (HsContext pass)-      -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit'-      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | Haskell Context type HsContext pass = [LHsType pass]  -- | Located Haskell Type type LHsType pass = XRec pass (HsType pass)-      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when-      --   in a list -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- | Haskell Kind type HsKind pass = HsType pass  -- | Located Haskell Kind type LHsKind pass = XRec pass (HsKind pass)-      -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -------------------------------------------------- --             LHsQTyVars --  The explicitly-quantified binders in a data/type declaration@@ -342,13 +321,14 @@ data LHsQTyVars pass   -- See Note [HsType binders]   = HsQTvs { hsq_ext :: XHsQTvs pass -           , hsq_explicit :: [LHsTyVarBndr () pass]+           , hsq_explicit :: [LHsTyVarBndr (HsBndrVis pass) pass]                 -- Explicit variables, written by the user     }   | XLHsQTyVars !(XXLHsQTyVars pass) -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass]-hsQTvExplicit = hsq_explicit+hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]+hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs+hsQTvExplicit (XLHsQTyVars {})                         = panic "hsQTvExplicit"  ------------------------------------------------ --            HsOuterTyVarBndrs@@ -356,7 +336,7 @@ -- the forall-or-nothing rule. These are used to represent the outermost -- quantification in: --    * Type signatures (LHsSigType/LHsSigWcType)---    * Patterns in a type/data family instance (HsTyPats)+--    * Patterns in a type/data family instance (HsFamEqnPats) -- -- We support two forms: --   HsOuterImplicit (implicit quantification, added by renamer)@@ -445,6 +425,14 @@ -- | Located Haskell Signature Wildcard Type type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both +data HsTyPat pass+  = HsTP { hstp_ext  :: XHsTP pass   -- ^ After renamer: 'HsTyPatRn'+         , hstp_body :: LHsType pass -- ^ Main payload (the type itself)+    }+  | XHsTyPat !(XXHsTyPat pass)++type LHsTyPat  pass = XRec pass (HsTyPat pass)+ -- | A type signature that obeys the @forall@-or-nothing rule. In other -- words, an 'LHsType' that uses an 'HsOuterSigTyVarBndrs' to represent its -- outermost type variable quantification.@@ -456,9 +444,6 @@           }   | XHsSigType !(XXHsSigType pass) -hsPatSigType :: HsPatSigType pass -> LHsType pass-hsPatSigType = hsps_body- {- Note [forall-or-nothing rule] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -689,36 +674,140 @@ --------------------------------------------------  -- | Haskell Type Variable Binder--- The flag annotates the binder. It is 'Specificity' in places where--- explicit specificity is allowed (e.g. x :: forall {a} b. ...) or--- '()' in other places.+-- See Note [Type variable binders] data HsTyVarBndr flag pass-  = UserTyVar        -- no explicit kinding-         (XUserTyVar pass)-         flag-         (LIdP pass)-        -- See Note [Located RdrNames] in GHC.Hs.Expr+  = HsTvb { tvb_ext  :: XTyVarBndr pass+          , tvb_flag :: flag+          , tvb_var  :: HsBndrVar pass+          , tvb_kind :: HsBndrKind pass }+  | XTyVarBndr+      !(XXTyVarBndr pass) -  | KindedTyVar-         (XKindedTyVar pass)-         flag-         (LIdP pass)-         (LHsKind pass)  -- The user-supplied kind signature-        -- ^-        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --          'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnClose'+data HsBndrVis pass+  = HsBndrRequired !(XBndrRequired pass)+      -- Binder for a visible (required) variable:+      --     type Dup a = (a, a)+      --             ^^^ -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | HsBndrInvisible !(XBndrInvisible pass)+      -- Binder for an invisible (specified) variable:+      --     type KindOf @k (a :: k) = k+      --                ^^^ -  | XTyVarBndr-      !(XXTyVarBndr pass)+  | XBndrVis !(XXBndrVis pass) +type family XBndrRequired  p+type family XBndrInvisible p+type family XXBndrVis      p++isHsBndrInvisible :: HsBndrVis pass -> Bool+isHsBndrInvisible HsBndrInvisible{} = True+isHsBndrInvisible HsBndrRequired{}  = False+isHsBndrInvisible (XBndrVis _)      = False++data HsBndrVar pass+  = HsBndrVar !(XBndrVar pass) !(LIdP pass)+  | HsBndrWildCard !(XBndrWildCard pass)+  | XBndrVar !(XXBndrVar pass)++type family XBndrVar p+type family XBndrWildCard p+type family XXBndrVar p++isHsBndrWildCard :: HsBndrVar pass -> Bool+isHsBndrWildCard HsBndrWildCard{} = True+isHsBndrWildCard HsBndrVar{}      = False+isHsBndrWildCard (XBndrVar _)     = False++data HsBndrKind pass+  = HsBndrKind   !(XBndrKind pass) (LHsKind pass)+  | HsBndrNoKind !(XBndrNoKind pass)+  | XBndrKind    !(XXBndrKind pass)++type family XBndrKind   p+type family XBndrNoKind p+type family XXBndrKind  p+ -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool-isHsKindedTyVar (UserTyVar {})   = False-isHsKindedTyVar (KindedTyVar {}) = True-isHsKindedTyVar (XTyVarBndr {})  = False+isHsKindedTyVar (HsTvb { tvb_kind = kind }) =+  case kind of+    HsBndrKind _ _ -> True+    HsBndrNoKind _ -> False+    XBndrKind    _ -> False+isHsKindedTyVar (XTyVarBndr {}) = False ++{- Note [Type variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type variable binders, represented by the HsTyVarBndr type, can occur in the+following contexts:++1. On the left-hand sides of type/class declarations (TyClDecl)++      data D a b = ...       -- data types     (DataDecl)+      newtype N a b = ...    -- newtypes       (DataDecl)+      type T a b = ...       -- type synonyms  (SynDecl)+      class C a b where ...  -- classes        (ClassDecl)+      type family TF a b     -- type families  (FamDecl)+      data family DF a b     -- data families  (FamDecl)++   The `a` and `b` in these examples are type variable binders.++2. In forall telescopes (HsForAllTy and HsOuterTyVarBndrs)++    2-Invis. forall {a} b. ...    -- invisible forall (HsForAllInvis)+    2-Vis.   forall a b -> ...    -- visible forall   (HsForAllVis)++   Again, `a` and `b` are type variable binders.++3. In type family result signatures (FamilyResultSig), which are+   part of the TypeFamilyDependencies extension++      type family F a = r | r -> a  -- result sig (TyVarSig)++   The `r` immediately to the right of `=` is a type variable binder.++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) = ...  -- invisible type arguments (InvisPat)+                                -- in constructor patterns (ConPat)++   Here, the `a` and `b` are type variable binders iff+   `GHC.Tc.Gen.HsType.tyPatToBndr` returns `Just`.++A type variable binder has three parts:+  * flag      (HsBndrVis, Specificity, or () -- depending on context)+  * variable  (HsBndrVar)+  * kind      (HsBndrKind)++Details about each part:++* The binder variable (HsBndrVar) is either a type variable name or a wildcard,+  i.e. `a` vs `_` (HsBndrVar vs HsBndrWildCard).++* The binder kind (HsBndrKind) stores the optional kind annotation,+  i.e. `a` vs `a :: k` (HsBndrNoKind vs HsBndrKind).++* The binder flag is instantiated to one of the following types,+  depending on the context where it occurs (contexts 1..4 are listed above)++    (a) flag=HsBndrVis records `a` vs `@a` (HsBndrRequired vs HsBndrInvisible)+          (used in contexts: 1)+    (b) flag=Specificity records `a` vs `{a}` (SpecifiedSpec vs InferredSpec)+          (used in contexts: 2-Invis)+    (c) flag=() is used when there is no distinction to record+          (used in contexts: 2-Vis, 3, 4)++All in all, we have the following forms of type variable binders in the language++  a, (a :: k), @a, @(a :: k), {a}, {a :: k}+  _, (_ :: k), @_, @(_ :: k)++The forms {_}, {_ :: k} are representable but never valid, see+Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type -}+ -- | Haskell Type data HsType pass   = HsForAllTy   -- See Note [HsType binders]@@ -727,9 +816,6 @@                                      -- Explicit, user-supplied 'forall a {b} c'       , hst_body    :: LHsType pass  -- body type       }-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForall',-      --         'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'-      -- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation"    | HsQualTy   -- See Note [HsType binders]       { hst_xqual :: XQualTy pass@@ -739,157 +825,83 @@   | 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-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsAppTy             (XAppTy pass)                         (LHsType pass)                         (LHsType pass)-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsAppKindTy         (XAppKindTy pass) -- type level type app                         (LHsType pass)                         (LHsKind pass)    | HsFunTy             (XFunTy pass)-                        (HsArrow pass)+                        (HsMultAnn pass) -- multiplicty annotations, includes the arrow                         (LHsType pass)   -- function type                         (LHsType pass)-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow', -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsListTy            (XListTy pass)                         (LHsType pass)  -- Element type-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-      --         'GHC.Parser.Annotation.AnnClose' @']'@ -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsTupleTy           (XTupleTy pass)                         HsTupleSort                         [LHsType pass]  -- Element types (length gives arity)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(' or '(#'@,-    --         'GHC.Parser.Annotation.AnnClose' @')' or '#)'@ -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsSumTy             (XSumTy pass)                         [LHsType pass]  -- Element types (length gives arity)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,-    --         'GHC.Parser.Annotation.AnnClose' '#)'@ -    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsOpTy              (XOpTy pass)                         PromotionFlag    -- Whether explicitly promoted,                                          -- for the pretty printer-                        (LHsType pass) (LIdP pass) (LHsType pass)-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+                        (LHsType pass) (LIdOccP pass) (LHsType pass)    | HsParTy             (XParTy pass)                         (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr         -- Parenthesis preserved for the precedence re-arrangement in         -- GHC.Rename.HsType         -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-      --         'GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsIParamTy          (XIParamTy pass)                         (XRec pass HsIPName) -- (?x :: ty)                         (LHsType pass)   -- Implicit parameters as they occur in                                          -- contexts       -- ^       -- > (?x :: ty)-      ---      -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsStarTy            (XStarTy pass)                         Bool             -- Is this the Unicode variant?                                          -- Note [HsStarTy]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None    | HsKindSig           (XKindSig pass)                         (LHsType pass)  -- (ty :: kind)                         (LHsKind pass)  -- A type with a kind signature       -- ^       -- > (ty :: kind)-      ---      -- - '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-   | HsSpliceTy          (XSpliceTy pass)                         (HsUntypedSplice pass)   -- Includes quasi-quotes-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@,-      --         'GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsDocTy             (XDocTy pass)                         (LHsType pass) (LHsDoc pass) -- A documented type-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation--  | HsBangTy    (XBangTy pass)-                HsSrcBang (LHsType pass)   -- Bang-style type annotations-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-      --         'GHC.Parser.Annotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,-      --         'GHC.Parser.Annotation.AnnClose' @'#-}'@-      --         'GHC.Parser.Annotation.AnnBang' @\'!\'@--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation--  | HsRecTy     (XRecTy pass)-                [LConDeclField pass]    -- Only in data type declarations-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,-      --         'GHC.Parser.Annotation.AnnClose' @'}'@--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsExplicitListTy       -- A promoted explicit list         (XExplicitListTy pass)         PromotionFlag      -- whether explicitly promoted, for pretty printer         [LHsType pass]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'["@,-      --         'GHC.Parser.Annotation.AnnClose' @']'@ -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsExplicitTupleTy      -- A promoted explicit tuple         (XExplicitTupleTy pass)+        PromotionFlag      -- whether explicitly promoted, for pretty printer         [LHsType pass]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'("@,-      --         'GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsTyLit (XTyLit pass) (HsTyLit pass)      -- A promoted numeric literal.-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   | HsWildCardTy (XWildCardTy pass)  -- A type wildcard       -- See Note [The wildcard story for types]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-   -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension   | XHsType       !(XXType pass)@@ -902,33 +914,31 @@   | HsCharTy (XCharTy pass) Char   | XTyLit   !(XXTyLit pass) --- | Denotes the type of arrows in the surface language-data HsArrow pass-  = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass)-    -- ^ a -> b or a → b+type HsMultAnn pass = HsMultAnnOf (LHsType (NoGhcTc pass)) pass -  | HsLinearArrow !(HsLinearArrowTokens pass)-    -- ^ a %1 -> b or a %1 → 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 } -  | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass)-    -- ^ a %m -> b or a %m → b (very much including `a %Many -> 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 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. -data HsLinearArrowTokens pass-  = HsPct1 !(LHsToken "%1" pass) !(LHsUniToken "->" "→" pass)-  | HsLolly !(LHsToken "⊸" pass)---- | 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]@@ -970,7 +980,7 @@ wrote '*' or 'Type', and lose the parse/ppr roundtrip property.  As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type')-and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type).+and then desugar it to 'Data.Kind.Type' in the typechecker (see tcHsType). When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not involved. @@ -1025,24 +1035,16 @@                  | HsBoxedOrConstraintTuple                  deriving Data --- | Located Constructor Declaration Field-type LConDeclField pass = XRec pass (ConDeclField pass)-      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when-      --   in a list--      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation---- | 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)}-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'+-- | Located Constructor Declaration Record Field+type LHsConDeclRecField pass = XRec pass (HsConDeclRecField pass) -      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | 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:@@ -1060,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` -}  -----------------------@@ -1112,36 +1135,62 @@  {- Note [hsScopedTvs and visible foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--XScopedTypeVariables can be defined in terms of a desugaring to--XTypeAbstractions (GHC Proposal #50):+ScopedTypeVariables can be defined in terms of a desugaring to TypeAbstractions+(GHC Proposals #155 and #448):      fn :: forall a b c. tau(a,b,c)            fn :: forall a b c. tau(a,b,c)     fn = defn(a,b,c)                   ==>    fn @x @y @z = defn(x,y,z) -That is, for every type variable of the leading 'forall' in the type signature,-we add an invisible binder at term level.+That is, for every type variable of the leading `forall` in the type signature,+we add an invisible binder at the term level. -This model does not extend to visible forall, as discussed here:+This model does not extend to visible forall. (Visible forall is the one written+with an arrow instead of a dot, i.e. `forall a ->`. See GHC Proposal #281 and+the RequiredTypeArguments extension).  Here is an example that demonstrates the+issue: -* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412-* https://github.com/ghc-proposals/ghc-proposals/pull/238+  vfn :: forall a b -> tau(a, b)+  vfn = case <scrutinee> of (p,q) -> \x y -> ... -The conclusion of these discussions can be summarized as follows:+The `a` and `b` cannot scope over the equations of `vfn`.  In particular,+`a` and `b` cannot be in scope in <scrutinee> because those type variables+are bound by the `\x y ->`. -  > Assuming support for visible 'forall' in terms, consider this example:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn = \a b -> ...-  >-  > The user has written their own binders 'a' and 'b' to stand for 'x' and-  > 'y', and we definitely should not desugar this into:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn x y = \a b -> ...         -- bad!+Our solution is simple: ScopedTypeVariables has no effect on visible forall.+It follows naturally from the fact that ScopedTypeVariables is already subject+to several restrictions: -This design choice is reflected in the design of HsOuterSigTyVarBndrs, which are-used in every place that ScopedTypeVariables takes effect:+  1. The type signature must be headed by an /explicit/ forall+      * `f :: forall a. a -> blah` brings `a` into scope in the body+      * `f ::           a -> blah` does not +  2. The forall is /not nested/+      * `f :: forall a b. blah`         brings `a` and `b` into scope in the body+      * `f :: forall a. forall b. blah` brings `a` but not `b` into scope in the body++With the introduction of visible forall, we also introduce a third condition:++  3. The forall has to be /invisible/+      * `f :: forall a b.   blah` brings `a` and `b` into scope in the body+      * `f :: forall a b -> blah` does not++For example:++   f1 :: forall a. a -> a+   f1 x = (x::a)          -- OK: `a` is in scope in the body++   f2 :: forall a b. a -> b -> (a, b)+   f2 x y = (x::a, y::b)  -- OK: both `a` and `b` are in scope in the body++   f3 :: forall a. forall b. a -> b -> (a, b)+   f3 x y = (x::a, y::b)  -- Wrong: the `forall b.` is not the outermost forall++   f4 :: forall a -> a -> a+   f4 t (x::t) = (x::a)   -- Wrong: the `forall a ->` does not bring `a` into scope++This design choice is reflected in the definition of HsOuterSigTyVarBndrs, which are+used in every place where ScopedTypeVariables takes effect:+   data HsOuterTyVarBndrs flag pass     = HsOuterImplicit { ... }     | HsOuterExplicit { ..., hso_bndrs :: [LHsTyVarBndr flag pass] }@@ -1155,21 +1204,6 @@ (in hsScopedTvs), we /only/ bring the type variables bound by the hso_bndrs in an HsOuterExplicit into scope. If we have an HsOuterImplicit instead, then we do not bring any type variables into scope over the body of a function at all.--At the moment, GHC does not support visible 'forall' in terms. Nevertheless,-it is still possible to write erroneous programs that use visible 'forall's in-terms, such as this example:--    x :: forall a -> a -> a-    x = x--Previous versions of GHC would bring `a` into scope over the body of `x` in the-hopes that the typechecker would error out later-(see `GHC.Tc.Validity.vdqAllowed`). However, this can wreak havoc in the-renamer before GHC gets to that point (see #17687 for an example of this).-Bottom line: nip problems in the bud by refraining from bringing any type-variables in an HsOuterImplicit into scope over the body of a function, even-if they correspond to a visible 'forall'. -}  {-@@ -1181,14 +1215,19 @@ -}  -- | Arguments in an expression/type after splitting-data HsArg tm ty-  = HsValArg tm   -- Argument is an ordinary expression     (f arg)-  | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty)-                         -- SrcSpan is location of the `@`-  | HsArgPar SrcSpan -- See Note [HsArgPar]+data HsArg p tm ty+  = HsValArg !(XValArg p) tm   -- Argument is an ordinary expression     (f arg)+  | HsTypeArg !(XTypeArg p) ty -- Argument is a visible type application (f @ty)+  | HsArgPar !(XArgPar p)      -- See Note [HsArgPar]+  | XArg !(XXArg p) +type family XValArg  p+type family XTypeArg p+type family XArgPar  p+type family XXArg    p+ -- type level equivalent-type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)+type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p)  {- Note [HsArgPar]@@ -1220,44 +1259,46 @@ -- | 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+-- [Ambiguous FieldOcc in record updates] to see how we currently+-- handle this. data FieldOcc pass   = FieldOcc {         foExt :: XCFieldOcc pass-      , foLabel :: XRec pass RdrName -- See Note [Located RdrNames] in Language.Haskell.Syntax.Expr+      , foLabel :: LIdP pass       }   | XFieldOcc !(XXFieldOcc pass) deriving instance (-    Eq (XRec pass RdrName)+    Eq (LIdP pass)   , Eq (XCFieldOcc pass)   , Eq (XXFieldOcc pass)   ) => Eq (FieldOcc pass) --- | Located Ambiguous Field Occurence-type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc 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. --- | Ambiguous Field Occurrence------ Represents an *occurrence* of a field that is potentially--- ambiguous after the renamer, with the ambiguity resolved by the--- typechecker.  We always store the 'RdrName' that the user--- originally wrote, and store the selector function after the renamer--- (for unambiguous occurrences) or the typechecker (for ambiguous--- occurrences).------ See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat".--- See Note [Located RdrNames] in "GHC.Hs.Expr".-data AmbiguousFieldOcc pass-  = Unambiguous (XUnambiguous pass) (XRec pass RdrName)-  | Ambiguous   (XAmbiguous pass)   (XRec pass RdrName)-  | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass)+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
@@ -2,7 +2,10 @@  import Data.Bool import Data.Eq+import Data.Ord +import Control.DeepSeq+ {- ************************************************************************ *                                                                      *@@ -17,5 +20,7 @@   | IsPromoted  instance Eq PromotionFlag+instance Ord PromotionFlag+instance NFData PromotionFlag  isPromoted :: PromotionFlag -> Bool
compiler/MachRegs.h view
@@ -51,631 +51,54 @@ #elif MACHREGS_NO_REGS == 0  /* -----------------------------------------------------------------------------   Caller saves and callee-saves regs.-+   Note [Caller saves and callee-saves regs.]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~    Caller-saves regs have to be saved around C-calls made from STG    land, so this file defines CALLER_SAVES_<reg> for each <reg> that    is designated caller-saves in that machine's C calling convention.+   NB: Caller-saved registers not mapped to a STG register don't+       require a CALLER_SAVES_ define.     As it stands, the only registers that are ever marked caller saves-   are the RX, FX, DX and USER registers; as a result, if you+   are the RX, FX, DX, XMM and USER registers; as a result, if you    decide to caller save a system register (e.g. SP, HP, etc), note that    this code path is completely untested! -- EZY     See Note [Register parameter passing] for details.    -------------------------------------------------------------------------- */ -/* ------------------------------------------------------------------------------   The x86 register mapping--   Ok, we've only got 6 general purpose registers, a frame pointer and a-   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,-   hence they get trashed across ccalls and are caller saves. \tr{%ebx},-   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.--   Reg     STG-Reg-   ----------------   ebx     Base-   ebp     Sp-   esi     R1-   edi     Hp--   Leaving SpLim out of the picture.-   -------------------------------------------------------------------------- */--#if defined(MACHREGS_i386)--#define REG(x) __asm__("%" #x)--#if !defined(not_doing_dynamic_linking)-#define REG_Base    ebx-#endif-#define REG_Sp      ebp--#if !defined(STOLEN_X86_REGS)-#define STOLEN_X86_REGS 4-#endif--#if STOLEN_X86_REGS >= 3-# define REG_R1     esi-#endif--#if STOLEN_X86_REGS >= 4-# define REG_Hp     edi-#endif-#define REG_MachSp  esp--#define REG_XMM1    xmm0-#define REG_XMM2    xmm1-#define REG_XMM3    xmm2-#define REG_XMM4    xmm3--#define REG_YMM1    ymm0-#define REG_YMM2    ymm1-#define REG_YMM3    ymm2-#define REG_YMM4    ymm3--#define REG_ZMM1    zmm0-#define REG_ZMM2    zmm1-#define REG_ZMM3    zmm2-#define REG_ZMM4    zmm3--#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */-#define MAX_REAL_FLOAT_REG   0-#define MAX_REAL_DOUBLE_REG  0-#define MAX_REAL_LONG_REG    0-#define MAX_REAL_XMM_REG     4-#define MAX_REAL_YMM_REG     4-#define MAX_REAL_ZMM_REG     4--/* ------------------------------------------------------------------------------  The x86-64 register mapping--  %rax          caller-saves, don't steal this one-  %rbx          YES-  %rcx          arg reg, caller-saves-  %rdx          arg reg, caller-saves-  %rsi          arg reg, caller-saves-  %rdi          arg reg, caller-saves-  %rbp          YES (our *prime* register)-  %rsp          (unavailable - stack pointer)-  %r8           arg reg, caller-saves-  %r9           arg reg, caller-saves-  %r10          caller-saves-  %r11          caller-saves-  %r12          YES-  %r13          YES-  %r14          YES-  %r15          YES--  %xmm0-7       arg regs, caller-saves-  %xmm8-15      caller-saves--  Use the caller-saves regs for Rn, because we don't always have to-  save those (as opposed to Sp/Hp/SpLim etc. which always have to be-  saved).--  --------------------------------------------------------------------------- */--#elif defined(MACHREGS_x86_64)--#define REG(x) __asm__("%" #x)--#define REG_Base  r13-#define REG_Sp    rbp-#define REG_Hp    r12-#define REG_R1    rbx-#define REG_R2    r14-#define REG_R3    rsi-#define REG_R4    rdi-#define REG_R5    r8-#define REG_R6    r9-#define REG_SpLim r15-#define REG_MachSp  rsp--/*-Map both Fn and Dn to register xmmn so that we can pass a function any-combination of up to six Float# or Double# arguments without touching-the stack. See Note [Overlapping global registers] for implications.-*/--#define REG_F1    xmm1-#define REG_F2    xmm2-#define REG_F3    xmm3-#define REG_F4    xmm4-#define REG_F5    xmm5-#define REG_F6    xmm6--#define REG_D1    xmm1-#define REG_D2    xmm2-#define REG_D3    xmm3-#define REG_D4    xmm4-#define REG_D5    xmm5-#define REG_D6    xmm6--#define REG_XMM1    xmm1-#define REG_XMM2    xmm2-#define REG_XMM3    xmm3-#define REG_XMM4    xmm4-#define REG_XMM5    xmm5-#define REG_XMM6    xmm6--#define REG_YMM1    ymm1-#define REG_YMM2    ymm2-#define REG_YMM3    ymm3-#define REG_YMM4    ymm4-#define REG_YMM5    ymm5-#define REG_YMM6    ymm6--#define REG_ZMM1    zmm1-#define REG_ZMM2    zmm2-#define REG_ZMM3    zmm3-#define REG_ZMM4    zmm4-#define REG_ZMM5    zmm5-#define REG_ZMM6    zmm6--#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_R3-#define CALLER_SAVES_R4-#endif-#define CALLER_SAVES_R5-#define CALLER_SAVES_R6--#define CALLER_SAVES_F1-#define CALLER_SAVES_F2-#define CALLER_SAVES_F3-#define CALLER_SAVES_F4-#define CALLER_SAVES_F5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_F6-#endif--#define CALLER_SAVES_D1-#define CALLER_SAVES_D2-#define CALLER_SAVES_D3-#define CALLER_SAVES_D4-#define CALLER_SAVES_D5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_D6-#endif--#define CALLER_SAVES_XMM1-#define CALLER_SAVES_XMM2-#define CALLER_SAVES_XMM3-#define CALLER_SAVES_XMM4-#define CALLER_SAVES_XMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_XMM6-#endif--#define CALLER_SAVES_YMM1-#define CALLER_SAVES_YMM2-#define CALLER_SAVES_YMM3-#define CALLER_SAVES_YMM4-#define CALLER_SAVES_YMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_YMM6-#endif--#define CALLER_SAVES_ZMM1-#define CALLER_SAVES_ZMM2-#define CALLER_SAVES_ZMM3-#define CALLER_SAVES_ZMM4-#define CALLER_SAVES_ZMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_ZMM6-#endif--#define MAX_REAL_VANILLA_REG 6-#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6-#define MAX_REAL_LONG_REG    0-#define MAX_REAL_XMM_REG     6-#define MAX_REAL_YMM_REG     6-#define MAX_REAL_ZMM_REG     6--/* ------------------------------------------------------------------------------   The PowerPC register mapping--   0            system glue?    (caller-save, volatile)-   1            SP              (callee-save, non-volatile)-   2            AIX, powerpc64-linux:-                    RTOC        (a strange special case)-                powerpc32-linux:-                                reserved for use by system--   3-10         args/return     (caller-save, volatile)-   11,12        system glue?    (caller-save, volatile)-   13           on 64-bit:      reserved for thread state pointer-                on 32-bit:      (callee-save, non-volatile)-   14-31                        (callee-save, non-volatile)--   f0                           (caller-save, volatile)-   f1-f13       args/return     (caller-save, volatile)-   f14-f31                      (callee-save, non-volatile)--   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.-   \tr{0}--\tr{12} are caller-save registers.--   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.+/* Define STG <-> machine register mappings. */+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) -   We can do the Whole Business with callee-save registers only!-   -------------------------------------------------------------------------- */+#include "MachRegs/x86.h"  #elif defined(MACHREGS_powerpc) -#define REG(x) __asm__(#x)--#define REG_R1          r14-#define REG_R2          r15-#define REG_R3          r16-#define REG_R4          r17-#define REG_R5          r18-#define REG_R6          r19-#define REG_R7          r20-#define REG_R8          r21-#define REG_R9          r22-#define REG_R10         r23--#define REG_F1          fr14-#define REG_F2          fr15-#define REG_F3          fr16-#define REG_F4          fr17-#define REG_F5          fr18-#define REG_F6          fr19--#define REG_D1          fr20-#define REG_D2          fr21-#define REG_D3          fr22-#define REG_D4          fr23-#define REG_D5          fr24-#define REG_D6          fr25--#define REG_Sp          r24-#define REG_SpLim       r25-#define REG_Hp          r26-#define REG_Base        r27--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6--/* ------------------------------------------------------------------------------   The ARM EABI register mapping--   Here we consider ARM mode (i.e. 32bit isns)-   and also CPU with full VFPv3 implementation--   ARM registers (see Chapter 5.1 in ARM IHI 0042D and-   Section 9.2.2 in ARM Software Development Toolkit Reference Guide)--   r15  PC         The Program Counter.-   r14  LR         The Link Register.-   r13  SP         The Stack Pointer.-   r12  IP         The Intra-Procedure-call scratch register.-   r11  v8/fp      Variable-register 8.-   r10  v7/sl      Variable-register 7.-   r9   v6/SB/TR   Platform register. The meaning of this register is-                   defined by the platform standard.-   r8   v5         Variable-register 5.-   r7   v4         Variable register 4.-   r6   v3         Variable register 3.-   r5   v2         Variable register 2.-   r4   v1         Variable register 1.-   r3   a4         Argument / scratch register 4.-   r2   a3         Argument / scratch register 3.-   r1   a2         Argument / result / scratch register 2.-   r0   a1         Argument / result / scratch register 1.--   VFPv2/VFPv3/NEON registers-   s0-s15/d0-d7/q0-q3    Argument / result/ scratch registers-   s16-s31/d8-d15/q4-q7  callee-saved registers (must be preserved across-                         subroutine calls)--   VFPv3/NEON registers (added to the VFPv2 registers set)-   d16-d31/q8-q15        Argument / result/ scratch registers-   ----------------------------------------------------------------------------- */+#include "MachRegs/ppc.h"  #elif defined(MACHREGS_arm) -#define REG(x) __asm__(#x)--#define REG_Base        r4-#define REG_Sp          r5-#define REG_Hp          r6-#define REG_R1          r7-#define REG_R2          r8-#define REG_R3          r9-#define REG_R4          r10-#define REG_SpLim       r11--#if !defined(arm_HOST_ARCH_PRE_ARMv6)-/* d8 */-#define REG_F1    s16-#define REG_F2    s17-/* d9 */-#define REG_F3    s18-#define REG_F4    s19--#define REG_D1    d10-#define REG_D2    d11-#endif--/* ------------------------------------------------------------------------------   The ARMv8/AArch64 ABI register mapping--   The AArch64 provides 31 64-bit general purpose registers-   and 32 128-bit SIMD/floating point registers.--   General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B)--   Register | Special | Role in the procedure call standard-   ---------+---------+-------------------------------------     SP     |         | The Stack Pointer-     r30    |  LR     | The Link Register-     r29    |  FP     | The Frame Pointer-   r19-r28  |         | Callee-saved registers-     r18    |         | The Platform Register, if needed;-            |         | or temporary register-     r17    |  IP1    | The second intra-procedure-call temporary register-     r16    |  IP0    | The first intra-procedure-call scratch register-    r9-r15  |         | Temporary registers-     r8     |         | Indirect result location register-    r0-r7   |         | Parameter/result registers---   FPU/SIMD registers--   s/d/q/v0-v7    Argument / result/ scratch registers-   s/d/q/v8-v15   callee-saved registers (must be preserved across subroutine calls,-                  but only bottom 64-bit value needs to be preserved)-   s/d/q/v16-v31  temporary registers--   ----------------------------------------------------------------------------- */+#include "MachRegs/arm32.h"  #elif defined(MACHREGS_aarch64) -#define REG(x) __asm__(#x)--#define REG_Base        r19-#define REG_Sp          r20-#define REG_Hp          r21-#define REG_R1          r22-#define REG_R2          r23-#define REG_R3          r24-#define REG_R4          r25-#define REG_R5          r26-#define REG_R6          r27-#define REG_SpLim       r28--#define REG_F1          s8-#define REG_F2          s9-#define REG_F3          s10-#define REG_F4          s11--#define REG_D1          d12-#define REG_D2          d13-#define REG_D3          d14-#define REG_D4          d15--/* ------------------------------------------------------------------------------   The s390x register mapping--   Register    | Role(s)                                 | Call effect-   ------------+-------------------------------------+------------------   r0,r1       | -                                       | caller-saved-   r2          | Argument / return value                 | caller-saved-   r3,r4,r5    | Arguments                               | caller-saved-   r6          | Argument                                | callee-saved-   r7...r11    | -                                       | callee-saved-   r12         | (Commonly used as GOT pointer)          | callee-saved-   r13         | (Commonly used as literal pool pointer) | callee-saved-   r14         | Return address                          | caller-saved-   r15         | Stack pointer                           | callee-saved-   f0          | Argument / return value                 | caller-saved-   f2,f4,f6    | Arguments                               | caller-saved-   f1,f3,f5,f7 | -                                       | caller-saved-   f8...f15    | -                                       | callee-saved-   v0...v31    | -                                       | caller-saved--   Each general purpose register r0 through r15 as well as each floating-point-   register f0 through f15 is 64 bits wide. Each vector register v0 through v31-   is 128 bits wide.--   Note, the vector registers v0 through v15 overlap with the floating-point-   registers f0 through f15.--   -------------------------------------------------------------------------- */+#include "MachRegs/arm64.h"  #elif defined(MACHREGS_s390x) -#define REG(x) __asm__("%" #x)--#define REG_Base        r7-#define REG_Sp          r8-#define REG_Hp          r10-#define REG_R1          r11-#define REG_R2          r12-#define REG_R3          r13-#define REG_R4          r6-#define REG_R5          r2-#define REG_R6          r3-#define REG_R7          r4-#define REG_R8          r5-#define REG_SpLim       r9-#define REG_MachSp      r15--#define REG_F1          f8-#define REG_F2          f9-#define REG_F3          f10-#define REG_F4          f11-#define REG_F5          f0-#define REG_F6          f1--#define REG_D1          f12-#define REG_D2          f13-#define REG_D3          f14-#define REG_D4          f15-#define REG_D5          f2-#define REG_D6          f3--#define CALLER_SAVES_R5-#define CALLER_SAVES_R6-#define CALLER_SAVES_R7-#define CALLER_SAVES_R8--#define CALLER_SAVES_F5-#define CALLER_SAVES_F6--#define CALLER_SAVES_D5-#define CALLER_SAVES_D6--/* ------------------------------------------------------------------------------   The riscv64 register mapping--   Register    | Role(s)                                 | Call effect-   ------------+-----------------------------------------+--------------   zero        | Hard-wired zero                         | --   ra          | Return address                          | caller-saved-   sp          | Stack pointer                           | callee-saved-   gp          | Global pointer                          | callee-saved-   tp          | Thread pointer                          | callee-saved-   t0,t1,t2    | -                                       | caller-saved-   s0          | Frame pointer                           | callee-saved-   s1          | -                                       | callee-saved-   a0,a1       | Arguments / return values               | caller-saved-   a2..a7      | Arguments                               | caller-saved-   s2..s11     | -                                       | callee-saved-   t3..t6      | -                                       | caller-saved-   ft0..ft7    | -                                       | caller-saved-   fs0,fs1     | -                                       | callee-saved-   fa0,fa1     | Arguments / return values               | caller-saved-   fa2..fa7    | Arguments                               | caller-saved-   fs2..fs11   | -                                       | callee-saved-   ft8..ft11   | -                                       | caller-saved--   Each general purpose register as well as each floating-point-   register is 64 bits wide.--   -------------------------------------------------------------------------- */+#include "MachRegs/s390x.h"  #elif defined(MACHREGS_riscv64) -#define REG(x) __asm__(#x)--#define REG_Base        s1-#define REG_Sp          s2-#define REG_Hp          s3-#define REG_R1          s4-#define REG_R2          s5-#define REG_R3          s6-#define REG_R4          s7-#define REG_R5          s8-#define REG_R6          s9-#define REG_R7          s10-#define REG_SpLim       s11--#define REG_F1          fs0-#define REG_F2          fs1-#define REG_F3          fs2-#define REG_F4          fs3-#define REG_F5          fs4-#define REG_F6          fs5--#define REG_D1          fs6-#define REG_D2          fs7-#define REG_D3          fs8-#define REG_D4          fs9-#define REG_D5          fs10-#define REG_D6          fs11--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6+#include "MachRegs/riscv64.h"  #elif defined(MACHREGS_wasm32) -#define REG_R1             1-#define REG_R2             2-#define REG_R3             3-#define REG_R4             4-#define REG_R5             5-#define REG_R6             6-#define REG_R7             7-#define REG_R8             8-#define REG_R9             9-#define REG_R10            10--#define REG_F1             11-#define REG_F2             12-#define REG_F3             13-#define REG_F4             14-#define REG_F5             15-#define REG_F6             16--#define REG_D1             17-#define REG_D2             18-#define REG_D3             19-#define REG_D4             20-#define REG_D5             21-#define REG_D6             22--#define REG_L1             23--#define REG_Sp             24-#define REG_SpLim          25-#define REG_Hp             26-#define REG_HpLim          27-#define REG_CCCS           28--/* ------------------------------------------------------------------------------   The loongarch64 register mapping--   Register    | Role(s)                                 | Call effect-   ------------+-----------------------------------------+--------------   zero        | Hard-wired zero                         | --   ra          | Return address                          | caller-saved-   tp          | Thread pointer                          | --   sp          | Stack pointer                           | callee-saved-   a0,a1       | Arguments / return values               | caller-saved-   a2..a7      | Arguments                               | caller-saved-   t0..t8      | -                                       | caller-saved-   u0          | Reserve                                 | --   fp          | Frame pointer                           | callee-saved-   s0..s8      | -                                       | callee-saved-   fa0,fa1     | Arguments / return values               | caller-saved-   fa2..fa7    | Arguments                               | caller-saved-   ft0..ft15   | -                                       | caller-saved-   fs0..fs7    | -                                       | callee-saved--   Each general purpose register as well as each floating-point-   register is 64 bits wide, also, the u0 register is called r21 in some cases.+#include "MachRegs/wasm32.h" -   -------------------------------------------------------------------------- */ #elif defined(MACHREGS_loongarch64) -#define REG(x) __asm__("$" #x)--#define REG_Base        s0-#define REG_Sp          s1-#define REG_Hp          s2-#define REG_R1          s3-#define REG_R2          s4-#define REG_R3          s5-#define REG_R4          s6-#define REG_R5          s7-#define REG_SpLim       s8--#define REG_F1          fs0-#define REG_F2          fs1-#define REG_F3          fs2-#define REG_F4          fs3--#define REG_D1          fs4-#define REG_D2          fs5-#define REG_D3          fs6-#define REG_D4          fs7--#define MAX_REAL_FLOAT_REG   4-#define MAX_REAL_DOUBLE_REG  4+#include "MachRegs/loongarch64.h"  #else @@ -799,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
@@ -9,6 +9,7 @@ // // The CPP is thus about the RTS version GHC is linked against, and not the // version of the GHC being built.+ #if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) // Unique64 patch was present in 9.10 and later #define HAVE_UNIQUE64 1@@ -20,34 +21,6 @@ #define HAVE_UNIQUE64 1 #endif - #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--// This function has been added to the RTS. Here we pessimistically assume-// that a threaded RTS is used. This function is only used for bootstrapping.-#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)-STATIC_INLINE StgWord64-atomic_inc64(StgWord64 volatile* p, StgWord64 incr)-{-#if defined(HAVE_C11_ATOMICS)-    return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST);-#else-    return __sync_add_and_fetch(p, incr);-#endif-}-#endif--#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS)-#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)--HsWord64 ghc_lib_parser_genSym(void) {-    HsWord64 u = atomic_inc64((StgWord64 *)&ghc_unique_counter64, ghc_unique_inc) & UNIQUE_MASK;-    // Uh oh! We will overflow next time a unique is requested.-    ASSERT(u != UNIQUE_MASK);-    return u;-}
− compiler/ghc-llvm-version.h 
@@ -1,11 +0,0 @@-/* compiler/ghc-llvm-version.h.  Generated from ghc-llvm-version.h.in by configure.  */-#if !defined(__GHC_LLVM_VERSION_H__)-#define __GHC_LLVM_VERSION_H__--/* The maximum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MAX (16)--/* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (11)--#endif /* __GHC_LLVM_VERSION_H__ */
compiler/ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.6.7+Version: 9.14.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -20,12 +20,16 @@     .     See <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler>     for more information.+    .+    __This package is not PVP-compliant.__+    .+    This package directly exposes GHC internals, which can and do change with+    every release. Category: Development Build-Type: Custom  extra-source-files:     GHC/Builtin/primops.txt.pp-    GHC/Builtin/bytearray-ops.txt.pp     Unique.h     CodeGen.Platform.h     -- Shared with rts via hard-link at configure time. This is safer@@ -35,11 +39,18 @@     ClosureTypes.h     FunTypes.h     MachRegs.h-    ghc-llvm-version.h+    MachRegs/arm32.h+    MachRegs/arm64.h+    MachRegs/loongarch64.h+    MachRegs/ppc.h+    MachRegs/riscv64.h+    MachRegs/s390x.h+    MachRegs/wasm32.h+    MachRegs/x86.h   custom-setup-    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath+    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers  Flag internal-interpreter     Description: Build with internal interpreter support.@@ -57,8 +68,31 @@     Description: Use build-tool-depends     Default: True +Flag with-libzstd+    Default: False+    Manual: True++Flag static-libzstd+    Default: False+    Manual: True++-- While the boot compiler fixes ghc's unit-id to `ghc`, the stage0 compiler must still be compiled with `-this-unit-id ghc`+Flag hadrian-stage0+    Description: Enable if compiling the stage0 compiler with hadrian+    Default: False+    Manual: True++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-internal`.+          See Note [Bootstrapping Template Haskell]+        Default: False+        Manual: True+ Library-    Default-Language: Haskell2010+    Default-Language: GHC2021     Exposed: False     Includes: Unique.h               -- CodeGen.Platform.h -- invalid as C, skip@@ -66,32 +100,51 @@               Bytecodes.h               ClosureTypes.h               FunTypes.h-              ghc-llvm-version.h      if flag(build-tool-depends)       build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants -    Build-Depends: base       >= 4.11 && < 4.19,-                   deepseq    >= 1.4 && < 1.5,+    if flag(with-libzstd)+      if flag(static-libzstd)+        if os(darwin)+          buildable: False+        else+          extra-libraries: :libzstd.a+      else+        extra-libraries: zstd+      CPP-Options: -DHAVE_LIBZSTD++    Build-Depends: base       >= 4.11 && < 4.23,+                   deepseq    >= 1.4 && < 1.6,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,-                   bytestring >= 0.9 && < 0.12,+                   bytestring >= 0.11 && < 0.13,                    binary     == 0.8.*,-                   time       >= 1.4 && < 1.13,-                   containers >= 0.6.2.1 && < 0.7,+                   time       >= 1.4 && < 1.16,+                   containers >= 0.6.2.1 && < 0.9,                    array      >= 0.1 && < 0.6,-                   filepath   >= 1   && < 1.5,-                   template-haskell == 2.20.*,-                   hpc        == 0.6.*,+                   filepath   >= 1.5 && < 1.6,+                   os-string  >= 2.0.1 && < 2.1,+                   hpc        >= 0.6 && < 0.8,                    transformers >= 0.5 && < 0.7,                    exceptions == 0.10.*,+                   semaphore-compat,                    stm,-                   ghc-boot   == 9.6.7,-                   ghc-heap   == 9.6.7,-                   ghci == 9.6.7+                   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.14.1+    else+      Build-Depends:+        ghc-boot-th          == 9.14.1,+        ghc-internal         == 9.1401.0,+     if os(windows)-        Build-Depends: Win32  >= 2.3 && < 2.14+        Build-Depends: Win32  >= 2.3 && < 2.15     else         Build-Depends: unix   >= 2.7 && < 2.9 @@ -136,9 +189,10 @@      Include-Dirs: . -    -- We need to set the unit id to ghc (without a version number)-    -- as it's magic.-    GHC-Options: -this-unit-id ghc+    if flag(hadrian-stage0)+        -- We need to set the unit id to ghc (without a version number)+        -- as it's magic.+        GHC-Options: -this-unit-id ghc      if arch(javascript)       js-sources:@@ -155,10 +209,7 @@     -- we use an explicit Prelude     Default-Extensions:         NoImplicitPrelude-       ,BangPatterns-       ,ScopedTypeVariables        ,MonoLocalBinds-       ,TypeOperators      Exposed-Modules:         GHC@@ -173,6 +224,7 @@         GHC.Builtin.Uniques         GHC.Builtin.Utils         GHC.ByteCode.Asm+        GHC.ByteCode.Breakpoints         GHC.ByteCode.InfoTable         GHC.ByteCode.Instr         GHC.ByteCode.Linker@@ -186,11 +238,11 @@         GHC.Cmm.ContFlowOpt         GHC.Cmm.Dataflow         GHC.Cmm.Dataflow.Block-        GHC.Cmm.Dataflow.Collections         GHC.Cmm.Dataflow.Graph         GHC.Cmm.Dataflow.Label         GHC.Cmm.DebugBlock         GHC.Cmm.Expr+        GHC.Cmm.GenericOpt         GHC.Cmm.Graph         GHC.Cmm.Info         GHC.Cmm.Info.Build@@ -212,6 +264,7 @@         GHC.Cmm.Switch         GHC.Cmm.Switch.Implement         GHC.Cmm.ThreadSanitizer+        GHC.Cmm.UniqueRenamer         GHC.CmmToAsm         GHC.Cmm.LRegSet         GHC.CmmToAsm.AArch64@@ -232,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@@ -256,7 +316,9 @@         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         GHC.CmmToAsm.Reg.Linear.State         GHC.CmmToAsm.Reg.Linear.Stats@@ -265,6 +327,13 @@         GHC.CmmToAsm.Reg.Liveness         GHC.CmmToAsm.Reg.Target         GHC.CmmToAsm.Reg.Utils+        GHC.CmmToAsm.RV64+        GHC.CmmToAsm.RV64.CodeGen+        GHC.CmmToAsm.RV64.Cond+        GHC.CmmToAsm.RV64.Instr+        GHC.CmmToAsm.RV64.Ppr+        GHC.CmmToAsm.RV64.RegInfo+        GHC.CmmToAsm.RV64.Regs         GHC.CmmToAsm.Types         GHC.CmmToAsm.Utils         GHC.CmmToAsm.X86@@ -283,6 +352,9 @@         GHC.CmmToLlvm.Mangler         GHC.CmmToLlvm.Ppr         GHC.CmmToLlvm.Regs+        GHC.CmmToLlvm.Version+        GHC.CmmToLlvm.Version.Bounds+        GHC.CmmToLlvm.Version.Type         GHC.Cmm.Dominators         GHC.Cmm.Reducibility         GHC.Cmm.Type@@ -300,6 +372,10 @@         GHC.Core.Lint         GHC.Core.Lint.Interactive         GHC.Core.LateCC+        GHC.Core.LateCC.Types+        GHC.Core.LateCC.TopLevelBinds+        GHC.Core.LateCC.Utils+        GHC.Core.LateCC.OverloadedCalls         GHC.Core.Make         GHC.Core.Map.Expr         GHC.Core.Map.Type@@ -307,6 +383,7 @@         GHC.Core.Opt.Arity         GHC.Core.Opt.CallArity         GHC.Core.Opt.CallerCC+        GHC.Core.Opt.CallerCC.Types         GHC.Core.Opt.ConstantFold         GHC.Core.Opt.CprAnal         GHC.Core.Opt.CSE@@ -322,6 +399,7 @@         GHC.Core.Opt.SetLevels         GHC.Core.Opt.Simplify         GHC.Core.Opt.Simplify.Env+        GHC.Core.Opt.Simplify.Inline         GHC.Core.Opt.Simplify.Iteration         GHC.Core.Opt.Simplify.Monad         GHC.Core.Opt.Simplify.Utils@@ -346,6 +424,7 @@         GHC.CoreToIface         GHC.CoreToStg         GHC.CoreToStg.Prep+        GHC.CoreToStg.AddImplicitBinds         GHC.Core.TyCo.FVs         GHC.Core.TyCo.Compare         GHC.Core.TyCon@@ -372,20 +451,26 @@         GHC.Data.FastString         GHC.Data.FastString.Env         GHC.Data.FiniteMap+        GHC.Data.FlatBag         GHC.Data.Graph.Base         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+        GHC.Data.OsPath         GHC.Data.Pair         GHC.Data.SmallArray         GHC.Data.Stream@@ -436,6 +521,9 @@         GHC.Driver.Config.StgToCmm         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@@ -446,8 +534,11 @@         GHC.Driver.GenerateCgIPEStub         GHC.Driver.Hooks         GHC.Driver.LlvmConfigCache+        GHC.Driver.MakeSem         GHC.Driver.Main         GHC.Driver.Make+        GHC.Driver.Messager+        GHC.Driver.MakeAction         GHC.Driver.MakeFile         GHC.Driver.Monad         GHC.Driver.Phases@@ -460,7 +551,10 @@         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         GHC.Hs.Decls         GHC.Hs.Doc@@ -473,6 +567,7 @@         GHC.Hs.Instances         GHC.Hs.Lit         GHC.Hs.Pat+        GHC.Hs.Specificity         GHC.Hs.Stats         GHC.HsToCore         GHC.HsToCore.Arrows@@ -489,6 +584,7 @@         GHC.HsToCore.Foreign.JavaScript         GHC.HsToCore.Foreign.Prim         GHC.HsToCore.Foreign.Utils+        GHC.HsToCore.Foreign.Wasm         GHC.HsToCore.GuardedRHSs         GHC.HsToCore.ListComp         GHC.HsToCore.Match@@ -511,8 +607,11 @@         GHC.Hs.Type         GHC.Hs.Utils         GHC.Iface.Binary+        GHC.Iface.Decl         GHC.Iface.Env         GHC.Iface.Errors+        GHC.Iface.Errors.Types+        GHC.Iface.Errors.Ppr         GHC.Iface.Ext.Ast         GHC.Iface.Ext.Binary         GHC.Iface.Ext.Debug@@ -524,19 +623,29 @@         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         GHC.IfaceToCore         GHC.Iface.Type+        GHC.JS.Ident         GHC.JS.Make+        GHC.JS.Optimizer+        GHC.JS.Opt.Expr+        GHC.JS.Opt.Simple         GHC.JS.Ppr         GHC.JS.Syntax+        GHC.JS.JStg.Syntax+        GHC.JS.JStg.Monad         GHC.JS.Transform-        GHC.Linker         GHC.Linker.Config+        GHC.Linker.Deps         GHC.Linker.Dynamic+        GHC.Linker.External         GHC.Linker.ExtraObj         GHC.Linker.Loader         GHC.Linker.MacOS@@ -558,23 +667,29 @@         GHC.Parser.Errors.Types         GHC.Parser.Header         GHC.Parser.Lexer+        GHC.Parser.Lexer.Interface+        GHC.Parser.Lexer.String         GHC.Parser.HaddockLex         GHC.Parser.PostProcess         GHC.Parser.PostProcess.Haddock+        GHC.Parser.String         GHC.Parser.Types         GHC.Parser.Utils         GHC.Platform         GHC.Platform.ARM         GHC.Platform.AArch64         GHC.Platform.Constants+        GHC.Platform.LA64         GHC.Platform.NoRegs         GHC.Platform.PPC         GHC.Platform.Profile         GHC.Platform.Reg         GHC.Platform.Reg.Class+        GHC.Platform.Reg.Class.NoVectors+        GHC.Platform.Reg.Class.Separate+        GHC.Platform.Reg.Class.Unified         GHC.Platform.Regs         GHC.Platform.RISCV64-        GHC.Platform.LoongArch64         GHC.Platform.S390X         GHC.Platform.Wasm32         GHC.Platform.Ways@@ -597,13 +712,20 @@         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         GHC.Settings         GHC.Settings.Config         GHC.Settings.Constants@@ -611,16 +733,18 @@         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         GHC.Stg.Lift.Config         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         GHC.Stg.Subst@@ -656,7 +780,6 @@         GHC.StgToJS.Arg         GHC.StgToJS.Closure         GHC.StgToJS.CodeGen-        GHC.StgToJS.CoreUtils         GHC.StgToJS.DataCon         GHC.StgToJS.Deps         GHC.StgToJS.Expr@@ -669,27 +792,27 @@         GHC.StgToJS.Object         GHC.StgToJS.Prim         GHC.StgToJS.Profiling-        GHC.StgToJS.Printer         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.StgUtils         GHC.StgToJS.Symbols         GHC.StgToJS.Types         GHC.StgToJS.Utils         GHC.StgToJS.Linker.Linker         GHC.StgToJS.Linker.Types         GHC.StgToJS.Linker.Utils+        GHC.StgToJS.Linker.Opt         GHC.Stg.Unarise         GHC.SysTools         GHC.SysTools.Ar         GHC.SysTools.BaseDir         GHC.SysTools.Cpp         GHC.SysTools.Elf-        GHC.SysTools.Info         GHC.SysTools.Process         GHC.SysTools.Tasks         GHC.SysTools.Terminal@@ -702,13 +825,16 @@         GHC.Tc.Errors         GHC.Tc.Errors.Hole         GHC.Tc.Errors.Hole.FitTypes+        GHC.Tc.Errors.Hole.Plugin         GHC.Tc.Errors.Ppr         GHC.Tc.Errors.Types+        GHC.Tc.Errors.Types.PromotionErr         GHC.Tc.Gen.Annotation         GHC.Tc.Gen.App         GHC.Tc.Gen.Arrow         GHC.Tc.Gen.Bind         GHC.Tc.Gen.Default+        GHC.Tc.Gen.Do         GHC.Tc.Gen.Export         GHC.Tc.Gen.Expr         GHC.Tc.Gen.Foreign@@ -716,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@@ -726,10 +851,13 @@         GHC.Tc.Module         GHC.Tc.Plugin         GHC.Tc.Solver-        GHC.Tc.Solver.Canonical+        GHC.Tc.Solver.Default         GHC.Tc.Solver.Rewrite         GHC.Tc.Solver.InertSet-        GHC.Tc.Solver.Interact+        GHC.Tc.Solver.Solve+        GHC.Tc.Solver.Irred+        GHC.Tc.Solver.Equality+        GHC.Tc.Solver.Dict         GHC.Tc.Solver.Monad         GHC.Tc.Solver.Types         GHC.Tc.TyCl@@ -741,9 +869,14 @@         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+        GHC.Tc.Types.ErrCtxt+        GHC.Tc.Types.LclEnv+        GHC.Tc.Types.TH+        GHC.Tc.Types.TcRef+        GHC.Tc.Types.BasicTypes         GHC.Tc.Utils.Backpack         GHC.Tc.Utils.Concrete         GHC.Tc.Utils.Env@@ -752,17 +885,20 @@         GHC.Tc.Utils.TcMType         GHC.Tc.Utils.TcType         GHC.Tc.Utils.Unify-        GHC.Tc.Utils.Zonk         GHC.Tc.Validity+        GHC.Tc.Zonk.Env+        GHC.Tc.Zonk.Monad+        GHC.Tc.Zonk.TcType+        GHC.Tc.Zonk.Type         GHC.ThToHs         GHC.Types.Annotations         GHC.Types.Avail         GHC.Types.Basic-        GHC.Types.BreakInfo         GHC.Types.CompleteMatch         GHC.Types.CostCentre         GHC.Types.CostCentre.State         GHC.Types.Cpr+        GHC.Types.DefaultEnv         GHC.Types.Demand         GHC.Types.Error         GHC.Types.Error.Codes@@ -771,11 +907,13 @@         GHC.Types.Fixity.Env         GHC.Types.ForeignCall         GHC.Types.ForeignStubs+        GHC.Types.GREInfo         GHC.Types.Hint         GHC.Types.Hint.Ppr         GHC.Types.HpcInfo         GHC.Types.Id         GHC.Types.IPE+        GHC.Types.ThLevelIndex         GHC.Types.Id.Info         GHC.Types.Id.Make         GHC.Types.Literal@@ -792,9 +930,11 @@         GHC.Types.ProfAuto         GHC.Types.RepType         GHC.Types.SafeHaskell+        GHC.Types.SaneDouble         GHC.Types.SourceError         GHC.Types.SourceFile         GHC.Types.SourceText+        GHC.Types.SptEntry         GHC.Types.SrcLoc         GHC.Types.Target         GHC.Types.Tickish@@ -803,6 +943,7 @@         GHC.Types.Unique         GHC.Types.Unique.DFM         GHC.Types.Unique.DSet+        GHC.Types.Unique.DSM         GHC.Types.Unique.FM         GHC.Types.Unique.Map         GHC.Types.Unique.MemoFun@@ -818,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@@ -856,6 +1001,7 @@         GHC.Utils.Logger         GHC.Utils.Misc         GHC.Utils.Monad+        GHC.Utils.Monad.Codensity         GHC.Utils.Monad.State.Strict         GHC.Utils.Outputable         GHC.Utils.Panic@@ -863,6 +1009,7 @@         GHC.Utils.Ppr         GHC.Utils.Ppr.Colour         GHC.Utils.TmpFs+        GHC.Utils.Touch         GHC.Utils.Trace         GHC.Utils.Unique         GHC.Utils.Word64@@ -877,14 +1024,16 @@         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic         Language.Haskell.Syntax.Binds-        Language.Haskell.Syntax.Concrete+        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+        Language.Haskell.Syntax.Specificity         Language.Haskell.Syntax.Type      autogen-modules: GHC.Platform.Constants
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-parser-version: 9.6.7.20250325+version: 9.14.1.20251220 license: BSD-3-Clause license-file: LICENSE category: Development@@ -24,15 +24,15 @@     libraries/ghc-boot/ghc-boot.cabal     libraries/ghci/ghci.cabal     compiler/ghc.cabal+    libraries/ghc-platform/ghc-platform.cabal     ghc-lib/stage0/rts/build/include/ghcautoconf.h     ghc-lib/stage0/rts/build/include/ghcplatform.h     ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h-    ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl     ghc-lib/stage0/compiler/build/primop-code-size.hs-incl     ghc-lib/stage0/compiler/build/primop-commutable.hs-incl     ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl     ghc-lib/stage0/compiler/build/primop-fixity.hs-incl-    ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl+    ghc-lib/stage0/compiler/build/primop-effects.hs-incl     ghc-lib/stage0/compiler/build/primop-list.hs-incl     ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl     ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl@@ -43,7 +43,12 @@     ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl     ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl     ghc-lib/stage0/compiler/build/primop-docs.hs-incl+    ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl+    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@@ -51,7 +56,15 @@     compiler/GHC/Parser/Lexer.x     compiler/GHC/Parser/HaddockLex.x     compiler/GHC/Parser.hs-boot-    compiler/ghc-llvm-version.h+    rts/include/stg/MachRegs/arm32.h+    rts/include/stg/MachRegs/arm64.h+    rts/include/stg/MachRegs/loongarch64.h+    rts/include/stg/MachRegs/ppc.h+    rts/include/stg/MachRegs/riscv64.h+    rts/include/stg/MachRegs/s390x.h+    rts/include/stg/MachRegs/wasm32.h+    rts/include/stg/MachRegs/x86.h+    libraries/containers/containers/include/containers.h     rts/include/ghcconfig.h     compiler/MachRegs.h     compiler/CodeGen.Platform.h@@ -67,33 +80,37 @@   manual: True   description: Pass -DTHREADED_RTS to the C toolchain library-    default-language: Haskell2010+    default-language: GHC2021     exposed: False     include-dirs:         rts/include+        rts/include/stg         ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler+        libraries/containers/containers/include     if impl(ghc >= 8.8.1)         ghc-options: -fno-safe-haskell     if flag(threaded-rts)         ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS-        cpp-options: -DTHREADED_RTS+        cpp-options: -DTHREADED_RTS   -DBOOTSTRAP_TH     else         ghc-options: -fobject-code -package=ghc-boot-th-        cpp-options:+        cpp-options:   -DBOOTSTRAP_TH     if !os(windows)         build-depends: unix     else         build-depends: Win32     build-depends:-        base >= 4.16.1 && < 4.19,-        ghc-prim > 0.2 && < 0.11,-        containers >= 0.6.2.1 && < 0.7,-        bytestring >= 0.11.3 && < 0.12,-        time >= 1.4 && < 1.13,-        filepath >= 1 && < 1.5,+        base >= 4.20 && < 4.23,+        ghc-prim > 0.2 && < 0.14,+        containers >= 0.6.2.1 && < 0.9,+        bytestring >= 0.11.4 && < 0.13,+        time >= 1.4 && < 1.16,+        filepath >= 1.5 && < 1.6,+        hpc >= 0.6 && < 0.8,+        os-string >= 2.0.1 && < 2.1,         exceptions == 0.10.*,         parsec,         binary == 0.8.*,@@ -105,7 +122,7 @@         process >= 1 && < 1.7     if impl(ghc >= 9.10)       build-depends: ghc-internal-    build-tool-depends: alex:alex >= 3.1, happy:happy < 1.21+    build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2     other-extensions:         BangPatterns         CPP@@ -140,26 +157,26 @@         UnboxedTuples         UndecidableInstances     default-extensions:-        BangPatterns-        ImplicitPrelude         MonoLocalBinds         NoImplicitPrelude-        ScopedTypeVariables-        TypeOperators     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+        libraries/ghc-platform/src         libraries/template-haskell+        libraries/ghc-platform         libraries/ghc-boot-th         libraries/ghc-boot         libraries/ghc-heap@@ -170,18 +187,25 @@         GHC.Parser     exposed-modules:         GHC.BaseDir+        GHC.Boot.TH.Lib.Map+        GHC.Boot.TH.Ppr+        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         GHC.Cmm.CLabel         GHC.Cmm.Dataflow.Block-        GHC.Cmm.Dataflow.Collections         GHC.Cmm.Dataflow.Graph         GHC.Cmm.Dataflow.Label         GHC.Cmm.Expr@@ -190,8 +214,12 @@         GHC.Cmm.Reg         GHC.Cmm.Switch         GHC.Cmm.Type+        GHC.Cmm.Utils         GHC.CmmToAsm.CFG.Weight         GHC.CmmToLlvm.Config+        GHC.CmmToLlvm.Version+        GHC.CmmToLlvm.Version.Bounds+        GHC.CmmToLlvm.Version.Type         GHC.Core         GHC.Core.Class         GHC.Core.Coercion@@ -210,12 +238,14 @@         GHC.Core.Multiplicity         GHC.Core.Opt.Arity         GHC.Core.Opt.CallerCC+        GHC.Core.Opt.CallerCC.Types         GHC.Core.Opt.ConstantFold         GHC.Core.Opt.Monad         GHC.Core.Opt.OccurAnal         GHC.Core.Opt.Pipeline.Types         GHC.Core.Opt.Simplify         GHC.Core.Opt.Simplify.Env+        GHC.Core.Opt.Simplify.Inline         GHC.Core.Opt.Simplify.Iteration         GHC.Core.Opt.Simplify.Monad         GHC.Core.Opt.Simplify.Utils@@ -256,13 +286,19 @@         GHC.Data.FastString         GHC.Data.FastString.Env         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+        GHC.Data.OsPath         GHC.Data.Pair         GHC.Data.ShortText         GHC.Data.SizedSeq@@ -288,6 +324,7 @@         GHC.Driver.Config.Diagnostic         GHC.Driver.Config.Logger         GHC.Driver.Config.Parser+        GHC.Driver.DynFlags         GHC.Driver.Env         GHC.Driver.Env.KnotVars         GHC.Driver.Env.Types@@ -296,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@@ -323,6 +361,7 @@         GHC.ForeignSrcLang         GHC.ForeignSrcLang.Type         GHC.Hs+        GHC.Hs.Basic         GHC.Hs.Binds         GHC.Hs.Decls         GHC.Hs.Doc@@ -334,20 +373,46 @@         GHC.Hs.Instances         GHC.Hs.Lit         GHC.Hs.Pat+        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+        GHC.JS.Ident+        GHC.JS.JStg.Monad+        GHC.JS.JStg.Syntax+        GHC.JS.Make+        GHC.JS.Ppr+        GHC.JS.Syntax+        GHC.JS.Transform         GHC.LanguageExtensions         GHC.LanguageExtensions.Type         GHC.Lexeme+        GHC.Linker.Config         GHC.Linker.Static.Utils         GHC.Linker.Types         GHC.Parser@@ -359,21 +424,27 @@         GHC.Parser.HaddockLex         GHC.Parser.Header         GHC.Parser.Lexer+        GHC.Parser.Lexer.Interface+        GHC.Parser.Lexer.String         GHC.Parser.PostProcess         GHC.Parser.PostProcess.Haddock+        GHC.Parser.String         GHC.Parser.Types         GHC.Platform         GHC.Platform.AArch64         GHC.Platform.ARM         GHC.Platform.ArchOS         GHC.Platform.Constants-        GHC.Platform.LoongArch64+        GHC.Platform.LA64         GHC.Platform.NoRegs         GHC.Platform.PPC         GHC.Platform.Profile         GHC.Platform.RISCV64         GHC.Platform.Reg         GHC.Platform.Reg.Class+        GHC.Platform.Reg.Class.NoVectors+        GHC.Platform.Reg.Class.Separate+        GHC.Platform.Reg.Class.Unified         GHC.Platform.Regs         GHC.Platform.S390X         GHC.Platform.Wasm32@@ -385,38 +456,53 @@         GHC.Runtime.Context         GHC.Runtime.Eval.Types         GHC.Runtime.Heap.Layout-        GHC.Runtime.Interpreter         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         GHC.StgToCmm.Config         GHC.StgToCmm.Types+        GHC.StgToJS.Linker.Types+        GHC.StgToJS.Object+        GHC.StgToJS.Symbols+        GHC.StgToJS.Types         GHC.SysTools.BaseDir         GHC.SysTools.Terminal         GHC.Tc.Errors.Hole.FitTypes+        GHC.Tc.Errors.Hole.Plugin         GHC.Tc.Errors.Ppr         GHC.Tc.Errors.Types+        GHC.Tc.Errors.Types.PromotionErr         GHC.Tc.Solver.InertSet         GHC.Tc.Solver.Types         GHC.Tc.Types+        GHC.Tc.Types.BasicTypes         GHC.Tc.Types.Constraint+        GHC.Tc.Types.CtLoc+        GHC.Tc.Types.ErrCtxt         GHC.Tc.Types.Evidence+        GHC.Tc.Types.LclEnv         GHC.Tc.Types.Origin         GHC.Tc.Types.Rank+        GHC.Tc.Types.TH+        GHC.Tc.Types.TcRef         GHC.Tc.Utils.TcType+        GHC.Tc.Zonk.Monad         GHC.Types.Annotations         GHC.Types.Avail         GHC.Types.Basic-        GHC.Types.BreakInfo         GHC.Types.CompleteMatch         GHC.Types.CostCentre         GHC.Types.CostCentre.State         GHC.Types.Cpr+        GHC.Types.DefaultEnv         GHC.Types.Demand         GHC.Types.Error         GHC.Types.Error.Codes@@ -425,6 +511,7 @@         GHC.Types.Fixity.Env         GHC.Types.ForeignCall         GHC.Types.ForeignStubs+        GHC.Types.GREInfo         GHC.Types.Hint         GHC.Types.Hint.Ppr         GHC.Types.HpcInfo@@ -445,16 +532,21 @@         GHC.Types.ProfAuto         GHC.Types.RepType         GHC.Types.SafeHaskell+        GHC.Types.SaneDouble         GHC.Types.SourceError         GHC.Types.SourceFile         GHC.Types.SourceText+        GHC.Types.SptEntry         GHC.Types.SrcLoc         GHC.Types.Target+        GHC.Types.ThLevelIndex         GHC.Types.Tickish         GHC.Types.TyThing+        GHC.Types.TyThing.Ppr         GHC.Types.TypeEnv         GHC.Types.Unique         GHC.Types.Unique.DFM+        GHC.Types.Unique.DSM         GHC.Types.Unique.DSet         GHC.Types.Unique.FM         GHC.Types.Unique.Map@@ -471,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@@ -482,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@@ -518,10 +614,8 @@         GHC.Utils.Ppr.Colour         GHC.Utils.TmpFs         GHC.Utils.Trace-        GHC.Utils.Unique         GHC.Utils.Word64         GHC.Version-        GHCi.BinaryArray         GHCi.BreakArray         GHCi.FFI         GHCi.Message@@ -531,20 +625,14 @@         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic         Language.Haskell.Syntax.Binds-        Language.Haskell.Syntax.Concrete+        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+        Language.Haskell.Syntax.Specificity         Language.Haskell.Syntax.Type-        Language.Haskell.TH-        Language.Haskell.TH.LanguageExtensions-        Language.Haskell.TH.Lib-        Language.Haskell.TH.Lib.Internal-        Language.Haskell.TH.Lib.Map-        Language.Haskell.TH.Ppr-        Language.Haskell.TH.PprLib-        Language.Haskell.TH.Syntax
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -83,6 +83,8 @@       pc_OFFSET_StgEntCounter_link :: {-# UNPACK #-} !Int,       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,@@ -96,6 +98,7 @@       pc_OFFSET_StgStack_sp :: {-# UNPACK #-} !Int,       pc_OFFSET_StgStack_stack :: {-# UNPACK #-} !Int,       pc_OFFSET_StgUpdateFrame_updatee :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgOrigThunkInfoFrame_info_ptr :: {-# UNPACK #-} !Int,       pc_OFFSET_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,       pc_REP_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgFunInfoExtraRev :: {-# UNPACK #-} !Int,@@ -166,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+     ,v128,v129,v130,v131      ] -> PlatformConstants             { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0             , pc_STD_HDR_SIZE = fromIntegral v1@@ -247,56 +250,59 @@             , pc_OFFSET_StgEntCounter_link = fromIntegral v76             , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77             , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78-            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v79-            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v80-            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v81-            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v82-            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v83-            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v84-            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v85-            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v86-            , pc_OFFSET_StgTSO_cccs = fromIntegral v87-            , pc_OFFSET_StgTSO_stackobj = fromIntegral v88-            , pc_OFFSET_StgStack_sp = fromIntegral v89-            , pc_OFFSET_StgStack_stack = fromIntegral v90-            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v91-            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v92-            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v93-            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v94-            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v95-            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v96-            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v97-            , pc_MAX_SPEC_AP_SIZE = fromIntegral v98-            , pc_MIN_PAYLOAD_SIZE = fromIntegral v99-            , pc_MIN_INTLIKE = fromIntegral v100-            , pc_MAX_INTLIKE = fromIntegral v101-            , pc_MIN_CHARLIKE = fromIntegral v102-            , pc_MAX_CHARLIKE = fromIntegral v103-            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v104-            , pc_MAX_Vanilla_REG = fromIntegral v105-            , pc_MAX_Float_REG = fromIntegral v106-            , pc_MAX_Double_REG = fromIntegral v107-            , pc_MAX_Long_REG = fromIntegral v108-            , pc_MAX_XMM_REG = fromIntegral v109-            , pc_MAX_Real_Vanilla_REG = fromIntegral v110-            , pc_MAX_Real_Float_REG = fromIntegral v111-            , pc_MAX_Real_Double_REG = fromIntegral v112-            , pc_MAX_Real_XMM_REG = fromIntegral v113-            , pc_MAX_Real_Long_REG = fromIntegral v114-            , pc_RESERVED_C_STACK_BYTES = fromIntegral v115-            , pc_RESERVED_STACK_WORDS = fromIntegral v116-            , pc_AP_STACK_SPLIM = fromIntegral v117-            , pc_WORD_SIZE = fromIntegral v118-            , pc_CINT_SIZE = fromIntegral v119-            , pc_CLONG_SIZE = fromIntegral v120-            , pc_CLONG_LONG_SIZE = fromIntegral v121-            , pc_BITMAP_BITS_SHIFT = fromIntegral v122-            , pc_TAG_BITS = fromIntegral v123-            , pc_LDV_SHIFT = fromIntegral v124-            , pc_ILDV_CREATE_MASK = v125-            , pc_ILDV_STATE_CREATE = v126-            , pc_ILDV_STATE_USE = v127-            , pc_USE_INLINE_SRT_FIELD = 0 < v128+            , pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr = fromIntegral v79+            , 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
@@ -5,6 +5,8 @@   , cProjectName   , cBooterVersion   , cStage+  , cProjectUnitId+  , cGhcInternalUnitId   ) where  import GHC.Prelude.Basic@@ -21,7 +23,13 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "9.6.7"+cBooterVersion        = "9.12.1"  cStage                :: String cStage                = show (1 :: Int)++cProjectUnitId :: String+cProjectUnitId = "ghc-9.14.1-inplace"++cGhcInternalUnitId :: String+cGhcInternalUnitId = "ghc-internal-9.1401.0-inplace"
− ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl 
@@ -1,257 +0,0 @@-primOpCanFail Int8QuotOp = True-primOpCanFail Int8RemOp = True-primOpCanFail Int8QuotRemOp = True-primOpCanFail Word8QuotOp = True-primOpCanFail Word8RemOp = True-primOpCanFail Word8QuotRemOp = True-primOpCanFail Int16QuotOp = True-primOpCanFail Int16RemOp = True-primOpCanFail Int16QuotRemOp = True-primOpCanFail Word16QuotOp = True-primOpCanFail Word16RemOp = True-primOpCanFail Word16QuotRemOp = True-primOpCanFail Int32QuotOp = True-primOpCanFail Int32RemOp = True-primOpCanFail Int32QuotRemOp = True-primOpCanFail Word32QuotOp = True-primOpCanFail Word32RemOp = True-primOpCanFail Word32QuotRemOp = True-primOpCanFail Int64QuotOp = True-primOpCanFail Int64RemOp = True-primOpCanFail Word64QuotOp = True-primOpCanFail Word64RemOp = True-primOpCanFail IntQuotOp = True-primOpCanFail IntRemOp = True-primOpCanFail IntQuotRemOp = True-primOpCanFail WordQuotOp = True-primOpCanFail WordRemOp = True-primOpCanFail WordQuotRemOp = True-primOpCanFail WordQuotRem2Op = True-primOpCanFail DoubleDivOp = True-primOpCanFail DoubleLogOp = True-primOpCanFail DoubleLog1POp = True-primOpCanFail DoubleAsinOp = True-primOpCanFail DoubleAcosOp = True-primOpCanFail FloatDivOp = True-primOpCanFail FloatLogOp = True-primOpCanFail FloatLog1POp = True-primOpCanFail FloatAsinOp = True-primOpCanFail FloatAcosOp = True-primOpCanFail ReadArrayOp = True-primOpCanFail WriteArrayOp = True-primOpCanFail IndexArrayOp = True-primOpCanFail CopyArrayOp = True-primOpCanFail CopyMutableArrayOp = True-primOpCanFail CloneArrayOp = True-primOpCanFail CloneMutableArrayOp = True-primOpCanFail FreezeArrayOp = True-primOpCanFail ThawArrayOp = True-primOpCanFail CasArrayOp = True-primOpCanFail ReadSmallArrayOp = True-primOpCanFail WriteSmallArrayOp = True-primOpCanFail IndexSmallArrayOp = True-primOpCanFail CopySmallArrayOp = True-primOpCanFail CopySmallMutableArrayOp = True-primOpCanFail CloneSmallArrayOp = True-primOpCanFail CloneSmallMutableArrayOp = True-primOpCanFail FreezeSmallArrayOp = True-primOpCanFail ThawSmallArrayOp = True-primOpCanFail CasSmallArrayOp = True-primOpCanFail IndexByteArrayOp_Char = True-primOpCanFail IndexByteArrayOp_WideChar = True-primOpCanFail IndexByteArrayOp_Int = True-primOpCanFail IndexByteArrayOp_Word = True-primOpCanFail IndexByteArrayOp_Addr = True-primOpCanFail IndexByteArrayOp_Float = True-primOpCanFail IndexByteArrayOp_Double = True-primOpCanFail IndexByteArrayOp_StablePtr = True-primOpCanFail IndexByteArrayOp_Int8 = True-primOpCanFail IndexByteArrayOp_Int16 = True-primOpCanFail IndexByteArrayOp_Int32 = True-primOpCanFail IndexByteArrayOp_Int64 = True-primOpCanFail IndexByteArrayOp_Word8 = True-primOpCanFail IndexByteArrayOp_Word16 = True-primOpCanFail IndexByteArrayOp_Word32 = True-primOpCanFail IndexByteArrayOp_Word64 = True-primOpCanFail IndexByteArrayOp_Word8AsChar = True-primOpCanFail IndexByteArrayOp_Word8AsWideChar = True-primOpCanFail IndexByteArrayOp_Word8AsInt = True-primOpCanFail IndexByteArrayOp_Word8AsWord = True-primOpCanFail IndexByteArrayOp_Word8AsAddr = True-primOpCanFail IndexByteArrayOp_Word8AsFloat = True-primOpCanFail IndexByteArrayOp_Word8AsDouble = True-primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True-primOpCanFail IndexByteArrayOp_Word8AsInt16 = True-primOpCanFail IndexByteArrayOp_Word8AsInt32 = True-primOpCanFail IndexByteArrayOp_Word8AsInt64 = True-primOpCanFail IndexByteArrayOp_Word8AsWord16 = True-primOpCanFail IndexByteArrayOp_Word8AsWord32 = True-primOpCanFail IndexByteArrayOp_Word8AsWord64 = True-primOpCanFail ReadByteArrayOp_Char = True-primOpCanFail ReadByteArrayOp_WideChar = True-primOpCanFail ReadByteArrayOp_Int = True-primOpCanFail ReadByteArrayOp_Word = True-primOpCanFail ReadByteArrayOp_Addr = True-primOpCanFail ReadByteArrayOp_Float = True-primOpCanFail ReadByteArrayOp_Double = True-primOpCanFail ReadByteArrayOp_StablePtr = True-primOpCanFail ReadByteArrayOp_Int8 = True-primOpCanFail ReadByteArrayOp_Int16 = True-primOpCanFail ReadByteArrayOp_Int32 = True-primOpCanFail ReadByteArrayOp_Int64 = True-primOpCanFail ReadByteArrayOp_Word8 = True-primOpCanFail ReadByteArrayOp_Word16 = True-primOpCanFail ReadByteArrayOp_Word32 = True-primOpCanFail ReadByteArrayOp_Word64 = True-primOpCanFail ReadByteArrayOp_Word8AsChar = True-primOpCanFail ReadByteArrayOp_Word8AsWideChar = True-primOpCanFail ReadByteArrayOp_Word8AsInt = True-primOpCanFail ReadByteArrayOp_Word8AsWord = True-primOpCanFail ReadByteArrayOp_Word8AsAddr = True-primOpCanFail ReadByteArrayOp_Word8AsFloat = True-primOpCanFail ReadByteArrayOp_Word8AsDouble = True-primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True-primOpCanFail ReadByteArrayOp_Word8AsInt16 = True-primOpCanFail ReadByteArrayOp_Word8AsInt32 = True-primOpCanFail ReadByteArrayOp_Word8AsInt64 = True-primOpCanFail ReadByteArrayOp_Word8AsWord16 = True-primOpCanFail ReadByteArrayOp_Word8AsWord32 = True-primOpCanFail ReadByteArrayOp_Word8AsWord64 = True-primOpCanFail WriteByteArrayOp_Char = True-primOpCanFail WriteByteArrayOp_WideChar = True-primOpCanFail WriteByteArrayOp_Int = True-primOpCanFail WriteByteArrayOp_Word = True-primOpCanFail WriteByteArrayOp_Addr = True-primOpCanFail WriteByteArrayOp_Float = True-primOpCanFail WriteByteArrayOp_Double = True-primOpCanFail WriteByteArrayOp_StablePtr = True-primOpCanFail WriteByteArrayOp_Int8 = True-primOpCanFail WriteByteArrayOp_Int16 = True-primOpCanFail WriteByteArrayOp_Int32 = True-primOpCanFail WriteByteArrayOp_Int64 = True-primOpCanFail WriteByteArrayOp_Word8 = True-primOpCanFail WriteByteArrayOp_Word16 = True-primOpCanFail WriteByteArrayOp_Word32 = True-primOpCanFail WriteByteArrayOp_Word64 = True-primOpCanFail WriteByteArrayOp_Word8AsChar = True-primOpCanFail WriteByteArrayOp_Word8AsWideChar = True-primOpCanFail WriteByteArrayOp_Word8AsInt = True-primOpCanFail WriteByteArrayOp_Word8AsWord = True-primOpCanFail WriteByteArrayOp_Word8AsAddr = True-primOpCanFail WriteByteArrayOp_Word8AsFloat = True-primOpCanFail WriteByteArrayOp_Word8AsDouble = True-primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True-primOpCanFail WriteByteArrayOp_Word8AsInt16 = True-primOpCanFail WriteByteArrayOp_Word8AsInt32 = True-primOpCanFail WriteByteArrayOp_Word8AsInt64 = True-primOpCanFail WriteByteArrayOp_Word8AsWord16 = True-primOpCanFail WriteByteArrayOp_Word8AsWord32 = True-primOpCanFail WriteByteArrayOp_Word8AsWord64 = True-primOpCanFail CompareByteArraysOp = True-primOpCanFail CopyByteArrayOp = True-primOpCanFail CopyMutableByteArrayOp = True-primOpCanFail CopyByteArrayToAddrOp = True-primOpCanFail CopyMutableByteArrayToAddrOp = True-primOpCanFail CopyAddrToByteArrayOp = True-primOpCanFail SetByteArrayOp = True-primOpCanFail AtomicReadByteArrayOp_Int = True-primOpCanFail AtomicWriteByteArrayOp_Int = True-primOpCanFail CasByteArrayOp_Int = True-primOpCanFail CasByteArrayOp_Int8 = True-primOpCanFail CasByteArrayOp_Int16 = True-primOpCanFail CasByteArrayOp_Int32 = True-primOpCanFail CasByteArrayOp_Int64 = True-primOpCanFail FetchAddByteArrayOp_Int = True-primOpCanFail FetchSubByteArrayOp_Int = True-primOpCanFail FetchAndByteArrayOp_Int = True-primOpCanFail FetchNandByteArrayOp_Int = True-primOpCanFail FetchOrByteArrayOp_Int = True-primOpCanFail FetchXorByteArrayOp_Int = True-primOpCanFail IndexOffAddrOp_Char = True-primOpCanFail IndexOffAddrOp_WideChar = True-primOpCanFail IndexOffAddrOp_Int = True-primOpCanFail IndexOffAddrOp_Word = True-primOpCanFail IndexOffAddrOp_Addr = True-primOpCanFail IndexOffAddrOp_Float = True-primOpCanFail IndexOffAddrOp_Double = True-primOpCanFail IndexOffAddrOp_StablePtr = True-primOpCanFail IndexOffAddrOp_Int8 = True-primOpCanFail IndexOffAddrOp_Int16 = True-primOpCanFail IndexOffAddrOp_Int32 = True-primOpCanFail IndexOffAddrOp_Int64 = True-primOpCanFail IndexOffAddrOp_Word8 = True-primOpCanFail IndexOffAddrOp_Word16 = True-primOpCanFail IndexOffAddrOp_Word32 = True-primOpCanFail IndexOffAddrOp_Word64 = True-primOpCanFail ReadOffAddrOp_Char = True-primOpCanFail ReadOffAddrOp_WideChar = True-primOpCanFail ReadOffAddrOp_Int = True-primOpCanFail ReadOffAddrOp_Word = True-primOpCanFail ReadOffAddrOp_Addr = True-primOpCanFail ReadOffAddrOp_Float = True-primOpCanFail ReadOffAddrOp_Double = True-primOpCanFail ReadOffAddrOp_StablePtr = True-primOpCanFail ReadOffAddrOp_Int8 = True-primOpCanFail ReadOffAddrOp_Int16 = True-primOpCanFail ReadOffAddrOp_Int32 = True-primOpCanFail ReadOffAddrOp_Int64 = True-primOpCanFail ReadOffAddrOp_Word8 = True-primOpCanFail ReadOffAddrOp_Word16 = True-primOpCanFail ReadOffAddrOp_Word32 = True-primOpCanFail ReadOffAddrOp_Word64 = True-primOpCanFail WriteOffAddrOp_Char = True-primOpCanFail WriteOffAddrOp_WideChar = True-primOpCanFail WriteOffAddrOp_Int = True-primOpCanFail WriteOffAddrOp_Word = True-primOpCanFail WriteOffAddrOp_Addr = True-primOpCanFail WriteOffAddrOp_Float = True-primOpCanFail WriteOffAddrOp_Double = True-primOpCanFail WriteOffAddrOp_StablePtr = True-primOpCanFail WriteOffAddrOp_Int8 = True-primOpCanFail WriteOffAddrOp_Int16 = True-primOpCanFail WriteOffAddrOp_Int32 = True-primOpCanFail WriteOffAddrOp_Int64 = True-primOpCanFail WriteOffAddrOp_Word8 = True-primOpCanFail WriteOffAddrOp_Word16 = True-primOpCanFail WriteOffAddrOp_Word32 = True-primOpCanFail WriteOffAddrOp_Word64 = True-primOpCanFail InterlockedExchange_Addr = True-primOpCanFail InterlockedExchange_Word = True-primOpCanFail CasAddrOp_Addr = True-primOpCanFail CasAddrOp_Word = True-primOpCanFail CasAddrOp_Word8 = True-primOpCanFail CasAddrOp_Word16 = True-primOpCanFail CasAddrOp_Word32 = True-primOpCanFail CasAddrOp_Word64 = True-primOpCanFail FetchAddAddrOp_Word = True-primOpCanFail FetchSubAddrOp_Word = True-primOpCanFail FetchAndAddrOp_Word = True-primOpCanFail FetchNandAddrOp_Word = True-primOpCanFail FetchOrAddrOp_Word = True-primOpCanFail FetchXorAddrOp_Word = True-primOpCanFail AtomicReadAddrOp_Word = True-primOpCanFail AtomicWriteAddrOp_Word = True-primOpCanFail AtomicModifyMutVar2Op = True-primOpCanFail AtomicModifyMutVar_Op = True-primOpCanFail RaiseOp = True-primOpCanFail RaiseUnderflowOp = True-primOpCanFail RaiseOverflowOp = True-primOpCanFail RaiseDivZeroOp = True-primOpCanFail ReallyUnsafePtrEqualityOp = True-primOpCanFail (VecInsertOp _ _ _) = True-primOpCanFail (VecDivOp _ _ _) = True-primOpCanFail (VecQuotOp _ _ _) = True-primOpCanFail (VecRemOp _ _ _) = True-primOpCanFail (VecIndexByteArrayOp _ _ _) = True-primOpCanFail (VecReadByteArrayOp _ _ _) = True-primOpCanFail (VecWriteByteArrayOp _ _ _) = True-primOpCanFail (VecIndexOffAddrOp _ _ _) = True-primOpCanFail (VecReadOffAddrOp _ _ _) = True-primOpCanFail (VecWriteOffAddrOp _ _ _) = True-primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True-primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True-primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True-primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True-primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True-primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True-primOpCanFail _ = False
ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -52,21 +52,27 @@ primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall  primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall  primOpCodeSize WriteArrayOp = 2+primOpCodeSize UnsafeFreezeByteArrayOp = 0+primOpCodeSize UnsafeThawByteArrayOp = 0 primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4 primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4-primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4-primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayNonOverlappingOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyAddrToAddrOp =  primOpCodeSizeForeignCall +primOpCodeSize CopyAddrToAddrNonOverlappingOp =  primOpCodeSizeForeignCall  primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize SetAddrRangeOp =  primOpCodeSizeForeignCall  primOpCodeSize AddrToIntOp = 0 primOpCodeSize IntToAddrOp = 0 primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall  primOpCodeSize RaiseUnderflowOp =  primOpCodeSizeForeignCall  primOpCodeSize RaiseOverflowOp =  primOpCodeSizeForeignCall  primOpCodeSize RaiseDivZeroOp =  primOpCodeSizeForeignCall -primOpCodeSize TouchOp =  0 +primOpCodeSize TouchOp = 0 primOpCodeSize ParOp =  primOpCodeSizeForeignCall  primOpCodeSize SparkOp =  primOpCodeSizeForeignCall  primOpCodeSize AddrToAnyOp = 0 primOpCodeSize AnyToAddrOp = 0-primOpCodeSize _ =  primOpCodeSizeDefault +primOpCodeSize _thisOp =  primOpCodeSizeDefault
ghc-lib/stage0/compiler/build/primop-commutable.hs-incl view
@@ -47,12 +47,16 @@ commutableOp WordXorOp = True commutableOp DoubleEqOp = True commutableOp DoubleNeOp = True+commutableOp DoubleMinOp = True+commutableOp DoubleMaxOp = True commutableOp DoubleAddOp = True commutableOp DoubleMulOp = True commutableOp FloatEqOp = True commutableOp FloatNeOp = True+commutableOp FloatMinOp = True+commutableOp FloatMaxOp = True commutableOp FloatAddOp = True commutableOp FloatMulOp = True commutableOp (VecAddOp _ _ _) = True commutableOp (VecMulOp _ _ _) = True-commutableOp _ = False+commutableOp _thisOp = False
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view

file too large to diff

+ ghc-lib/stage0/compiler/build/primop-deprecations.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-docs.hs-incl view

file too large to diff

+ ghc-lib/stage0/compiler/build/primop-effects.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-fixity.hs-incl view

file too large to diff

− ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl

file too large to diff

+ ghc-lib/stage0/compiler/build/primop-is-cheap.hs-incl view

file too large to diff

+ ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-list.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-tag.hs-incl view

file too large to diff

ghc-lib/stage0/lib/llvm-passes view

file too large to diff

ghc-lib/stage0/lib/llvm-targets view

file too large to diff

ghc-lib/stage0/lib/settings view

file too large to diff

ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view

file too large to diff

+ ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/Prim.hs view

file too large to diff

+ ghc-lib/stage0/libraries/ghc-internal/build/GHC/Internal/PrimopWrappers.hs view

file too large to diff

ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view

file too large to diff

ghc-lib/stage0/rts/build/include/ghcautoconf.h view

file too large to diff

ghc-lib/stage0/rts/build/include/ghcplatform.h view

file too large to diff

ghc/ghc-bin.cabal view

file too large to diff

+ libraries/containers/containers/include/containers.h view

file too large to diff

+ libraries/ghc-boot-th/GHC/Boot/TH/Lib/Map.hs view

file too large to diff

+ libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs view

file too large to diff

+ libraries/ghc-boot-th/GHC/Boot/TH/PprLib.hs view

file too large to diff

+ libraries/ghc-boot-th/GHC/Boot/TH/Syntax.hs view

file too large to diff

libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs view

file too large to diff

libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs view

file too large to diff

libraries/ghc-boot-th/GHC/Lexeme.hs view

file too large to diff

libraries/ghc-boot-th/ghc-boot-th.cabal view

file too large to diff

libraries/ghc-boot/GHC/BaseDir.hs view

file too large to diff

libraries/ghc-boot/GHC/Data/ShortText.hs view

file too large to diff

libraries/ghc-boot/GHC/Data/SizedSeq.hs view

file too large to diff

− libraries/ghc-boot/GHC/Platform/ArchOS.hs

file too large to diff

libraries/ghc-boot/GHC/Serialized.hs view

file too large to diff

libraries/ghc-boot/GHC/Settings/Utils.hs view

file too large to diff

libraries/ghc-boot/GHC/Utils/Encoding.hs view

file too large to diff

libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs view

file too large to diff

libraries/ghc-boot/ghc-boot.cabal view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap.hs view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view

file too large to diff

+ libraries/ghc-heap/GHC/Exts/Heap/Constants.hs view

file too large to diff

− libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc view

file too large to diff

+ libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs view

file too large to diff

− libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc

file too large to diff

+ libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs view

file too large to diff

− libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc

file too large to diff

+ libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs view

file too large to diff

− libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs view

file too large to diff

libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc view

file too large to diff

− libraries/ghc-heap/cbits/HeapPrim.cmm

file too large to diff

libraries/ghc-heap/ghc-heap.cabal view

file too large to diff

+ libraries/ghc-internal/cbits/HeapPrim.cmm view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/Lexeme.hs view

file too large to diff

+ libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs view

file too large to diff

+ libraries/ghc-platform/ghc-platform.cabal view

file too large to diff

+ libraries/ghc-platform/src/GHC/Platform/ArchOS.hs view

file too large to diff

− libraries/ghci/GHCi/BinaryArray.hs

file too large to diff

libraries/ghci/GHCi/BreakArray.hs view

file too large to diff

libraries/ghci/GHCi/FFI.hsc view

file too large to diff

libraries/ghci/GHCi/Message.hs view

file too large to diff

libraries/ghci/GHCi/RemoteTypes.hs view

file too large to diff

libraries/ghci/GHCi/ResolvedBCO.hs view

file too large to diff

libraries/ghci/GHCi/TH/Binary.hs view

file too large to diff

libraries/ghci/ghci.cabal view

file too large to diff

− libraries/template-haskell/Language/Haskell/TH.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/LanguageExtensions.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/Lib.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/Ppr.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/PprLib.hs

file too large to diff

− libraries/template-haskell/Language/Haskell/TH/Syntax.hs

file too large to diff

libraries/template-haskell/template-haskell.cabal view

file too large to diff

+ rts/include/stg/MachRegs/arm32.h view

file too large to diff

+ rts/include/stg/MachRegs/arm64.h view

file too large to diff

+ rts/include/stg/MachRegs/loongarch64.h view

file too large to diff

+ rts/include/stg/MachRegs/ppc.h view

file too large to diff

+ rts/include/stg/MachRegs/riscv64.h view

file too large to diff

+ rts/include/stg/MachRegs/s390x.h view

file too large to diff

+ rts/include/stg/MachRegs/wasm32.h view

file too large to diff

+ rts/include/stg/MachRegs/x86.h view

file too large to diff